Commit 71ea27ee authored by Glenn Morris's avatar Glenn Morris

Whitespace only.

parent 6eb61c70
......@@ -77,36 +77,36 @@
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
(let* ((month (extract-calendar-month date))
(day (extract-calendar-day date))
(year (extract-calendar-year date))
(prior-years (+ (1- year) 1844))
(leap-days (- (+ (/ prior-years 4) ; leap days in prior years
(- (/ prior-years 100))
(/ prior-years 400))
calendar-bahai-leap-base)))
(+ (1- calendar-bahai-epoch) ; days before epoch
(* 365 (1- year)) ; days in prior years
(day (extract-calendar-day date))
(year (extract-calendar-year date))
(prior-years (+ (1- year) 1844))
(leap-days (- (+ (/ prior-years 4) ; leap days in prior years
(- (/ prior-years 100))
(/ prior-years 400))
calendar-bahai-leap-base)))
(+ (1- calendar-bahai-epoch) ; days before epoch
(* 365 (1- year)) ; days in prior years
leap-days
(calendar-sum m 1 (< m month) 19)
(if (= month 19) 4 0)
day))) ; days so far this month
day))) ; days so far this month
(defun calendar-bahai-from-absolute (date)
"Bahá'í year corresponding to the absolute DATE."
(if (< date calendar-bahai-epoch)
(list 0 0 0) ; pre-Bahá'í date
(let* ((greg (calendar-gregorian-from-absolute date))
(year (+ (- (extract-calendar-year greg) 1844)
(if (or (> (extract-calendar-month greg) 3)
(and (= (extract-calendar-month greg) 3)
(>= (extract-calendar-day greg) 21)))
1 0)))
(year (+ (- (extract-calendar-year greg) 1844)
(if (or (> (extract-calendar-month greg) 3)
(and (= (extract-calendar-month greg) 3)
(>= (extract-calendar-day greg) 21)))
1 0)))
(month ; search forward from Baha
(1+ (calendar-sum m 1
(> date
(calendar-absolute-from-bahai
(list m 19 year)))
1)))
(> date
(calendar-absolute-from-bahai
(list m 19 year)))
1)))
(day ; calculate the day by subtraction
(- date
(1- (calendar-absolute-from-bahai (list month 1 year))))))
......@@ -117,25 +117,25 @@ Gregorian date Sunday, December 31, 1 BC."
"String of Bahá'í date of Gregorian DATE.
Defaults to today's date if DATE is not given."
(let* ((bahai-date (calendar-bahai-from-absolute
(calendar-absolute-from-gregorian
(or date (calendar-current-date)))))
(calendar-absolute-from-gregorian
(or date (calendar-current-date)))))
(y (extract-calendar-year bahai-date))
(m (extract-calendar-month bahai-date))
(d (extract-calendar-day bahai-date)))
(let ((monthname
(if (and (= m 19)
(<= d 0))
"Ayyám-i-Há"
(aref calendar-bahai-month-name-array (1- m))))
(day (int-to-string
(if (<= d 0)
(if (calendar-bahai-leap-year-p y)
(+ d 5)
(+ d 4))
d)))
(dayname nil)
(month (int-to-string m))
(year (int-to-string y)))
(if (and (= m 19)
(<= d 0))
"Ayyám-i-Há"
(aref calendar-bahai-month-name-array (1- m))))
(day (int-to-string
(if (<= d 0)
(if (calendar-bahai-leap-year-p y)
(+ d 5)
(+ d 4))
d)))
(dayname nil)
(month (int-to-string m))
(year (int-to-string y)))
(mapconcat 'eval calendar-date-display-form ""))))
;;;###cal-autoload
......@@ -166,15 +166,15 @@ Echo Bahá'í date unless NOECHO is t."
(calendar-absolute-from-gregorian today))))))
(completion-ignore-case t)
(month (cdr (assoc
(completing-read
"Bahá'í calendar month name: "
(mapcar 'list
(append calendar-bahai-month-name-array nil))
nil t)
(completing-read
"Bahá'í calendar month name: "
(mapcar 'list
(append calendar-bahai-month-name-array nil))
nil t)
(calendar-make-alist calendar-bahai-month-name-array
1))))
(day (calendar-read "Bahá'í calendar day (1-19): "
(lambda (x) (and (< 0 x) (<= x 19))))))
(lambda (x) (and (< 0 x) (<= x 19))))))
(list (list month day year))))
(defvar displayed-month)
......@@ -187,15 +187,15 @@ If MONTH, DAY (Bahá'í) is visible, the value returned is corresponding
Gregorian date in the form of the list (((month day year) STRING)). Returns
nil if it is not visible in the current calendar window."
(let* ((bahai-date (calendar-bahai-from-absolute
(calendar-absolute-from-gregorian
(list displayed-month 15 displayed-year))))
(calendar-absolute-from-gregorian
(list displayed-month 15 displayed-year))))
(m (extract-calendar-month bahai-date))
(y (extract-calendar-year bahai-date))
(date))
(date))
(if (< m 1)
nil ; Bahá'í calendar doesn't apply
nil ; Bahá'í calendar doesn't apply
(increment-calendar-month m y (- 10 month))
(if (> m 7) ; Bahá'í date might be visible
(if (> m 7) ; Bahá'í date might be visible
(let ((date (calendar-gregorian-from-absolute
(calendar-absolute-from-bahai (list month day y)))))
(if (calendar-date-is-visible-p date)
......@@ -406,7 +406,7 @@ part of `nongregorian-diary-marking-hook'."
(cdr (assoc-string
mm-name
(calendar-make-alist
calendar-bahai-month-name-array)
calendar-bahai-month-name-array)
t)))))
(calendar-bahai-mark-date-pattern mm dd yy)))))
(setq d (cdr d)))))
......@@ -427,15 +427,15 @@ A value of 0 in any position is a wildcard."
(mark-visible-calendar-date date)))
;; Month and day in any year--this taken from the holiday stuff.
(let* ((bahai-date (calendar-bahai-from-absolute
(calendar-absolute-from-gregorian
(list displayed-month 15 displayed-year))))
(calendar-absolute-from-gregorian
(list displayed-month 15 displayed-year))))
(m (extract-calendar-month bahai-date))
(y (extract-calendar-year bahai-date))
(date))
(if (< m 1)
nil ; Bahá'í calendar doesn't apply
nil ; Bahá'í calendar doesn't apply
(increment-calendar-month m y (- 10 month))
(if (> m 7) ; Bahá'í date might be visible
(if (> m 7) ; Bahá'í date might be visible
(let ((date (calendar-gregorian-from-absolute
(calendar-absolute-from-bahai
(list month day y)))))
......@@ -457,18 +457,19 @@ A value of 0 in any position is a wildcard."
(calendar-absolute-from-gregorian
(list m (calendar-last-day-of-month m y) y)))
(calendar-for-loop date from first-date to last-date do
(let* ((b-date (calendar-bahai-from-absolute date))
(i-month (extract-calendar-month b-date))
(i-day (extract-calendar-day b-date))
(i-year (extract-calendar-year b-date)))
(and (or (zerop month)
(= month i-month))
(or (zerop day)
(= day i-day))
(or (zerop year)
(= year i-year))
(mark-visible-calendar-date
(calendar-gregorian-from-absolute date)))))))))
(let* ((b-date (calendar-bahai-from-absolute date))
(i-month (extract-calendar-month b-date))
(i-day (extract-calendar-day b-date))
(i-year (extract-calendar-year b-date)))
(and (or (zerop month)
(= month i-month))
(or (zerop day)
(= day i-day))
(or (zerop year)
(= year i-year))
(mark-visible-calendar-date
(calendar-gregorian-from-absolute
date)))))))))
;;;###cal-autoload
(defun diary-bahai-insert-entry (arg)
......
......@@ -4,7 +4,7 @@
;; 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Paul Eggert <eggert@twinsun.com>
;; Edward M. Reingold <reingold@cs.uiuc.edu>
;; Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: daylight saving time, calendar, diary, holidays
......@@ -113,15 +113,15 @@ high and low 16 bits, respectively, of the number of seconds since
Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on
absolute date ABS-DATE is the equivalent moment to X."
(let* ((h (car x))
(xtail (cdr x))
(xtail (cdr x))
(l (+ utc-diff (if (numberp xtail) xtail (car xtail))))
(u (+ (* 512 (mod h 675)) (floor l 128))))
;; Overflow is a terrible thing!
(cons (+ calendar-system-time-basis
;; floor((2^16 h +l) / (60*60*24))
(* 512 (floor h 675)) (floor u 675))
;; (2^16 h +l) mod (60*60*24)
(+ (* (mod u 675) 128) (mod l 128)))))
;; floor((2^16 h +l) / (60*60*24))
(* 512 (floor h 675)) (floor u 675))
;; (2^16 h +l) mod (60*60*24)
(+ (* (mod u 675) 128) (mod l 128)))))
(defun calendar-time-from-absolute (abs-date s)
"Time of absolute date ABS-DATE, S seconds after midnight.
......@@ -143,12 +143,12 @@ midnight UTC on absolute date ABS-DATE."
"Return the time of the next time zone transition after TIME.
Both TIME and the result are acceptable arguments to `current-time-zone'.
Return nil if no such transition can be found."
(let* ((base 65536);; 2^16 = base of current-time output
(quarter-multiple 120);; approx = (seconds per quarter year) / base
(time-zone (current-time-zone time))
(time-utc-diff (car time-zone))
(let* ((base 65536) ;; 2^16 = base of current-time output
(quarter-multiple 120) ;; approx = (seconds per quarter year) / base
(time-zone (current-time-zone time))
(time-utc-diff (car time-zone))
hi
hi-zone
hi-zone
(hi-utc-diff time-utc-diff)
(quarters '(2 1 3)))
;; Heuristic: probe the time zone offset in the next three calendar
......@@ -166,21 +166,21 @@ Return nil if no such transition can be found."
;; Set LO to TIME, and then binary search to increase LO and decrease HI
;; until LO is just before and HI is just after the time zone transition.
(let* ((tail (cdr time))
(lo (cons (car time) (if (numberp tail) tail (car tail))))
probe)
(lo (cons (car time) (if (numberp tail) tail (car tail))))
probe)
(while
;; Set PROBE to halfway between LO and HI, rounding down.
;; If PROBE equals LO, we are done.
(let* ((lsum (+ (cdr lo) (cdr hi)))
(hsum (+ (car lo) (car hi) (/ lsum base)))
(hsumodd (logand 1 hsum)))
(setq probe (cons (/ (- hsum hsumodd) 2)
(/ (+ (* hsumodd base) (% lsum base)) 2)))
(not (equal lo probe)))
;; Set either LO or HI to PROBE, depending on probe results.
(if (eq (car (current-time-zone probe)) hi-utc-diff)
(setq hi probe)
(setq lo probe)))
;; Set PROBE to halfway between LO and HI, rounding down.
;; If PROBE equals LO, we are done.
(let* ((lsum (+ (cdr lo) (cdr hi)))
(hsum (+ (car lo) (car hi) (/ lsum base)))
(hsumodd (logand 1 hsum)))
(setq probe (cons (/ (- hsum hsumodd) 2)
(/ (+ (* hsumodd base) (% lsum base)) 2)))
(not (equal lo probe)))
;; Set either LO or HI to PROBE, depending on probe results.
(if (eq (car (current-time-zone probe)) hi-utc-diff)
(setq hi probe)
(setq lo probe)))
hi))))
(defun calendar-time-zone-daylight-rules (abs-date utc-diff)
......@@ -188,69 +188,70 @@ Return nil if no such transition can be found."
ABS-DATE must specify a day that contains a daylight saving transition.
The result has the proper form for `calendar-daylight-savings-starts'."
(let* ((date (calendar-gregorian-from-absolute abs-date))
(weekday (% abs-date 7))
(m (extract-calendar-month date))
(d (extract-calendar-day date))
(y (extract-calendar-year date))
(weekday (% abs-date 7))
(m (extract-calendar-month date))
(d (extract-calendar-day date))
(y (extract-calendar-year date))
(last (calendar-last-day-of-month m y))
(candidate-rules
(append
;; Day D of month M.
(list (list 'list m d 'year))
;; The first WEEKDAY of month M.
(candidate-rules
(append
;; Day D of month M.
(list (list 'list m d 'year))
;; The first WEEKDAY of month M.
(if (< d 8)
(list (list 'calendar-nth-named-day 1 weekday m 'year)))
;; The last WEEKDAY of month M.
;; The last WEEKDAY of month M.
(if (> d (- last 7))
(list (list 'calendar-nth-named-day -1 weekday m 'year)))
;; The first WEEKDAY after day J of month M, for D-6 < J <= D.
;; The first WEEKDAY after day J of month M, for D-6 < J <= D.
(let (l)
(calendar-for-loop j from (max 2 (- d 6)) to (min d (- last 8)) do
(setq l
(cons
(list 'calendar-nth-named-day 1 weekday m 'year j)
l)))
l)
;; 01-01 and 07-01 for this year's Persian calendar.
(if (and (= m 3) (<= 20 d) (<= d 21))
'((calendar-gregorian-from-absolute
(calendar-absolute-from-persian
(list 1 1 (- year 621))))))
(if (and (= m 9) (<= 22 d) (<= d 23))
'((calendar-gregorian-from-absolute
(calendar-absolute-from-persian
(list 7 1 (- year 621))))))))
(prevday-sec (- -1 utc-diff)) ;; last sec of previous local day
(year (1+ y)))
(setq l
(cons
(list 'calendar-nth-named-day
1 weekday m 'year j)
l)))
l)
;; 01-01 and 07-01 for this year's Persian calendar.
(if (and (= m 3) (<= 20 d) (<= d 21))
'((calendar-gregorian-from-absolute
(calendar-absolute-from-persian
(list 1 1 (- year 621))))))
(if (and (= m 9) (<= 22 d) (<= d 23))
'((calendar-gregorian-from-absolute
(calendar-absolute-from-persian
(list 7 1 (- year 621))))))))
(prevday-sec (- -1 utc-diff)) ;; last sec of previous local day
(year (1+ y)))
;; Scan through the next few years until only one rule remains.
(while
(let ((rules candidate-rules)
new-rules)
(while
(let*
((rule (car rules))
(date
;; The following is much faster than
;; (calendar-absolute-from-gregorian (eval rule)).
(cond ((eq (car rule) 'calendar-nth-named-day)
(eval (cons 'calendar-nth-named-absday (cdr rule))))
((eq (car rule) 'calendar-gregorian-from-absolute)
(eval (car (cdr rule))))
(t (let ((g (eval rule)))
(calendar-absolute-from-gregorian g))))))
(or (equal
(current-time-zone
(calendar-time-from-absolute date prevday-sec))
(current-time-zone
(calendar-time-from-absolute (1+ date) prevday-sec)))
(setq new-rules (cons rule new-rules)))
(setq rules (cdr rules))))
;; If no rules remain, just use the first candidate rule;
;; it's wrong in general, but it's right for at least one year.
(setq candidate-rules (if new-rules (nreverse new-rules)
(list (car candidate-rules))))
(setq year (1+ year))
(cdr candidate-rules)))
(let ((rules candidate-rules)
new-rules)
(while
(let*
((rule (car rules))
(date
;; The following is much faster than
;; (calendar-absolute-from-gregorian (eval rule)).
(cond ((eq (car rule) 'calendar-nth-named-day)
(eval (cons 'calendar-nth-named-absday (cdr rule))))
((eq (car rule) 'calendar-gregorian-from-absolute)
(eval (car (cdr rule))))
(t (let ((g (eval rule)))
(calendar-absolute-from-gregorian g))))))
(or (equal
(current-time-zone
(calendar-time-from-absolute date prevday-sec))
(current-time-zone
(calendar-time-from-absolute (1+ date) prevday-sec)))
(setq new-rules (cons rule new-rules)))
(setq rules (cdr rules))))
;; If no rules remain, just use the first candidate rule;
;; it's wrong in general, but it's right for at least one year.
(setq candidate-rules (if new-rules (nreverse new-rules)
(list (car candidate-rules))))
(setq year (1+ year))
(cdr candidate-rules)))
(car candidate-rules)))
;; TODO it might be better to extract this information directly from
......@@ -414,7 +415,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
(cadr (calendar-dst-find-startend year))
(nth 4 calendar-current-time-zone-cache))))
(if expr (eval expr)))
;; New US rules commencing 2007. ftp://elsie.nci.nih.gov/pub/.
;; New US rules commencing 2007. ftp://elsie.nci.nih.gov/pub/.
(and (not (zerop calendar-daylight-time-offset))
(calendar-nth-named-day 2 0 3 year))))
......@@ -425,7 +426,7 @@ This function respects the value of `calendar-dst-check-each-year-flag'."
(nth 2 (calendar-dst-find-startend year))
(nth 5 calendar-current-time-zone-cache))))
(if expr (eval expr)))
;; New US rules commencing 2007. ftp://elsie.nci.nih.gov/pub/.
;; New US rules commencing 2007. ftp://elsie.nci.nih.gov/pub/.
(and (not (zerop calendar-daylight-time-offset))
(calendar-nth-named-day 1 0 11 year))))
......@@ -469,12 +470,12 @@ Conversion to daylight saving time is done according to
`calendar-daylight-savings-offset'."
(let* ((rounded-abs-date (+ (calendar-absolute-from-gregorian date)
(/ (round (* 60 time)) 60.0 24.0)))
(/ (round (* 60 time)) 60.0 24.0)))
(dst (dst-in-effect rounded-abs-date))
(time-zone (if dst
calendar-daylight-time-zone-name
calendar-standard-time-zone-name))
(time (+ rounded-abs-date
(time-zone (if dst
calendar-daylight-time-zone-name
calendar-standard-time-zone-name))
(time (+ rounded-abs-date
(if dst (/ calendar-daylight-time-offset 24.0 60.0) 0))))
(list (calendar-gregorian-from-absolute (truncate time))
(* 24.0 (- time (truncate time)))
......
......@@ -44,10 +44,10 @@
(defun french-calendar-accents ()
"True if diacritical marks are available."
(and (or window-system
(terminal-coding-system))
(terminal-coding-system))
(or enable-multibyte-characters
(and (char-table-p standard-display-table)
(equal (aref standard-display-table 161) [161])))))
(and (char-table-p standard-display-table)
(equal (aref standard-display-table 161) [161])))))
(defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792))
"Absolute date of start of French Revolutionary calendar = September 22, 1792.")
......@@ -145,20 +145,22 @@ The absolute date is the number of days elapsed since the
(year ; search forward from the approximation
(+ approx
(calendar-sum y approx
(>= date (calendar-absolute-from-french (list 1 1 (1+ y))))
1)))
(>= date (calendar-absolute-from-french
(list 1 1 (1+ y))))
1)))
(month ; search forward from Vendemiaire
(1+ (calendar-sum m 1
(> date
(calendar-absolute-from-french
(list m
(french-calendar-last-day-of-month m year)
year)))
1)))
(> date
(calendar-absolute-from-french
(list m
(french-calendar-last-day-of-month
m year)
year)))
1)))
(day ; calculate the day by subtraction
(- date
(1- (calendar-absolute-from-french (list month 1 year))))))
(list month day year))))
(list month day year))))
;;;###cal-autoload
(defun calendar-french-date-string (&optional date)
......@@ -201,47 +203,47 @@ Defaults to today's date if DATE is not given."
Echo French Revolutionary date unless NOECHO is t."
(interactive
(let ((accents (french-calendar-accents))
(months (french-calendar-month-name-array))
(special-days (french-calendar-special-days-array)))
(months (french-calendar-month-name-array))
(special-days (french-calendar-special-days-array)))
(let* ((year
(progn
(calendar-read
(if accents
"Anne de la Rvolution (>0): "
"Anne'e de la Re'volution (>0): ")
(lambda (x) (> x 0))
(int-to-string
(extract-calendar-year
(calendar-french-from-absolute
(calendar-absolute-from-gregorian
(calendar-current-date))))))))
(month-list
(mapcar 'list
(append months
(if (french-calendar-leap-year-p year)
(mapcar
(lambda (x) (concat "Jour " x))
french-calendar-special-days-array)
(reverse
(cdr ; we don't want rev. day in a non-leap yr
(reverse
(mapcar
(lambda (x)
(concat "Jour " x))
special-days))))))))
(completion-ignore-case t)
(month (cdr (assoc-string
(progn
(calendar-read
(if accents
"Anne de la Rvolution (>0): "
"Anne'e de la Re'volution (>0): ")
(lambda (x) (> x 0))
(int-to-string
(extract-calendar-year
(calendar-french-from-absolute
(calendar-absolute-from-gregorian
(calendar-current-date))))))))
(month-list
(mapcar 'list
(append months
(if (french-calendar-leap-year-p year)
(mapcar
(lambda (x) (concat "Jour " x))
french-calendar-special-days-array)
(reverse
(cdr ; we don't want rev. day in a non-leap yr
(reverse
(mapcar
(lambda (x)
(concat "Jour " x))
special-days))))))))
(completion-ignore-case t)
(month (cdr (assoc-string
(completing-read
"Mois ou Sansculottide: "
month-list
nil t)
(calendar-make-alist month-list 1 'car) t)))
(day (if (> month 12)
(- month 12)
(calendar-read
"Jour (1-30): "
(lambda (x) (and (<= 1 x) (<= x 30))))))
(month (if (> month 12) 13 month)))
(calendar-make-alist month-list 1 'car) t)))
(day (if (> month 12)
(- month 12)
(calendar-read
"Jour (1-30): "
(lambda (x) (and (<= 1 x) (<= x 30))))))
(month (if (> month 12) 13 month)))
(list (list month day year)))))
(calendar-goto-date (calendar-gregorian-from-absolute
(calendar-absolute-from-french date)))
......
This diff is collapsed.
......@@ -4,7 +4,7 @@
;; 2006, 2007, 2008 Free Software Foundation, Inc.
;; Author: Stewart M. Clamen <clamen@cs.cmu.edu>
;; Edward M. Reingold <reingold@cs.uiuc.edu>
;; Edward M. Reingold <reingold@cs.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: Mayan calendar, Maya, calendar, diary
......@@ -100,12 +100,12 @@ but some use 1137140. Using 1232041 gives you Spinden's correlation; using
(condition-case condition
(progn
(while (< cc c)
(let* ((start (string-match "[0-9]+" str cc))
(end (match-end 0))
datum)
(setq datum (read (substring str start end)))
(setq rlc (cons datum rlc))
(setq cc end)))
(let* ((start (string-match "[0-9]+" str cc))
(end (match-end 0))
datum)
(setq datum (read (substring str start end)))
(setq rlc (cons datum rlc))
(setq cc end)))
(if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil)))
(invalid-read-syntax nil))