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))))))
"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
(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)
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)
(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)))))
(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)))))
(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)
;; 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
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.
"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
;; 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)
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
(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))))
(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))))
`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)))
(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.")
(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)
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
- "Année de la Révolution (>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
+ "Année de la Révolution (>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)))
(* 12 months-elapsed)
(* 793 (/ months-elapsed 1080))
(/ parts-elapsed 1080)))
- (parts ; conjunction parts
+ (parts ; conjunction parts
(+ (* 1080 (% hours-elapsed 24)) (% parts-elapsed 1080)))
- (day ; conjunction day
+ (day ; conjunction day
(+ 1 (* 29 months-elapsed) (/ hours-elapsed 24)))
(alternative-day
(if (or (>= parts 19440) ; if the new moon is at or after midday
- (and (= (% day 7) 2) ; ...or is on a Tuesday...
+ (and (= (% day 7) 2) ; ...or is on a Tuesday...
(>= parts 9924) ; at 9 hours, 204 parts or later...
- ;; of a common year...
+ ;; of a common year...
(not (hebrew-calendar-leap-year-p year)))
- (and (= (% day 7) 1) ; ...or is on a Monday...
+ (and (= (% day 7) 1) ; ...or is on a Monday...
(>= parts 16789) ; at 15 hours, 589 parts or later...
- ;; at the end of a leap year.
+ ;; at the end of a leap year.
(hebrew-calendar-leap-year-p (1- year))))
- ;; Then postpone Rosh HaShanah one day.
+ ;; Then postpone Rosh HaShanah one day.
(1+ day)
- ;; Else:
+ ;; Else:
day)))
;; If Rosh HaShanah would occur on Sunday, Wednesday, or Friday
(if (memq (% alternative-day 7) (list 0 3 5))
- ;; Then postpone it one (more) day and return.
+ ;; Then postpone it one (more) day and return.
(1+ alternative-day)
;; Else return.
alternative-day)))
(let* ((month (extract-calendar-month date))
(day (extract-calendar-day date))
(year (extract-calendar-year date)))
- (+ day ; days so far this month
- (if (< month 7) ; before Tishri
- ;; Then add days in prior months this year before and after Nisan.
+ (+ day ; days so far this month
+ (if (< month 7) ; before Tishri
+ ;; Then add days in prior months this year before and after Nisan.
(+ (calendar-sum
m 7 (<= m (hebrew-calendar-last-month-of-year year))
(hebrew-calendar-last-day-of-month m year))
(calendar-sum
m 1 (< m month)
(hebrew-calendar-last-day-of-month m year)))
- ;; Else add days in prior months this year.
+ ;; Else add days in prior months this year.
(calendar-sum
m 7 (< m month)
(hebrew-calendar-last-day-of-month m year)))
- (hebrew-calendar-elapsed-days year) ; days in prior years
- -1373429))) ; days elapsed before absolute date 1
+ (hebrew-calendar-elapsed-days year) ; days in prior years
+ -1373429))) ; days elapsed before absolute date 1
(defun calendar-hebrew-from-absolute (date)
"Compute the Hebrew date (month day year) corresponding to absolute DATE.
Gregorian date Sunday, December 31, 1 BC."
(let* ((greg-date (calendar-gregorian-from-absolute date))
(month (aref [9 10 11 12 1 2 3 4 7 7 7 8]
- (1- (extract-calendar-month greg-date))))
+ (1- (extract-calendar-month greg-date))))
(day)
(year (+ 3760 (extract-calendar-year greg-date))))
(while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year))))
- (setq year (1+ year)))
+ (setq year (1+ year)))
(let ((length (hebrew-calendar-last-month-of-year year)))
(while (> date
(calendar-absolute-from-hebrew
(defvar calendar-hebrew-month-name-array-common-year
["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
"Heshvan" "Kislev" "Teveth" "Shevat" "Adar"]
-"Array of strings giving the names of the Hebrew months in a common year.")
+ "Array of strings giving the names of the Hebrew months in a common year.")
(defvar calendar-hebrew-month-name-array-leap-year
["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
"Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"]
-"Array of strings giving the names of the Hebrew months in a leap year.")
+ "Array of strings giving the names of the Hebrew months in a leap year.")
;;;###cal-autoload
(defun calendar-hebrew-date-string (&optional date)
(mapcar 'list (append month-array nil))
(if (= year 3761)
(lambda (x)
- (let ((m (cdr
- (assoc-string
- (car x)
- (calendar-make-alist month-array)
- t))))
- (< 0
- (calendar-absolute-from-hebrew
- (list m
- (hebrew-calendar-last-day-of-month
- m year)
- year))))))
+ (let ((m (cdr
+ (assoc-string
+ (car x)
+ (calendar-make-alist month-array)
+ t))))
+ (< 0
+ (calendar-absolute-from-hebrew
+ (list m
+ (hebrew-calendar-last-day-of-month
+ m year)
+ year))))))
t)
(calendar-make-alist month-array 1) t)))
(last (hebrew-calendar-last-day-of-month month year))
"List of dates related to Rosh Hashanah, as visible in calendar window."
(if (or (< displayed-month 8)
(> displayed-month 11))
- nil ; none of the dates is visible
+ nil ; none of the dates is visible
(let* ((abs-r-h (calendar-absolute-from-hebrew
- (list 7 1 (+ displayed-year 3761))))
- (mandatory
- (list
- (list (calendar-gregorian-from-absolute abs-r-h)
- (format "Rosh HaShanah %d" (+ 3761 displayed-year)))
- (list (calendar-gregorian-from-absolute (+ abs-r-h 9))
- "Yom Kippur")
- (list (calendar-gregorian-from-absolute (+ abs-r-h 14))
- "Sukkot")
- (list (calendar-gregorian-from-absolute (+ abs-r-h 21))
- "Shemini Atzeret")
- (list (calendar-gregorian-from-absolute (+ abs-r-h 22))
- "Simchat Torah")))
+ (list 7 1 (+ displayed-year 3761))))
+ (mandatory
+ (list
+ (list (calendar-gregorian-from-absolute abs-r-h)
+ (format "Rosh HaShanah %d" (+ 3761 displayed-year)))
+ (list (calendar-gregorian-from-absolute (+ abs-r-h 9))
+ "Yom Kippur")
+ (list (calendar-gregorian-from-absolute (+ abs-r-h 14))
+ "Sukkot")
+ (list (calendar-gregorian-from-absolute (+ abs-r-h 21))
+ "Shemini Atzeret")
+ (list (calendar-gregorian-from-absolute (+ abs-r-h 22))
+ "Simchat Torah")))
(optional
(list
(list (calendar-gregorian-from-absolute
"Hol Hamoed Sukkot (fourth day)")
(list (calendar-gregorian-from-absolute (+ abs-r-h 20))
"Hoshanah Rabbah")))
- (output-list
- (holiday-filter-visible-calendar mandatory)))
+ (output-list
+ (holiday-filter-visible-calendar mandatory)))
(if all-hebrew-calendar-holidays
(setq output-list
(append
"List of dates related to Hanukkah, as visible in calendar window."
;; This test is only to speed things up a bit, it works fine without it.
(if (memq displayed-month
- '(10 11 12 1 2))
+ '(10 11 12 1 2))
(let ((m displayed-month)
- (y displayed-year))
- (increment-calendar-month m y 1)
- (let* ((h-y (extract-calendar-year
- (calendar-hebrew-from-absolute
- (calendar-absolute-from-gregorian
- (list m (calendar-last-day-of-month m y) y)))))
- (abs-h (calendar-absolute-from-hebrew (list 9 25 h-y))))
- (holiday-filter-visible-calendar
- (list
- (list (calendar-gregorian-from-absolute (1- abs-h))
- "Erev Hanukkah")
- (list (calendar-gregorian-from-absolute abs-h)
- "Hanukkah (first day)")
- (list (calendar-gregorian-from-absolute (1+ abs-h))
- "Hanukkah (second day)")
- (list (calendar-gregorian-from-absolute (+ abs-h 2))
- "Hanukkah (third day)")
- (list (calendar-gregorian-from-absolute (+ abs-h 3))
- "Hanukkah (fourth day)")
- (list (calendar-gregorian-from-absolute (+ abs-h 4))
- "Hanukkah (fifth day)")
- (list (calendar-gregorian-from-absolute (+ abs-h 5))
- "Hanukkah (sixth day)")
- (list (calendar-gregorian-from-absolute (+ abs-h 6))
- "Hanukkah (seventh day)")
- (list (calendar-gregorian-from-absolute (+ abs-h 7))
- "Hanukkah (eighth day)")))))))
+ (y displayed-year))
+ (increment-calendar-month m y 1)
+ (let* ((h-y (extract-calendar-year
+ (calendar-hebrew-from-absolute
+ (calendar-absolute-from-gregorian
+ (list m (calendar-last-day-of-month m y) y)))))
+ (abs-h (calendar-absolute-from-hebrew (list 9 25 h-y))))
+ (holiday-filter-visible-calendar
+ (list
+ (list (calendar-gregorian-from-absolute (1- abs-h))
+ "Erev Hanukkah")
+ (list (calendar-gregorian-from-absolute abs-h)
+ "Hanukkah (first day)")
+ (list (calendar-gregorian-from-absolute (1+ abs-h))
+ "Hanukkah (second day)")
+ (list (calendar-gregorian-from-absolute (+ abs-h 2))
+ "Hanukkah (third day)")
+ (list (calendar-gregorian-from-absolute (+ abs-h 3))
+ "Hanukkah (fourth day)")
+ (list (calendar-gregorian-from-absolute (+ abs-h 4))
+ "Hanukkah (fifth day)")
+ (list (calendar-gregorian-from-absolute (+ abs-h 5))
+ "Hanukkah (sixth day)")
+ (list (calendar-gregorian-from-absolute (+ abs-h 6))
+ "Hanukkah (seventh day)")
+ (list (calendar-gregorian-from-absolute (+ abs-h 7))
+ "Hanukkah (eighth day)")))))))
;;;###holiday-autoload
(defun holiday-passover-etc ()
"List of dates related to Passover, as visible in calendar window."
- (if (< 7 displayed-month)
- nil ; none of the dates is visible
+ (if (< 7 displayed-month)
+ nil ; none of the dates is visible
(let* ((abs-p (calendar-absolute-from-hebrew
- (list 1 15 (+ displayed-year 3760))))
+ (list 1 15 (+ displayed-year 3760))))
(mandatory
(list
(list (calendar-gregorian-from-absolute abs-p)
(list (calendar-gregorian-from-absolute (+ abs-p 51))
"Shavuot (second day)")))
(output-list
- (holiday-filter-visible-calendar mandatory)))
+ (holiday-filter-visible-calendar mandatory)))
(if all-hebrew-calendar-holidays
(setq output-list
(append
"List of dates around Tisha B'Av, as visible in calendar window."
(if (or (< displayed-month 5)
(> displayed-month 9))
- nil ; none of the dates is visible
+ nil ; none of the dates is visible
(let* ((abs-t-a (calendar-absolute-from-hebrew
- (list 5 9 (+ displayed-year 3760)))))
+ (list 5 9 (+ displayed-year 3760)))))
(holiday-filter-visible-calendar
(list
(declare-function add-to-diary-list "diary-lib"
(date string specifier &optional marker globcolor literal))
-(defvar number) ; from diary-list-entries
+(defvar number) ; from diary-list-entries
;;;###diary-autoload
(defun list-hebrew-diary-entries ()
(if (calendar-date-is-visible-p date)
(mark-visible-calendar-date date)))
;; Month and day in any year--this taken from the holiday stuff.
- ;; This test is only to speed things up a bit, it works
- ;; fine without it.
+ ;; This test is only to speed things up a bit, it works
+ ;; fine without it.
(if (memq displayed-month
(list
(if (< 11 month) (- month 11) (+ month 1))
(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* ((h-date (calendar-hebrew-from-absolute date))
- (h-month (extract-calendar-month h-date))
- (h-day (extract-calendar-day h-date))
- (h-year (extract-calendar-year h-date)))
- (and (or (zerop month)
- (= month h-month))
- (or (zerop day)
- (= day h-day))
- (or (zerop year)
- (= year h-year))
- (mark-visible-calendar-date
- (calendar-gregorian-from-absolute date)))))))))
+ (let* ((h-date (calendar-hebrew-from-absolute date))
+ (h-month (extract-calendar-month h-date))
+ (h-day (extract-calendar-day h-date))
+ (h-year (extract-calendar-year h-date)))
+ (and (or (zerop month)
+ (= month h-month))
+ (or (zerop day)
+ (= day h-day))
+ (or (zerop year)
+ (= year h-year))
+ (mark-visible-calendar-date
+ (calendar-gregorian-from-absolute date)))))
+ ))))
(declare-function diary-name-pattern "diary-lib"
(string-array &optional abbrev-array paren))
(let*
((date-form (if (equal (car (car d)) 'backup)
(cdr (car d))
- (car d))) ; ignore 'backup directive
+ (car d))) ; ignore 'backup directive
(dayname (diary-name-pattern calendar-day-name-array
calendar-day-abbrev-array))
(monthname
(if dd-name
(mark-calendar-days-named
(cdr (assoc-string dd-name
- (calendar-make-alist
- calendar-day-name-array
- 0 nil calendar-day-abbrev-array) t)))
+ (calendar-make-alist
+ calendar-day-name-array
+ 0 nil calendar-day-abbrev-array) t)))
(if mm-name
(setq mm
(if (string-equal mm-name "*") 0
(end-year (calendar-read
(format "Ending year of Yahrzeit table (>=%d): "
start-year)
- (lambda (x) (>= x start-year)))))
- (list death-date start-year end-year)))
+ (lambda (x) (>= x start-year)))))
+ (list death-date start-year end-year)))
(message "Computing Yahrzeits...")
(let* ((h-date (calendar-hebrew-from-absolute
(calendar-absolute-from-gregorian death-date)))
(erase-buffer)
(goto-char (point-min))
(calendar-for-loop i from start-year to end-year do
- (insert
- (calendar-date-string
- (calendar-gregorian-from-absolute
- (hebrew-calendar-yahrzeit
- h-date
- (extract-calendar-year
- (calendar-hebrew-from-absolute
- (calendar-absolute-from-gregorian (list 1 1 i))))))) "\n"))
+ (insert
+ (calendar-date-string
+ (calendar-gregorian-from-absolute
+ (hebrew-calendar-yahrzeit
+ h-date
+ (extract-calendar-year
+ (calendar-hebrew-from-absolute
+ (calendar-absolute-from-gregorian
+ (list 1 1 i))))))) "\n"))
(goto-char (point-min))
(set-buffer-modified-p nil)
(setq buffer-read-only t)
(day (% omer 7)))
(if (and (> omer 0) (< omer 50))
(cons mark
- (format "Day %d%s of the omer (until sunset)"
- omer
- (if (zerop week)
- ""
- (format ", that is, %d week%s%s"
- week
- (if (= week 1) "" "s")
- (if (zerop day)
- ""
- (format " and %d day%s"
- day (if (= day 1) "" "s"))))))))))
+ (format "Day %d%s of the omer (until sunset)"
+ omer
+ (if (zerop week)
+ ""
+ (format ", that is, %d week%s%s"
+ week
+ (if (= week 1) "" "s")
+ (if (zerop day)
+ ""
+ (format " and %d day%s"
+ day (if (= day 1) "" "s"))))))))))
(defvar entry)
(calendar-absolute-from-gregorian
(if european-calendar-style
(list death-day death-month death-year)
- (list death-month death-day death-year)))))
+ (list death-month death-day death-year)))))
(h-month (extract-calendar-month h-date))
(h-day (extract-calendar-day h-date))
(h-year (extract-calendar-year h-date))
(y (hebrew-calendar-yahrzeit h-date yr)))
(if (and (> diff 0) (or (= y d) (= y (1+ d))))
(cons mark
- (format "Yahrzeit of %s%s: %d%s anniversary"
- entry
- (if (= y d) "" " (evening)")
- diff
- (cond ((= (% diff 10) 1) "st")
- ((= (% diff 10) 2) "nd")
- ((= (% diff 10) 3) "rd")
- (t "th")))))))
+ (format "Yahrzeit of %s%s: %d%s anniversary"
+ entry
+ (if (= y d) "" " (evening)")
+ diff
+ (cond ((= (% diff 10) 1) "st")
+ ((= (% diff 10) 2) "nd")
+ ((= (% diff 10) 3) "rd")
+ (t "th")))))))
;;;###diary-autoload
(defun diary-rosh-hodesh (&optional mark)
(calendar-hebrew-from-absolute (1- d)))))
(if (or (= h-day 30) (and (= h-day 1) (/= h-month 7)))
(cons mark
- (format
- "Rosh Hodesh %s"
- (if (= h-day 30)
- (format
- "%s (first day)"
- ;; Next month must be in the same year since this
- ;; month can't be the last month of the year since
- ;; it has 30 days
- (aref h-month-names h-month))
- (if (= h-yesterday 30)
- (format "%s (second day)" this-month)
- this-month))))
- (if (= (% d 7) 6) ; Saturday--check for Shabbat Mevarchim
+ (format
+ "Rosh Hodesh %s"
+ (if (= h-day 30)
+ (format
+ "%s (first day)"
+ ;; Next month must be in the same year since this
+ ;; month can't be the last month of the year since
+ ;; it has 30 days
+ (aref h-month-names h-month))
+ (if (= h-yesterday 30)
+ (format "%s (second day)" this-month)
+ this-month))))
+ (if (= (% d 7) 6) ; Saturday--check for Shabbat Mevarchim
(cons mark
- (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
- (format "Mevarchim Rosh Hodesh %s (%s)"
- (aref h-month-names
- (if (= h-month
- (hebrew-calendar-last-month-of-year
- h-year))
- 0 h-month))
- (aref calendar-day-name-array (- 29 h-day))))
- ((and (< h-day 30) (> h-day 22) (= 30 last-day))
- (format "Mevarchim Rosh Hodesh %s (%s-%s)"
- (aref h-month-names h-month)
- (if (= h-day 29)
- "tomorrow"
- (aref calendar-day-name-array (- 29 h-day)))
- (aref calendar-day-name-array
- (% (- 30 h-day) 7))))))
+ (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
+ (format "Mevarchim Rosh Hodesh %s (%s)"
+ (aref h-month-names
+ (if (= h-month
+ (hebrew-calendar-last-month-of-year
+ h-year))
+ 0 h-month))
+ (aref calendar-day-name-array (- 29 h-day))))
+ ((and (< h-day 30) (> h-day 22) (= 30 last-day))
+ (format "Mevarchim Rosh Hodesh %s (%s-%s)"
+ (aref h-month-names h-month)
+ (if (= h-day 29)
+ "tomorrow"
+ (aref calendar-day-name-array (- 29 h-day)))
+ (aref calendar-day-name-array
+ (% (- 30 h-day) 7))))))
(if (and (= h-day 29) (/= h-month 6))
(cons mark
- (format "Erev Rosh Hodesh %s"
- (aref h-month-names
- (if (= h-month
- (hebrew-calendar-last-month-of-year
- h-year))
- 0 h-month)))))))))
+ (format "Erev Rosh Hodesh %s"
+ (aref h-month-names
+ (if (= h-month
+ (hebrew-calendar-last-month-of-year
+ h-year))
+ 0 h-month)))))))))
(defvar hebrew-calendar-parashiot-names
-["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth"
- "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi"
- "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim"
- "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra"
- "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim"
- "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha"
- "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth"
- "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim"
- "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"]
+ ["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth"
+ "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi"
+ "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim"
+ "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra"
+ "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim"
+ "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha"
+ "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth"
+ "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim"
+ "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"]
"The names of the parashiot in the Torah.")
(defun hebrew-calendar-parasha-name (p)
"Name(s) corresponding to parasha P."
- (if (arrayp p) ; combined parasha
+ (if (arrayp p) ; combined parasha
(format "%s/%s"
(aref hebrew-calendar-parashiot-names (aref p 0))
(aref hebrew-calendar-parashiot-names (aref p 1)))
An optional parameter MARK specifies a face or single-character string to
use when highlighting the day in the calendar."
(let ((d (calendar-absolute-from-gregorian date)))
- (if (= (% d 7) 6) ; Saturday
+ (if (= (% d 7) 6) ; Saturday
(let*
((h-year (extract-calendar-year
(calendar-hebrew-from-absolute d)))
(symbol-value
(intern (format "hebrew-calendar-year-%s-%s-%s" ; keviah
rosh-hashanah-day type passover-day))))
- (first-saturday ; of Hebrew year
+ (first-saturday ; of Hebrew year
(calendar-dayname-on-or-before 6 (+ 6 rosh-hashanah)))
- (saturday ; which Saturday of the Hebrew year
+ (saturday ; which Saturday of the Hebrew year
(/ (- d first-saturday) 7))
(parasha (aref year-format saturday)))
(if parasha
(cons mark
- (format
- "Parashat %s"
- (if (listp parasha) ; Israel differs from diaspora
- (if (car parasha)
- (format "%s (diaspora), %s (Israel)"
- (hebrew-calendar-parasha-name
- (car parasha))
- (hebrew-calendar-parasha-name
- (cdr parasha)))
- (format "%s (Israel)"
- (hebrew-calendar-parasha-name
- (cdr parasha))))
- (hebrew-calendar-parasha-name parasha)))))))))
+ (format
+ "Parashat %s"
+ (if (listp parasha) ; Israel differs from diaspora
+ (if (car parasha)
+ (format "%s (diaspora), %s (Israel)"
+ (hebrew-calendar-parasha-name
+ (car parasha))
+ (hebrew-calendar-parasha-name
+ (cdr parasha)))
+ (format "%s (Israel)"
+ (hebrew-calendar-parasha-name
+ (cdr parasha))))
+ (hebrew-calendar-parasha-name parasha)))))))))
;; The seven ordinary year types (keviot).
(defconst hebrew-calendar-year-Saturday-incomplete-Sunday
[nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
- 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
- 43 44 45 46 47 48 49 50]
+ 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
+ 43 44 45 46 47 48 49 50]
"The structure of the parashiot.
Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have
29 days), and has Passover start on Sunday.")
(defconst hebrew-calendar-year-Saturday-complete-Tuesday
[nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
- 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
- 43 44 45 46 47 48 49 [50 51]]
+ 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
+ 43 44 45 46 47 48 49 [50 51]]
"The structure of the parashiot.
Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
have 30 days), and has Passover start on Tuesday.")
(defconst hebrew-calendar-year-Monday-incomplete-Tuesday
[51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
- 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
- 43 44 45 46 47 48 49 [50 51]]
+ 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
+ 43 44 45 46 47 48 49 [50 51]]
"The structure of the parashiot.
Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
have 29 days), and has Passover start on Tuesday.")
(defconst hebrew-calendar-year-Monday-complete-Thursday
[51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
- 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
- (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
+ 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
+ (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
"The structure of the parashiot.
Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
30 days), and has Passover start on Thursday.")
(defconst hebrew-calendar-year-Tuesday-regular-Thursday
[51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
- 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
- (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
+ 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
+ (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
"The structure of the parashiot.
Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
Kislev has 30 days), and has Passover start on Thursday.")
(defconst hebrew-calendar-year-Thursday-regular-Saturday
[52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23
- 24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30)
- (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48
- 49 50]
+ 24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30)
+ (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48
+ 49 50]
"The structure of the parashiot.
Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and
Kislev has 30 days), and has Passover start on Saturday.")
(defconst hebrew-calendar-year-Thursday-complete-Sunday
[52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
- 43 44 45 46 47 48 49 50]
+ 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
+ 43 44 45 46 47 48 49 50]
"The structure of the parashiot.
Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each
have 30 days), and has Passover start on Sunday.")
;; The seven leap year types (keviot).
(defconst hebrew-calendar-year-Saturday-incomplete-Tuesday
[nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42]
- 43 44 45 46 47 48 49 [50 51]]
+ 23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42]
+ 43 44 45 46 47 48 49 [50 51]]
"The structure of the parashiot.
Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each
have 29 days), and has Passover start on Tuesday.")
(defconst hebrew-calendar-year-Saturday-complete-Thursday
[nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
- (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
+ 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
+ (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
"The structure of the parashiot.
Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
have 30 days), and has Passover start on Thursday.")
(defconst hebrew-calendar-year-Monday-incomplete-Thursday
[51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
- (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
+ 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
+ (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
"The structure of the parashiot.
Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
have 29 days), and has Passover start on Thursday.")
(defconst hebrew-calendar-year-Monday-complete-Saturday
[51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
- (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
- (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
+ 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
+ (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
+ (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
"The structure of the parashiot.
Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
30 days), and has Passover start on Saturday.")
(defconst hebrew-calendar-year-Tuesday-regular-Saturday
[51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
- (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
- (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
+ 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
+ (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
+ (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
"The structure of the parashiot.
Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
Kislev has 30 days), and has Passover start on Saturday.")
(defconst hebrew-calendar-year-Thursday-incomplete-Sunday
[52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
- 43 44 45 46 47 48 49 50]
+ 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
+ 43 44 45 46 47 48 49 50]
"The structure of the parashiot.
Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both
have 29 days), and has Passover start on Sunday.")
(defconst hebrew-calendar-year-Thursday-complete-Tuesday
[52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
- 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
- 43 44 45 46 47 48 49 [50 51]]
+ 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
+ 43 44 45 46 47 48 49 [50 51]]
"The structure of the parashiot.
Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
have 30 days), and has Passover start on Tuesday.")
;; 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
(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))
(reverse rlc)))
(defun calendar-mayan-haab-difference (date1 date2)
"Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2."
(mod (+ (* 20 (- (cdr date2) (cdr date1)))
- (- (car date2) (car date1)))
+ (- (car date2) (car date1)))
365))
(defun calendar-mayan-haab-on-or-before (haab-date date)
"Absolute date of latest HAAB-DATE on or before absolute DATE."
(- date
(% (- date
- (calendar-mayan-haab-difference
- (calendar-mayan-haab-from-absolute 0) haab-date))
- 365)))
+ (calendar-mayan-haab-difference
+ (calendar-mayan-haab-from-absolute 0) haab-date))
+ 365)))
;;;###cal-autoload
(defun calendar-next-haab-date (haab-date &optional noecho)
"Convert Mayan HAAB date (a pair) into its traditional written form."
(let ((month (cdr haab))
(day (car haab)))
- ;; 19th month consists of 5 special days
- (if (= month 19)
- (format "%d Uayeb" day)
- (format "%d %s"
- day
- (aref calendar-mayan-haab-month-name-array (1- month))))))
+ ;; 19th month consists of 5 special days
+ (if (= month 19)
+ (format "%d Uayeb" day)
+ (format "%d %s"
+ day
+ (aref calendar-mayan-haab-month-name-array (1- month))))))
(defun calendar-mayan-tzolkin-from-absolute (date)
"Convert absolute DATE into a Mayan tzolkin date (a pair)."
(let ((number-difference (- (car date2) (car date1)))
(name-difference (- (cdr date2) (cdr date1))))
(mod (+ number-difference
- (* 13 (mod (* 3 (- number-difference name-difference))
- 20)))
- 260)))
+ (* 13 (mod (* 3 (- number-difference name-difference))
+ 20)))
+ 260)))
(defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
"Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
(- date
(% (- date (calendar-mayan-tzolkin-difference
- (calendar-mayan-tzolkin-from-absolute 0)
- tzolkin-date))
- 260)))
+ (calendar-mayan-tzolkin-from-absolute 0)
+ tzolkin-date))
+ 260)))
;;;###cal-autoload
(defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
(if (= (% difference 5) 0)
(- date
(mod (- date
- (+ haab-difference (* 365 difference)))
- 18980))
+ (+ haab-difference (* 365 difference)))
+ 18980))
nil)))
(defun calendar-read-mayan-haab-date ()
(tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
(tzolkin-name (cdr
(assoc-string
- (completing-read "Tzolkin uinal: "
- (mapcar 'list tzolkin-name-list)
- nil t)
+ (completing-read "Tzolkin uinal: "
+ (mapcar 'list tzolkin-name-list)
+ nil t)
(calendar-make-alist tzolkin-name-list 1) t))))
(cons tzolkin-count tzolkin-name)))
(defun calendar-absolute-from-mayan-long-count (c)
"Compute the absolute date corresponding to the Mayan Long Count C.
Long count is a list (baktun katun tun uinal kin)"
- (+ (* (nth 0 c) 144000) ; baktun
- (* (nth 1 c) 7200) ; katun
- (* (nth 2 c) 360) ; tun
- (* (nth 3 c) 20) ; uinal
- (nth 4 c) ; kin (days)
- (- ; days before absolute date 0
+ (+ (* (nth 0 c) 144000) ; baktun
+ (* (nth 1 c) 7200) ; katun
+ (* (nth 2 c) 360) ; tun
+ (* (nth 3 c) 20) ; uinal
+ (nth 4 c) ; kin (days)
+ (- ; days before absolute date 0
calendar-mayan-days-before-absolute-zero)))
;;;###cal-autoload
(tzolkin (calendar-mayan-tzolkin-from-absolute d))
(haab (calendar-mayan-haab-from-absolute d))
(long-count (calendar-mayan-long-count-from-absolute d)))
- (format "Long count = %s; tzolkin = %s; haab = %s"
- (calendar-mayan-long-count-to-string long-count)
- (calendar-mayan-tzolkin-to-string tzolkin)
- (calendar-mayan-haab-to-string haab))))
+ (format "Long count = %s; tzolkin = %s; haab = %s"
+ (calendar-mayan-long-count-to-string long-count)
+ (calendar-mayan-tzolkin-to-string tzolkin)
+ (calendar-mayan-haab-to-string haab))))
;;;###cal-autoload
(defun calendar-print-mayan-date ()
(read-string "Mayan long count (baktun.katun.tun.uinal.kin): "
(calendar-mayan-long-count-to-string
(calendar-mayan-long-count-from-absolute
- (calendar-absolute-from-gregorian
- (calendar-current-date))))))))
+ (calendar-absolute-from-gregorian
+ (calendar-current-date))))))))
(if (calendar-mayan-long-count-common-era datum)
(setq lc datum))))
(list lc)))
;; Free Software Foundation, Inc.
;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
-;; Lara Rios <lrios@coewl.cen.uiuc.edu>
+;; Lara Rios <lrios@coewl.cen.uiuc.edu>
;; Maintainer: Glenn Morris <rgm@gnu.org>
;; Keywords: calendar
;; Human-Keywords: calendar, popup menus, menu bar
(defun calendar-cursor-to-visible-date (date)
"Move the cursor to DATE that is on the screen."
(let* ((month (extract-calendar-month date))
- (day (extract-calendar-day date))
- (year (extract-calendar-year date))
- (first-of-month-weekday (calendar-day-of-week (list month 1 year))))
+ (day (extract-calendar-day date))
+ (year (extract-calendar-year date))
+ (first-of-month-weekday (calendar-day-of-week (list month 1 year))))
(goto-line (+ 3
- (/ (+ day -1
+ (/ (+ day -1
(mod
(- (calendar-day-of-week (list month 1 year))
calendar-week-start-day)
7))
7)))
(move-to-column (+ 6
- (* 25
- (1+ (calendar-interval
- displayed-month displayed-year month year)))
- (* 3 (mod
+ (* 25
+ (1+ (calendar-interval
+ displayed-month displayed-year month year)))
+ (* 3 (mod
(- (calendar-day-of-week date)
calendar-week-start-day)
7))))))
(cal-tex-list-diary-entries
;; FIXME d1?
(calendar-absolute-from-gregorian (list month 1 year))
- d2))))
+ d2))))
(cal-tex-preamble "twoside")
(cal-tex-cmd "\\textwidth 3.25in")
(cal-tex-cmd "\\textheight 6.5in")
;; 2008 Free Software Foundation, Inc.
;; Author: Michael Kifer <kifer@cs.sunysb.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: calendar, dedicated frames, X Window System
(save-window-excursion
(save-excursion
(setq calendar-frame
- (make-frame calendar-and-diary-frame-parameters))
+ (make-frame calendar-and-diary-frame-parameters))
(run-hooks 'calendar-after-frame-setup-hooks)
(select-frame calendar-frame)
(if (eq 'icon (cdr (assoc 'visibility
- (frame-parameters calendar-frame))))
+ (frame-parameters calendar-frame))))
(iconify-or-deiconify-frame))
(calendar-basic-setup arg)
(set-window-dedicated-p (selected-window) t)
(save-window-excursion
(save-excursion
(setq calendar-frame
- (make-frame calendar-frame-parameters))
+ (make-frame calendar-frame-parameters))
(run-hooks 'calendar-after-frame-setup-hooks)
(select-frame calendar-frame)
(if (eq 'icon (cdr (assoc 'visibility
- (frame-parameters calendar-frame))))
+ (frame-parameters calendar-frame))))
(iconify-or-deiconify-frame))
(calendar-basic-setup arg)
(set-window-dedicated-p (selected-window) t))))))
"List of pseudo-patterns describing the American patterns of date used.
See the documentation of `diary-date-forms' for an explanation."
:type '(repeat (choice (cons :tag "Backup"
- :value (backup . nil)
- (const backup)
- (repeat (list :inline t :format "%v"
- (symbol :tag "Keyword")
- (choice symbol regexp))))
- (repeat (list :inline t :format "%v"
- (symbol :tag "Keyword")
- (choice symbol regexp)))))
+ :value (backup . nil)
+ (const backup)
+ (repeat (list :inline t :format "%v"
+ (symbol :tag "Keyword")
+ (choice symbol regexp))))
+ (repeat (list :inline t :format "%v"
+ (symbol :tag "Keyword")
+ (choice symbol regexp)))))
:group 'diary)
(defcustom european-date-diary-pattern
"List of pseudo-patterns describing the European patterns of date used.
See the documentation of `diary-date-forms' for an explanation."
:type '(repeat (choice (cons :tag "Backup"
- :value (backup . nil)
- (const backup)
- (repeat (list :inline t :format "%v"
- (symbol :tag "Keyword")
- (choice symbol regexp))))
- (repeat (list :inline t :format "%v"
- (symbol :tag "Keyword")
- (choice symbol regexp)))))
+ :value (backup . nil)
+ (const backup)
+ (repeat (list :inline t :format "%v"
+ (symbol :tag "Keyword")
+ (choice symbol regexp))))
+ (repeat (list :inline t :format "%v"
+ (symbol :tag "Keyword")
+ (choice symbol regexp)))))
:group 'diary)
(defvar diary-font-lock-keywords)
current word of the diary entry, so in no case can the pattern match more than
a portion of the first word of the diary entry."
:type '(repeat (choice (cons :tag "Backup"
- :value (backup . nil)
- (const backup)
- (repeat (list :inline t :format "%v"
- (symbol :tag "Keyword")
- (choice symbol regexp))))
- (repeat (list :inline t :format "%v"
- (symbol :tag "Keyword")
- (choice symbol regexp)))))
+ :value (backup . nil)
+ (const backup)
+ (repeat (list :inline t :format "%v"
+ (symbol :tag "Keyword")
+ (choice symbol regexp))))
+ (repeat (list :inline t :format "%v"
+ (symbol :tag "Keyword")
+ (choice symbol regexp)))))
:initialize 'custom-initialize-default
:set (lambda (symbol value)
(unless (equal value (eval symbol))
;;;###autoload
(defcustom oriental-holidays
'((if (fboundp 'atan)
- (holiday-chinese-new-year)))
+ (holiday-chinese-new-year)))
"Oriental holidays.
See the documentation for `calendar-holidays' for details."
:type 'sexp
(format "Baha'i New Year (Naw-Ruz) %d" (- displayed-year (1- 1844))))
(holiday-fixed 4 21 "First Day of Ridvan")
(if all-bahai-calendar-holidays
- (holiday-fixed 4 22 "Second Day of Ridvan"))
+ (holiday-fixed 4 22 "Second Day of Ridvan"))
(if all-bahai-calendar-holidays
- (holiday-fixed 4 23 "Third Day of Ridvan"))
+ (holiday-fixed 4 23 "Third Day of Ridvan"))
(if all-bahai-calendar-holidays
- (holiday-fixed 4 24 "Fourth Day of Ridvan"))
+ (holiday-fixed 4 24 "Fourth Day of Ridvan"))
(if all-bahai-calendar-holidays
- (holiday-fixed 4 25 "Fifth Day of Ridvan"))
+ (holiday-fixed 4 25 "Fifth Day of Ridvan"))
(if all-bahai-calendar-holidays
- (holiday-fixed 4 26 "Sixth Day of Ridvan"))
+ (holiday-fixed 4 26 "Sixth Day of Ridvan"))
(if all-bahai-calendar-holidays
- (holiday-fixed 4 27 "Seventh Day of Ridvan"))
+ (holiday-fixed 4 27 "Seventh Day of Ridvan"))
(if all-bahai-calendar-holidays
- (holiday-fixed 4 28 "Eighth Day of Ridvan"))
+ (holiday-fixed 4 28 "Eighth Day of Ridvan"))
(holiday-fixed 4 29 "Ninth Day of Ridvan")
(if all-bahai-calendar-holidays
- (holiday-fixed 4 30 "Tenth Day of Ridvan"))
+ (holiday-fixed 4 30 "Tenth Day of Ridvan"))
(if all-bahai-calendar-holidays
- (holiday-fixed 5 1 "Eleventh Day of Ridvan"))
+ (holiday-fixed 5 1 "Eleventh Day of Ridvan"))
(holiday-fixed 5 2 "Twelfth Day of Ridvan")
(holiday-fixed 5 23 "Declaration of the Bab")
(holiday-fixed 5 29 "Ascension of Baha'u'llah")
(holiday-fixed 10 20 "Birth of the Bab")
(holiday-fixed 11 12 "Birth of Baha'u'llah")
(if all-bahai-calendar-holidays
- (holiday-fixed 11 26 "Day of the Covenant"))
+ (holiday-fixed 11 26 "Day of the Covenant"))
(if all-bahai-calendar-holidays
- (holiday-fixed 11 28 "Ascension of `Abdu'l-Baha")))
+ (holiday-fixed 11 28 "Ascension of `Abdu'l-Baha")))
"Baha'i holidays.
See the documentation for `calendar-holidays' for details."
:type 'sexp
;;;###autoload
(defcustom solar-holidays
'((if (fboundp 'atan)
- (solar-equinoxes-solstices))
+ (solar-equinoxes-solstices))
(if (require 'cal-dst)
(funcall
'holiday-sexp
(fit-window-to-buffer nil nil calendar-minimum-window-height))
(sit-for 0))
(if (and (boundp 'font-lock-mode)
- font-lock-mode)
- (font-lock-fontify-buffer))
+ font-lock-mode)
+ (font-lock-fontify-buffer))
(and mark-holidays-in-calendar
;;; (calendar-date-is-valid-p today) ; useful for BC dates
(calendar-mark-holidays)
(- (calendar-day-of-week (list month 1 year))
calendar-week-start-day)
7))
- (last (calendar-last-day-of-month month year)))
+ (last (calendar-last-day-of-month month year)))
(goto-char (point-min))
(calendar-insert-indented
(calendar-string-spread
(add-text-properties
(- (point) 3) (1- (point))
'(mouse-face highlight
- help-echo "mouse-2: menu of operations for this date"))
+ help-echo "mouse-2: menu of operations for this date"))
(and (zerop (mod (+ i blank-days) 7))
(/= i last)
(calendar-insert-indented "" 0 t) ; force onto following line
(defcustom calendar-mode-line-format
(list
(propertize "<"
- 'help-echo "mouse-1: previous month"
- 'mouse-face 'mode-line-highlight
- 'keymap (make-mode-line-mouse-map 'mouse-1
- 'calendar-scroll-right))
+ 'help-echo "mouse-1: previous month"
+ 'mouse-face 'mode-line-highlight
+ 'keymap (make-mode-line-mouse-map 'mouse-1
+ 'calendar-scroll-right))
"Calendar"
(concat
(propertize
'help-echo "mouse-1: choose another month"
'mouse-face 'mode-line-highlight
'keymap (make-mode-line-mouse-map
- 'mouse-1 'mouse-calendar-other-month))
+ 'mouse-1 'mouse-calendar-other-month))
" / "
(propertize
(substitute-command-keys
'keymap (make-mode-line-mouse-map 'mouse-1 #'calendar-goto-today)))
'(calendar-date-string (calendar-current-date) t)
(propertize ">"
- 'help-echo "mouse-1: next month"
- 'mouse-face 'mode-line-highlight
- 'keymap (make-mode-line-mouse-map
- 'mouse-1 'calendar-scroll-left)))
+ 'help-echo "mouse-1: next month"
+ 'mouse-face 'mode-line-highlight
+ 'keymap (make-mode-line-mouse-map
+ 'mouse-1 'calendar-scroll-left)))
"The mode line of the calendar buffer.
This must be a list of items that evaluate to strings--those strings are
(let ((calendar-buffers (calendar-buffer-list))
list)
(walk-windows (lambda (w)
- (if (memq (window-buffer w) calendar-buffers)
- (push w list)))
+ (if (memq (window-buffer w) calendar-buffers)
+ (push w list)))
nil t)
list))
(list month year))
(list month
(calendar-read (format "Day (1-%d): " last)
- (lambda (x) (and (< 0 x) (<= x last))))
+ (lambda (x) (and (< 0 x) (<= x last))))
year))))
(defun calendar-interval (mon1 yr1 mon2 yr2)
(defvar calendar-font-lock-keywords
`((,(concat (regexp-opt (mapcar 'identity calendar-month-name-array) t)
- " -?[0-9]+")
+ " -?[0-9]+")
. font-lock-function-name-face) ; month and year
(,(regexp-opt
(list (substring (aref calendar-day-name-array 6) 0 2)
- (substring (aref calendar-day-name-array 0) 0 2)))
+ (substring (aref calendar-day-name-array 0) 0 2)))
;; Saturdays and Sundays are highlighted differently.
. font-lock-comment-face)
;; First two chars of each day are used in the calendar.
If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise."
(if (> n 0)
(+ (* 7 (1- n))
- (calendar-dayname-on-or-before
- dayname
- (+ 6 (calendar-absolute-from-gregorian
- (list month (or day 1) year)))))
+ (calendar-dayname-on-or-before
+ dayname
+ (+ 6 (calendar-absolute-from-gregorian
+ (list month (or day 1) year)))))
(+ (* 7 (1+ n))
(calendar-dayname-on-or-before
- dayname
- (calendar-absolute-from-gregorian
- (list month
- (or day (calendar-last-day-of-month month year))
- year))))))
+ dayname
+ (calendar-absolute-from-gregorian
+ (list month
+ (or day (calendar-last-day-of-month month year))
+ year))))))
(defun calendar-nth-named-day (n dayname month year &optional day)
"The date of Nth DAYNAME in MONTH, YEAR before/after optional DAY.
:type 'face
:group 'diary)
(make-obsolete-variable 'diary-face "customize the face `diary' instead."
- "23.1")
+ "23.1")
;; Face markup of calendar and diary displays: Any entry line that
;; ends with [foo:value] where foo is a face attribute (except :box
attribute being applied. Available TYPES (see `diary-attrtype-convert')
are: `string', `symbol', `int', `tnil',`stringtnil.'"
:type '(repeat (list (string :tag "Regular expression")
- (integer :tag "Sub-expression")
- (symbol :tag "Attribute (e.g. :foreground)")
- (choice (const string :tag "A string")
- (const symbol :tag "A symbol")
- (const int :tag "An integer")
- (const tnil :tag "`t' or `nil'")
- (const stringtnil
- :tag "A string, `t', or `nil'"))))
+ (integer :tag "Sub-expression")
+ (symbol :tag "Attribute (e.g. :foreground)")
+ (choice (const string :tag "A string")
+ (const symbol :tag "A symbol")
+ (const int :tag "An integer")
+ (const tnil :tag "`t' or `nil'")
+ (const stringtnil
+ :tag "A string, `t', or `nil'"))))
:group 'diary)
(defcustom diary-glob-file-regexp-prefix "^\\#"
describes the style of such diary entries."
:type 'hook
:options '(list-hebrew-diary-entries
- list-islamic-diary-entries
- diary-bahai-list-entries)
+ list-islamic-diary-entries
+ diary-bahai-list-entries)
:group 'diary)
(defcustom nongregorian-diary-marking-hook nil
describes the style of such diary entries."
:type 'hook
:options '(mark-hebrew-diary-entries
- mark-islamic-diary-entries
- diary-bahai-mark-entries)
+ mark-islamic-diary-entries
+ diary-bahai-mark-entries)
:group 'diary)
(defcustom print-diary-entries-hook 'lpr-buffer
body text as argument, and may use `match-string' etc. to make a
template following the rules above."
:type '(alist :key-type (regexp :tag "Regexp matching time/place")
- :value-type (choice
- (string :tag "Template for entry")
- (function :tag
- "Unary function providing template")))
+ :value-type (choice
+ (string :tag "Template for entry")
+ (function :tag
+ "Unary function providing template")))
:version "22.1"
:group 'diary)
"Convert string ATTRVALUE to TYPE appropriate for a face description.
Valid TYPEs are: string, symbol, int, stringtnil, tnil."
(cond ((eq type 'string) attrvalue)
- ((eq type 'symbol) (read attrvalue)) ; FIXME intern-soft?
- ((eq type 'int) (string-to-number attrvalue))
- ((eq type 'stringtnil)
- (cond ((string-equal "t" attrvalue) t)
- ((string-equal "nil" attrvalue) nil)
- (t attrvalue)))
- ((eq type 'tnil) (string-equal "t" attrvalue))))
+ ((eq type 'symbol) (read attrvalue)) ; FIXME intern-soft?
+ ((eq type 'int) (string-to-number attrvalue))
+ ((eq type 'stringtnil)
+ (cond ((string-equal "t" attrvalue) t)
+ ((string-equal "nil" attrvalue) nil)
+ (t attrvalue)))
+ ((eq type 'tnil) (string-equal "t" attrvalue))))
(defun diary-pull-attrs (entry fileglobattrs)
"Search for matches for regexps from `diary-face-attrs'.
pairs."
(let (regexp regnum attrname attrname attrvalue type ret-attr)
(if (null entry)
- (save-excursion
- (dolist (attr diary-face-attrs)
- ;; FIXME inefficient searching.
- (goto-char (point-min))
- (setq regexp (concat diary-glob-file-regexp-prefix (car attr))
- regnum (cadr attr)
- attrname (nth 2 attr)
- type (nth 3 attr)
- attrvalue (if (re-search-forward regexp nil t)
- (match-string-no-properties regnum)))
- (and attrvalue
- (setq attrvalue (diary-attrtype-convert attrvalue type))
- (setq ret-attr (append ret-attr
- (list attrname attrvalue))))))
+ (save-excursion
+ (dolist (attr diary-face-attrs)
+ ;; FIXME inefficient searching.
+ (goto-char (point-min))
+ (setq regexp (concat diary-glob-file-regexp-prefix (car attr))
+ regnum (cadr attr)
+ attrname (nth 2 attr)
+ type (nth 3 attr)
+ attrvalue (if (re-search-forward regexp nil t)
+ (match-string-no-properties regnum)))
+ (and attrvalue
+ (setq attrvalue (diary-attrtype-convert attrvalue type))
+ (setq ret-attr (append ret-attr
+ (list attrname attrvalue))))))
(setq ret-attr fileglobattrs)
(dolist (attr diary-face-attrs)
- (setq regexp (car attr)
- regnum (cadr attr)
- attrname (nth 2 attr)
- type (nth 3 attr)
- attrvalue nil)
- ;; FIXME multiple matches?
- (if (string-match regexp entry)
- (setq attrvalue (match-string-no-properties regnum entry)
- entry (replace-match "" t t entry)))
- (and attrvalue
- (setq attrvalue (diary-attrtype-convert attrvalue type))
- (setq ret-attr (append ret-attr (list attrname attrvalue))))))
+ (setq regexp (car attr)
+ regnum (cadr attr)
+ attrname (nth 2 attr)
+ type (nth 3 attr)
+ attrvalue nil)
+ ;; FIXME multiple matches?
+ (if (string-match regexp entry)
+ (setq attrvalue (match-string-no-properties regnum entry)
+ entry (replace-match "" t t entry)))
+ (and attrvalue
+ (setq attrvalue (diary-attrtype-convert attrvalue type))
+ (setq ret-attr (append ret-attr (list attrname attrvalue))))))
(list entry ret-attr)))
;;;###cal-autoload
from the calendar; in that case, the prefix argument controls the
number of days of diary entries displayed."
:type '(choice (integer :tag "Entries")
- (vector :value [0 0 0 0 0 0 0]
- (integer :tag "Sunday")
- (integer :tag "Monday")
- (integer :tag "Tuesday")
- (integer :tag "Wednesday")
- (integer :tag "Thursday")
- (integer :tag "Friday")
- (integer :tag "Saturday")))
+ (vector :value [0 0 0 0 0 0 0]
+ (integer :tag "Sunday")
+ (integer :tag "Monday")
+ (integer :tag "Tuesday")
+ (integer :tag "Wednesday")
+ (integer :tag "Thursday")
+ (integer :tag "Friday")
+ (integer :tag "Saturday")))
:initialize 'custom-initialize-default
:set 'diary-set-maybe-redraw
:group 'diary)
org.el and planner.el) to modify the string or add properties to it.
The function takes a string argument and must return a string.")
-(defvar diary-entries-list) ; bound in diary-list-entries
+(defvar diary-entries-list) ; bound in diary-list-entries
(defun add-to-diary-list (date string specifier &optional marker
globcolor literal)
(or (string-equal prefix "")
(setq string (format "[%s] %s" prefix string)))))
(and diary-modify-entry-list-string-function
- (setq string (funcall diary-modify-entry-list-string-function
- string)))
+ (setq string (funcall diary-modify-entry-list-string-function
+ string)))
(setq diary-entries-list
(append diary-entries-list
(list (list date string specifier
(aref number-of-diary-entries (calendar-day-of-week date))
number-of-diary-entries)))
(when (> number 0)
- (let ((original-date date) ; save for possible use in the hooks
+ (let ((original-date date) ; save for possible use in the hooks
diary-entries-list
file-glob-attrs
(date-string (calendar-date-string date))
(entry-found (list-sexp-diary-entries date)))
(dolist (date-form diary-date-forms)
(let* ((backup (when (eq (car date-form) 'backup)
- (setq date-form (cdr date-form))
- t))
- (dayname
- (format "%s\\|%s\\.?"
- (calendar-day-name date)
- (calendar-day-name date 'abbrev)))
- (monthname
- (format "\\*\\|%s\\|%s\\.?"
- (calendar-month-name month)
- (calendar-month-name month 'abbrev)))
- (month (concat "\\*\\|0*" (int-to-string month)))
- (day (concat "\\*\\|0*" (int-to-string day)))
- (year
- (concat
- "\\*\\|0*" (int-to-string year)
- (if abbreviated-calendar-year
- (concat "\\|" (format "%02d" (% year 100)))
- "")))
- (regexp
- (concat
- "^" mark "?\\("
- ;; This must be let* so that date-form
- ;; can use day etc.
- (mapconcat 'eval date-form "\\)\\(?:")
- "\\)"))
- (case-fold-search t))
+ (setq date-form (cdr date-form))
+ t))
+ (dayname
+ (format "%s\\|%s\\.?"
+ (calendar-day-name date)
+ (calendar-day-name date 'abbrev)))
+ (monthname
+ (format "\\*\\|%s\\|%s\\.?"
+ (calendar-month-name month)
+ (calendar-month-name month 'abbrev)))
+ (month (concat "\\*\\|0*" (int-to-string month)))
+ (day (concat "\\*\\|0*" (int-to-string day)))
+ (year
+ (concat
+ "\\*\\|0*" (int-to-string year)
+ (if abbreviated-calendar-year
+ (concat "\\|" (format "%02d" (% year 100)))
+ "")))
+ (regexp
+ (concat
+ "^" mark "?\\("
+ ;; This must be let* so that date-form
+ ;; can use day etc.
+ (mapconcat 'eval date-form "\\)\\(?:")
+ "\\)"))
+ (case-fold-search t))
(goto-char (point-min))
(while (re-search-forward regexp nil t)
(if backup (re-search-backward "\\<" nil t))
- (if (and (bolp) (not (looking-at "[ \t]")))
+ (if (and (bolp) (not (looking-at "[ \t]")))
;; Diary entry that consists only of date.
(backward-char 1)
;; Found a nonempty diary entry--make it
;; visible and add it to the list.
(setq entry-found t)
- (if (looking-at "[ \t]*\n[ \t]") (forward-line 1))
+ (if (looking-at "[ \t]*\n[ \t]") (forward-line 1))
(let ((entry-start (point))
date-start temp)
- (setq date-start
- (line-end-position
- (if (and (bolp) (> number 1)) -1 0)))
- (forward-line 1)
- (while (looking-at "[ \t]")
- (forward-line 1))
+ (setq date-start
+ (line-end-position
+ (if (and (bolp) (> number 1)) -1 0)))
+ (forward-line 1)
+ (while (looking-at "[ \t]")
+ (forward-line 1))
(unless (and (eobp) (not (bolp)))
(backward-char 1))
(unless list-only
(remove-overlays date-start (point)
'invisible 'diary))
- (setq temp (diary-pull-attrs
- (buffer-substring entry-start (point))
- file-glob-attrs))
+ (setq temp (diary-pull-attrs
+ (buffer-substring entry-start (point))
+ file-glob-attrs))
(add-to-diary-list
date
(car temp)
'list-diary-entries-hook)
(unless list-only
(if diary-display-hook
- (run-hooks 'diary-display-hook)
- (simple-diary-display)))
+ (run-hooks 'diary-display-hook)
+ (simple-diary-display)))
(run-hooks 'diary-hook)
diary-entries-list))))))
(remove-overlays (point-min) (point-max) 'invisible 'diary)
(kill-local-variable 'mode-line-format))
-(defvar original-date) ; bound in diary-list-entries
+(defvar original-date) ; bound in diary-list-entries
(defvar number)
(defun include-other-diary-files ()
" \"\\([^\"]*\\)\"")
nil t)
(let ((diary-file (substitute-in-file-name
- (match-string-no-properties 1)))
- (diary-list-include-blanks nil)
- (list-diary-entries-hook 'include-other-diary-files)
- (diary-display-hook 'ignore)
- (diary-hook nil))
+ (match-string-no-properties 1)))
+ (diary-list-include-blanks nil)
+ (list-diary-entries-hook 'include-other-diary-files)
+ (diary-display-hook 'ignore)
+ (diary-hook nil))
(if (file-exists-p diary-file)
(if (file-readable-p diary-file)
(unwind-protect
(beep)
(message "Can't find included diary file %s" diary-file)
(sleep-for 2))))
- (goto-char (point-min)))
+ (goto-char (point-min)))
;; Bound in diary-list-entries.
(defvar date-string)
(message "Preparing diary...done"))))
(defface diary-button '((((type pc) (class color))
- (:foreground "lightblue")))
+ (:foreground "lightblue")))
"Default face used for buttons."
:version "22.1"
:group 'diary)
(holiday-list-last-month 1)
(holiday-list-last-year 1)
(date (list 0 0 0)))
- (dolist (entry entry-list)
+ (dolist (entry entry-list)
(if (not (calendar-date-equal date (car entry)))
(progn
(setq date (car entry))
;; We need to get the holidays for the next 3 months.
(setq holiday-list-last-month
(extract-calendar-month date)
- holiday-list-last-year
+ holiday-list-last-year
(extract-calendar-year date))
(progn
(increment-calendar-month
(increment-calendar-month
holiday-list-last-month holiday-list-last-year 1))
(let (date-holiday-list)
- ;; Make a list of all holidays for date.
- (dolist (h holiday-list)
- (if (calendar-date-equal date (car h))
- (setq date-holiday-list (append date-holiday-list
- (cdr h)))))
+ ;; Make a list of all holidays for date.
+ (dolist (h holiday-list)
+ (if (calendar-date-equal date (car h))
+ (setq date-holiday-list (append date-holiday-list
+ (cdr h)))))
(insert (if (bobp) "" ?\n) (calendar-date-string date))
(if date-holiday-list (insert ": "))
(let ((l (current-column))
- (longest 0))
+ (longest 0))
(insert (mapconcat (lambda (x)
- (if (< longest (length x))
- (setq longest (length x)))
- x)
+ (if (< longest (length x))
+ (setq longest (length x)))
+ x)
date-holiday-list
(concat "\n" (make-string l ? ))))
(insert ?\n (make-string (+ l longest) ?=) ?\n)))))
- (let ((this-entry (cadr entry))
- this-loc)
- (unless (zerop (length this-entry))
- (if (setq this-loc (nth 3 entry))
- (insert-button (concat this-entry "\n")
- ;; (MARKER FILENAME SPECIFIER LITERAL)
- 'locator (list (car this-loc)
- (cadr this-loc)
- (nth 2 entry)
- (or (nth 2 this-loc)
- (nth 1 entry)))
- :type 'diary-entry)
- (insert this-entry ?\n))
- (save-excursion
- (let* ((marks (nth 4 entry))
- (faceinfo marks)
- temp-face)
- (when marks
- (setq temp-face (make-symbol
- (apply
- 'concat "temp-face-"
- (mapcar (lambda (sym)
- (if (stringp sym)
- sym
- (symbol-name sym)))
- marks))))
- (make-face temp-face)
- ;; Remove :face info from the marks,
- ;; copy the face info into temp-face
- (while (setq faceinfo (memq :face faceinfo))
- (copy-face (read (nth 1 faceinfo)) temp-face)
- (setcar faceinfo nil)
- (setcar (cdr faceinfo) nil))
- (setq marks (delq nil marks))
- ;; Apply the font aspects.
- (apply 'set-face-attribute temp-face nil marks)
- (search-backward this-entry)
- (overlay-put
- (make-overlay (match-beginning 0) (match-end 0))
- 'face temp-face))))))))
+ (let ((this-entry (cadr entry))
+ this-loc)
+ (unless (zerop (length this-entry))
+ (if (setq this-loc (nth 3 entry))
+ (insert-button (concat this-entry "\n")
+ ;; (MARKER FILENAME SPECIFIER LITERAL)
+ 'locator (list (car this-loc)
+ (cadr this-loc)
+ (nth 2 entry)
+ (or (nth 2 this-loc)
+ (nth 1 entry)))
+ :type 'diary-entry)
+ (insert this-entry ?\n))
+ (save-excursion
+ (let* ((marks (nth 4 entry))
+ (faceinfo marks)
+ temp-face)
+ (when marks
+ (setq temp-face (make-symbol
+ (apply
+ 'concat "temp-face-"
+ (mapcar (lambda (sym)
+ (if (stringp sym)
+ sym
+ (symbol-name sym)))
+ marks))))
+ (make-face temp-face)
+ ;; Remove :face info from the marks,
+ ;; copy the face info into temp-face
+ (while (setq faceinfo (memq :face faceinfo))
+ (copy-face (read (nth 1 faceinfo)) temp-face)
+ (setcar faceinfo nil)
+ (setcar (cdr faceinfo) nil))
+ (setq marks (delq nil marks))
+ ;; Apply the font aspects.
+ (apply 'set-face-attribute temp-face nil marks)
+ (search-backward this-entry)
+ (overlay-put
+ (make-overlay (match-beginning 0) (match-end 0))
+ 'face temp-face))))))))
(set-buffer-modified-p nil)
(goto-char (point-min))
(setq buffer-read-only t)
(+ y 100)
y)))
(string-to-number y-str)))))
- (setq marks (nth 1
- (diary-pull-attrs
- (buffer-substring-no-properties
- (point) (line-end-position))
- file-glob-attrs)))
+ (setq marks (nth 1
+ (diary-pull-attrs
+ (buffer-substring-no-properties
+ (point) (line-end-position))
+ file-glob-attrs)))
(if dd-name
(mark-calendar-days-named
(cdr (assoc-string
'mark-diary-entries-hook))
(message "Marking diary entries...done")))))
-(defvar displayed-year) ; bound in generate-calendar
+(defvar displayed-year) ; bound in generate-calendar
(defvar displayed-month)
(defun mark-sexp-diary-entries ()
(setq sexp (buffer-substring-no-properties sexp-start (point)))
(forward-char 1)
(if (and (bolp) (not (looking-at "[ \t]")))
- ;; Diary entry consists only of the sexp.
+ ;; Diary entry consists only of the sexp.
(progn
(backward-char 1)
(setq entry ""))
(if (bolp) (backward-char 1))
(setq entry (buffer-substring-no-properties entry-start (point))))
(calendar-for-loop date from first-date to last-date do
- (if (setq mark (diary-sexp-entry sexp entry
- (calendar-gregorian-from-absolute date)))
- (progn
- (setq marks (diary-pull-attrs entry file-glob-attrs)
- marks (nth 1 (diary-pull-attrs entry file-glob-attrs)))
- (mark-visible-calendar-date
- (calendar-gregorian-from-absolute date)
- (if (< 0 (length marks))
- marks
- (if (consp mark)
- (car mark)))))))))))
+ (if (setq mark (diary-sexp-entry sexp entry
+ (calendar-gregorian-from-absolute date)))
+ (progn
+ (setq marks (diary-pull-attrs entry file-glob-attrs)
+ marks (nth 1 (diary-pull-attrs entry file-glob-attrs)))
+ (mark-visible-calendar-date
+ (calendar-gregorian-from-absolute date)
+ (if (< 0 (length marks))
+ marks
+ (if (consp mark)
+ (car mark)))))))))))
(defun mark-included-diary-files ()
"Mark the diary entries from other diary files with those of the diary file.
(increment-calendar-month prev-month prev-year -1)
(setq day (calendar-absolute-from-gregorian
(calendar-nth-named-day 1 dayname prev-month prev-year))
- last-day (calendar-absolute-from-gregorian
- (calendar-nth-named-day -1 dayname succ-month succ-year)))
+ last-day (calendar-absolute-from-gregorian
+ (calendar-nth-named-day -1 dayname succ-month succ-year)))
(while (<= day last-day)
(mark-visible-calendar-date (calendar-gregorian-from-absolute day)
- color)
+ color)
(setq day (+ day 7))))))
(defun mark-calendar-date-pattern (month day year &optional color)
(or (zerop p-year) (= year p-year))))
(if (zerop p-day)
(calendar-for-loop
- i from 1 to (calendar-last-day-of-month month year) do
- (mark-visible-calendar-date (list month i year) color))
+ i from 1 to (calendar-last-day-of-month month year) do
+ (mark-visible-calendar-date (list month i year) color))
(mark-visible-calendar-date (list month p-day year) color))))
(defun sort-diary-entries ()
XXAM, XXpm, XXPM, XX:XXam, XX:XXAM XX:XXpm, or XX:XXPM. A period (.) can
be used instead of a colon (:) to separate the hour and minute parts."
(let ((case-fold-search nil))
- (cond ((string-match ; military time
- "\\`[ \t\n]*\\([0-9]?[0-9]\\)[:.]?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)"
+ (cond ((string-match ; military time
+ "\\`[ \t\n]*\\([0-9]?[0-9]\\)[:.]?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)"
s)
- (+ (* 100 (string-to-number (match-string 1 s)))
- (string-to-number (match-string 2 s))))
- ((string-match ; hour only (XXam or XXpm)
- "\\`[ \t\n]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
- (+ (* 100 (% (string-to-number (match-string 1 s)) 12))
- (if (equal ?a (downcase (aref s (match-beginning 2))))
- 0 1200)))
- ((string-match ; hour and minute (XX:XXam or XX:XXpm)
- "\\`[ \t\n]*\\([0-9]?[0-9]\\)[:.]\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
- (+ (* 100 (% (string-to-number (match-string 1 s)) 12))
- (string-to-number (match-string 2 s))
- (if (equal ?a (downcase (aref s (match-beginning 3))))
- 0 1200)))
- (t diary-unknown-time)))) ; unrecognizable
+ (+ (* 100 (string-to-number (match-string 1 s)))
+ (string-to-number (match-string 2 s))))
+ ((string-match ; hour only (XXam or XXpm)
+ "\\`[ \t\n]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
+ (+ (* 100 (% (string-to-number (match-string 1 s)) 12))
+ (if (equal ?a (downcase (aref s (match-beginning 2))))
+ 0 1200)))
+ ((string-match ; hour and minute (XX:XXam or XX:XXpm)
+ "\\`[ \t\n]*\\([0-9]?[0-9]\\)[:.]\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
+ (+ (* 100 (% (string-to-number (match-string 1 s)) 12))
+ (string-to-number (match-string 2 s))
+ (if (equal ?a (downcase (aref s (match-beginning 3))))
+ 0 1200)))
+ (t diary-unknown-time)))) ; unrecognizable
(defun list-sexp-diary-entries (date)
"Add sexp entries for DATE from the diary file to `diary-entries-list'.
entry-start (1+ line-start))
(forward-char 1)
(if (and (bolp) (not (looking-at "[ \t]")))
- ;; Diary entry consists only of the sexp.
+ ;; Diary entry consists only of the sexp.
(progn
(backward-char 1)
(setq entry ""))
diary-file sexp)
(sleep-for 2))))))
(cond ((stringp result) result)
- ((and (consp result)
- (stringp (cdr result))) result)
- (result entry)
+ ((and (consp result)
+ (stringp (cdr result))) result)
+ (result entry)
(t nil))))
(defvar date)
An optional parameter DAY means the Nth DAYNAME on or after/before MONTH DAY.
Optional MARK specifies a face or single-character string to use when
highlighting the day in the calendar."
-;; This is messy because the diary entry may apply, but the date on which it
-;; is based can be in a different month/year. For example, asking for the
-;; first Monday after December 30. For large values of |n| the problem is
-;; more grotesque.
+ ;; This is messy because the diary entry may apply, but the date on which it
+ ;; is based can be in a different month/year. For example, asking for the
+ ;; first Monday after December 30. For large values of |n| the problem is
+ ;; more grotesque.
(and (= dayname (calendar-day-of-week date))
(let* ((m (extract-calendar-month date))
(d (extract-calendar-day date))
(y (extract-calendar-year date))
- ;; Last (n>0) or first (n<0) possible base date for entry.
+ ;; Last (n>0) or first (n<0) possible base date for entry.
(limit
(calendar-nth-named-absday (- n) dayname m y d))
(last-abs (if (> n 0) limit (+ limit 6)))
(m2 (extract-calendar-month last))
(d2 (extract-calendar-day last))
(y2 (extract-calendar-year last)))
- (if (or (and (= m1 m2) ; only possible base dates in one month
- (or (eq month t)
- (if (listp month)
+ (if (or (and (= m1 m2) ; only possible base dates in one month
+ (or (eq month t)
+ (if (listp month)
(memq m1 month)
- (= m1 month)))
- (let ((d (or day (if (> n 0)
- 1
- (calendar-last-day-of-month m1 y1)))))
- (and (<= d1 d) (<= d d2))))
- ;; Only possible base dates straddle two months.
- (and (or (< y1 y2)
- (and (= y1 y2) (< m1 m2)))
- (or
- ;; m1, d1 works as a base date.
- (and
- (or (eq month t)
- (if (listp month)
+ (= m1 month)))
+ (let ((d (or day (if (> n 0)
+ 1
+ (calendar-last-day-of-month m1 y1)))))
+ (and (<= d1 d) (<= d d2))))
+ ;; Only possible base dates straddle two months.
+ (and (or (< y1 y2)
+ (and (= y1 y2) (< m1 m2)))
+ (or
+ ;; m1, d1 works as a base date.
+ (and
+ (or (eq month t)
+ (if (listp month)
(memq m1 month)
- (= m1 month)))
- (<= d1 (or day (if (> n 0)
- 1
- (calendar-last-day-of-month m1 y1)))))
- ;; m2, d2 works as a base date.
- (and (or (eq month t)
- (if (listp month)
+ (= m1 month)))
+ (<= d1 (or day (if (> n 0)
+ 1
+ (calendar-last-day-of-month m1 y1)))))
+ ;; m2, d2 works as a base date.
+ (and (or (eq month t)
+ (if (listp month)
(memq m2 month)
- (= m2 month)))
- (<= (or day (if (> n 0)
- 1
- (calendar-last-day-of-month m2 y2)))
- d2)))))
- (cons mark entry)))))
+ (= m2 month)))
+ (<= (or day (if (> n 0)
+ 1
+ (calendar-last-day-of-month m2 y2)))
+ d2)))))
+ (cons mark entry)))))
;; To be called from diary-sexp-entry, where DATE, ENTRY are bound.
(defun diary-anniversary (month day &optional year mark)
diary-entry)
;; Diary entry may apply to `days' before date.
((and (integerp days)
- (not diary-entry) ; diary entry does not apply to date
+ (not diary-entry) ; diary entry does not apply to date
(or (not marking-diary-entries) marking))
(let ((date (calendar-gregorian-from-absolute
(+ (calendar-absolute-from-gregorian date) days))))
(if european-calendar-style
'(day " " month " " year)
'(month " " day " " year)))
- (cursor (calendar-cursor-to-date t))
- (mark (or (car calendar-mark-ring)
- (error "No mark set in this buffer")))
- start end)
+ (cursor (calendar-cursor-to-date t))
+ (mark (or (car calendar-mark-ring)
+ (error "No mark set in this buffer")))
+ start end)
(if (< (calendar-absolute-from-gregorian mark)
(calendar-absolute-from-gregorian cursor))
(setq start mark
end cursor)
(setq start cursor
- end mark))
+ end mark))
(make-diary-entry
(format "%s(diary-block %s %s)"
- sexp-diary-entry-symbol
- (calendar-date-string start nil t)
- (calendar-date-string end nil t))
+ sexp-diary-entry-symbol
+ (calendar-date-string start nil t)
+ (calendar-date-string end nil t))
arg)))
;;;###cal-autoload
"?\\(" (regexp-quote sexp-diary-entry-symbol) "\\)")
limit t)
(condition-case nil
- (save-restriction
- (narrow-to-region (point-min) limit)
- (let ((start (point)))
- (forward-sexp 1)
- (store-match-data (list start (point)))
- t))
- (error t))))
+ (save-restriction
+ (narrow-to-region (point-min) limit)
+ (let ((start (point)))
+ (forward-sexp 1)
+ (store-match-data (list start (point)))
+ t))
+ (error t))))
(defun diary-font-lock-date-forms (month-array &optional symbol abbrev-array)
"Create font-lock patterns for `diary-date-forms' using MONTH-ARRAY.
(day "\\([0-9]+\\|\\*\\)")
(year "-?\\([0-9]+\\|\\*\\)"))
(mapcar (lambda (x)
- (cons
- (concat "^" (regexp-quote diary-nonmarking-symbol) "?"
- (if symbol (regexp-quote symbol) "") "\\("
- (mapconcat 'eval
- ;; If backup, omit first item (backup)
- ;; and last item (not part of date).
- (if (equal (car x) 'backup)
+ (cons
+ (concat "^" (regexp-quote diary-nonmarking-symbol) "?"
+ (if symbol (regexp-quote symbol) "") "\\("
+ (mapconcat 'eval
+ ;; If backup, omit first item (backup)
+ ;; and last item (not part of date).
+ (if (equal (car x) 'backup)
(nreverse (cdr (reverse (cdr x))))
- x)
- "")
- ;; With backup, last item is not part of date.
- (if (equal (car x) 'backup)
- (concat "\\)" (eval (car (reverse x))))
- "\\)"))
- '(1 diary-face)))
+ x)
+ "")
+ ;; With backup, last item is not part of date.
+ (if (equal (car x) 'backup)
+ (concat "\\)" (eval (car (reverse x))))
+ "\\)"))
+ '(1 diary-face)))
diary-date-forms)))
(defvar calendar-hebrew-month-name-array-leap-year)
(diary-font-lock-date-forms
calendar-islamic-month-name-array islamic-diary-entry-symbol))
(when (or (memq 'diary-bahai-mark-entries
- nongregorian-diary-marking-hook)
- (memq 'diary-bahai-list-entries
- nongregorian-diary-marking-hook))
+ nongregorian-diary-marking-hook)
+ (memq 'diary-bahai-list-entries
+ nongregorian-diary-marking-hook))
(require 'cal-bahai)
(diary-font-lock-date-forms
calendar-bahai-month-name-array bahai-diary-entry-symbol))
'font-lock-keyword-face)
(cons
(format "^%s?\\(%s\\)" (regexp-quote diary-nonmarking-symbol)
- (regexp-quote sexp-diary-entry-symbol))
+ (regexp-quote sexp-diary-entry-symbol))
'(1 font-lock-reference-face))
(cons
(format "^%s" (regexp-quote diary-nonmarking-symbol))
'font-lock-reference-face)
(cons
(format "^%s?%s" (regexp-quote diary-nonmarking-symbol)
- (regexp-opt (mapcar 'regexp-quote
- (list hebrew-diary-entry-symbol
- islamic-diary-entry-symbol
- bahai-diary-entry-symbol))
- t))
+ (regexp-opt (mapcar 'regexp-quote
+ (list hebrew-diary-entry-symbol
+ islamic-diary-entry-symbol
+ bahai-diary-entry-symbol))
+ t))
'(1 font-lock-reference-face))
'(diary-font-lock-sexps . font-lock-keyword-face)
`(,(format "\\(^\\|\\s-\\)%s\\(-%s\\)?" diary-time-regexp
- diary-time-regexp)
+ diary-time-regexp)
. 'diary-time))))
(defvar diary-font-lock-keywords (diary-font-lock-keywords)
(catch 'finished
(let (format-string)
(dotimes (i (length diary-outlook-formats))
- (when (eq 0 (string-match (car (nth i diary-outlook-formats))
- body))
- (unless test-only
- (setq format-string (cdr (nth i diary-outlook-formats)))
- (save-excursion
- (save-window-excursion
- ;; Fixme: References to optional fields in the format
- ;; are treated literally, not replaced by the empty
- ;; string. I think this is an Emacs bug.
- (make-diary-entry
- (format (replace-match (if (functionp format-string)
- (funcall format-string body)
- format-string)
- t nil (match-string 0 body))
- subject))
- (save-buffer))))
- (throw 'finished t))))
+ (when (eq 0 (string-match (car (nth i diary-outlook-formats))
+ body))
+ (unless test-only
+ (setq format-string (cdr (nth i diary-outlook-formats)))
+ (save-excursion
+ (save-window-excursion
+ ;; Fixme: References to optional fields in the format
+ ;; are treated literally, not replaced by the empty
+ ;; string. I think this is an Emacs bug.
+ (make-diary-entry
+ (format (replace-match (if (functionp format-string)
+ (funcall format-string body)
+ format-string)
+ t nil (match-string 0 body))
+ subject))
+ (save-buffer))))
+ (throw 'finished t))))
nil))
(defun diary-from-outlook (&optional noconfirm)
user is asked to confirm its addition."
(interactive "p")
(let ((func (cond
- ((eq major-mode 'rmail-mode)
- #'diary-from-outlook-rmail)
- ((memq major-mode '(gnus-summary-mode gnus-article-mode))
- #'diary-from-outlook-gnus)
- (t (error "Don't know how to snarf in `%s'" major-mode)))))
+ ((eq major-mode 'rmail-mode)
+ #'diary-from-outlook-rmail)
+ ((memq major-mode '(gnus-summary-mode gnus-article-mode))
+ #'diary-from-outlook-gnus)
+ (t (error "Don't know how to snarf in `%s'" major-mode)))))
(funcall func noconfirm)))
(interactive "p")
(with-current-buffer gnus-article-buffer
(let ((subject (gnus-fetch-field "subject"))
- (body (if gnus-article-mime-handles
- ;; We're multipart. Don't get confused by part
- ;; buttons &c. Assume info is in first part.
- (mm-get-part (nth 1 gnus-article-mime-handles))
- (save-restriction
- (gnus-narrow-to-body)
- (buffer-string)))))
+ (body (if gnus-article-mime-handles
+ ;; We're multipart. Don't get confused by part
+ ;; buttons &c. Assume info is in first part.
+ (mm-get-part (nth 1 gnus-article-mime-handles))
+ (save-restriction
+ (gnus-narrow-to-body)
+ (buffer-string)))))
(when (diary-from-outlook-internal t)
- (when (or noconfirm (y-or-n-p "Snarf diary entry? "))
- (diary-from-outlook-internal)
- (message "Diary entry added"))))))
+ (when (or noconfirm (y-or-n-p "Snarf diary entry? "))
+ (diary-from-outlook-internal)
+ (message "Diary entry added"))))))
(custom-add-option 'gnus-article-prepare-hook 'diary-from-outlook-gnus)
(interactive "p")
(with-current-buffer rmail-buffer
(let ((subject (mail-fetch-field "subject"))
- (body (buffer-substring (save-excursion
- (rfc822-goto-eoh)
- (point))
- (point-max))))
+ (body (buffer-substring (save-excursion
+ (rfc822-goto-eoh)
+ (point))
+ (point-max))))
(when (diary-from-outlook-internal t)
- (when (or noconfirm (y-or-n-p "Snarf diary entry? "))
- (diary-from-outlook-internal)
- (message "Diary entry added"))))))
+ (when (or noconfirm (y-or-n-p "Snarf diary entry? "))
+ (diary-from-outlook-internal)
+ (message "Diary entry added"))))))
(provide 'diary-lib)
((= phase 2) (- adjustment adj))
(t adjustment)))
(date (+ date adjustment))
- (date (+ date (/ (- calendar-time-zone
- (solar-ephemeris-correction
+ (date (+ date (/ (- calendar-time-zone
+ (solar-ephemeris-correction
(extract-calendar-year
(calendar-gregorian-from-absolute
(truncate date)))))
- 60.0 24.0)))
+ 60.0 24.0)))
(time (* 24 (- date (truncate date))))
- (date (calendar-gregorian-from-absolute (truncate date)))
+ (date (calendar-gregorian-from-absolute (truncate date)))
(adj (dst-adjust-time date time)))
(list (car adj) (apply 'solar-time-string (cdr adj)) phase)))
(defun lunar-new-moon-time (k)
"Astronomical (Julian) day number of K th new moon."
(let* ((T (/ k 1236.85))
- (T2 (* T T))
- (T3 (* T T T))
- (T4 (* T2 T2))
- (JDE (+ 2451550.09765
- (* 29.530588853 k)
- (* 0.0001337 T2)
- (* -0.000000150 T3)
- (* 0.00000000073 T4)))
- (E (- 1 (* 0.002516 T) (* 0.0000074 T2)))
- (sun-anomaly (+ 2.5534
- (* 29.10535669 k)
- (* -0.0000218 T2)
- (* -0.00000011 T3)))
- (moon-anomaly (+ 201.5643
- (* 385.81693528 k)
- (* 0.0107438 T2)
- (* 0.00001239 T3)
- (* -0.000000058 T4)))
- (moon-argument (+ 160.7108
- (* 390.67050274 k)
- (* -0.0016341 T2)
- (* -0.00000227 T3)
- (* 0.000000011 T4)))
- (omega (+ 124.7746
- (* -1.56375580 k)
- (* 0.0020691 T2)
- (* 0.00000215 T3)))
- (A1 (+ 299.77 (* 0.107408 k) (* -0.009173 T2)))
- (A2 (+ 251.88 (* 0.016321 k)))
- (A3 (+ 251.83 (* 26.641886 k)))
- (A4 (+ 349.42 (* 36.412478 k)))
- (A5 (+ 84.66 (* 18.206239 k)))
- (A6 (+ 141.74 (* 53.303771 k)))
- (A7 (+ 207.14 (* 2.453732 k)))
- (A8 (+ 154.84 (* 7.306860 k)))
- (A9 (+ 34.52 (* 27.261239 k)))
- (A10 (+ 207.19 (* 0.121824 k)))
- (A11 (+ 291.34 (* 1.844379 k)))
- (A12 (+ 161.72 (* 24.198154 k)))
- (A13 (+ 239.56 (* 25.513099 k)))
- (A14 (+ 331.55 (* 3.592518 k)))
- (correction
- (+ (* -0.40720 (solar-sin-degrees moon-anomaly))
- (* 0.17241 E (solar-sin-degrees sun-anomaly))
- (* 0.01608 (solar-sin-degrees (* 2 moon-anomaly)))
- (* 0.01039 (solar-sin-degrees (* 2 moon-argument)))
- (* 0.00739 E (solar-sin-degrees (- moon-anomaly sun-anomaly)))
- (* -0.00514 E (solar-sin-degrees (+ moon-anomaly sun-anomaly)))
- (* 0.00208 E E (solar-sin-degrees (* 2 sun-anomaly)))
- (* -0.00111 (solar-sin-degrees
- (- moon-anomaly (* 2 moon-argument))))
- (* -0.00057 (solar-sin-degrees
- (+ moon-anomaly (* 2 moon-argument))))
- (* 0.00056 E (solar-sin-degrees
- (+ (* 2 moon-anomaly) sun-anomaly)))
- (* -0.00042 (solar-sin-degrees (* 3 moon-anomaly)))
- (* 0.00042 E (solar-sin-degrees
- (+ sun-anomaly (* 2 moon-argument))))
- (* 0.00038 E (solar-sin-degrees
- (- sun-anomaly (* 2 moon-argument))))
- (* -0.00024 E (solar-sin-degrees
- (- (* 2 moon-anomaly) sun-anomaly)))
- (* -0.00017 (solar-sin-degrees omega))
- (* -0.00007 (solar-sin-degrees
- (+ moon-anomaly (* 2 sun-anomaly))))
- (* 0.00004 (solar-sin-degrees
- (- (* 2 moon-anomaly) (* 2 moon-argument))))
- (* 0.00004 (solar-sin-degrees (* 3 sun-anomaly)))
- (* 0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly
- (* -2 moon-argument))))
- (* 0.00003 (solar-sin-degrees
- (+ (* 2 moon-anomaly) (* 2 moon-argument))))
- (* -0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly
- (* 2 moon-argument))))
- (* 0.00003 (solar-sin-degrees (- moon-anomaly sun-anomaly
- (* -2 moon-argument))))
- (* -0.00002 (solar-sin-degrees (- moon-anomaly sun-anomaly
- (* 2 moon-argument))))
- (* -0.00002 (solar-sin-degrees
- (+ (* 3 moon-anomaly) sun-anomaly)))
- (* 0.00002 (solar-sin-degrees (* 4 moon-anomaly)))))
- (additional
- (+ (* 0.000325 (solar-sin-degrees A1))
- (* 0.000165 (solar-sin-degrees A2))
- (* 0.000164 (solar-sin-degrees A3))
- (* 0.000126 (solar-sin-degrees A4))
- (* 0.000110 (solar-sin-degrees A5))
- (* 0.000062 (solar-sin-degrees A6))
- (* 0.000060 (solar-sin-degrees A7))
- (* 0.000056 (solar-sin-degrees A8))
- (* 0.000047 (solar-sin-degrees A9))
- (* 0.000042 (solar-sin-degrees A10))
- (* 0.000040 (solar-sin-degrees A11))
- (* 0.000037 (solar-sin-degrees A12))
- (* 0.000035 (solar-sin-degrees A13))
- (* 0.000023 (solar-sin-degrees A14))))
- (newJDE (+ JDE correction additional)))
+ (T2 (* T T))
+ (T3 (* T T T))
+ (T4 (* T2 T2))
+ (JDE (+ 2451550.09765
+ (* 29.530588853 k)
+ (* 0.0001337 T2)
+ (* -0.000000150 T3)
+ (* 0.00000000073 T4)))
+ (E (- 1 (* 0.002516 T) (* 0.0000074 T2)))
+ (sun-anomaly (+ 2.5534
+ (* 29.10535669 k)
+ (* -0.0000218 T2)
+ (* -0.00000011 T3)))
+ (moon-anomaly (+ 201.5643
+ (* 385.81693528 k)
+ (* 0.0107438 T2)
+ (* 0.00001239 T3)
+ (* -0.000000058 T4)))
+ (moon-argument (+ 160.7108
+ (* 390.67050274 k)
+ (* -0.0016341 T2)
+ (* -0.00000227 T3)
+ (* 0.000000011 T4)))
+ (omega (+ 124.7746
+ (* -1.56375580 k)
+ (* 0.0020691 T2)
+ (* 0.00000215 T3)))
+ (A1 (+ 299.77 (* 0.107408 k) (* -0.009173 T2)))
+ (A2 (+ 251.88 (* 0.016321 k)))
+ (A3 (+ 251.83 (* 26.641886 k)))
+ (A4 (+ 349.42 (* 36.412478 k)))
+ (A5 (+ 84.66 (* 18.206239 k)))
+ (A6 (+ 141.74 (* 53.303771 k)))
+ (A7 (+ 207.14 (* 2.453732 k)))
+ (A8 (+ 154.84 (* 7.306860 k)))
+ (A9 (+ 34.52 (* 27.261239 k)))
+ (A10 (+ 207.19 (* 0.121824 k)))
+ (A11 (+ 291.34 (* 1.844379 k)))
+ (A12 (+ 161.72 (* 24.198154 k)))
+ (A13 (+ 239.56 (* 25.513099 k)))
+ (A14 (+ 331.55 (* 3.592518 k)))
+ (correction
+ (+ (* -0.40720 (solar-sin-degrees moon-anomaly))
+ (* 0.17241 E (solar-sin-degrees sun-anomaly))
+ (* 0.01608 (solar-sin-degrees (* 2 moon-anomaly)))
+ (* 0.01039 (solar-sin-degrees (* 2 moon-argument)))
+ (* 0.00739 E (solar-sin-degrees (- moon-anomaly sun-anomaly)))
+ (* -0.00514 E (solar-sin-degrees (+ moon-anomaly sun-anomaly)))
+ (* 0.00208 E E (solar-sin-degrees (* 2 sun-anomaly)))
+ (* -0.00111 (solar-sin-degrees
+ (- moon-anomaly (* 2 moon-argument))))
+ (* -0.00057 (solar-sin-degrees
+ (+ moon-anomaly (* 2 moon-argument))))
+ (* 0.00056 E (solar-sin-degrees
+ (+ (* 2 moon-anomaly) sun-anomaly)))
+ (* -0.00042 (solar-sin-degrees (* 3 moon-anomaly)))
+ (* 0.00042 E (solar-sin-degrees
+ (+ sun-anomaly (* 2 moon-argument))))
+ (* 0.00038 E (solar-sin-degrees
+ (- sun-anomaly (* 2 moon-argument))))
+ (* -0.00024 E (solar-sin-degrees
+ (- (* 2 moon-anomaly) sun-anomaly)))
+ (* -0.00017 (solar-sin-degrees omega))
+ (* -0.00007 (solar-sin-degrees
+ (+ moon-anomaly (* 2 sun-anomaly))))
+ (* 0.00004 (solar-sin-degrees
+ (- (* 2 moon-anomaly) (* 2 moon-argument))))
+ (* 0.00004 (solar-sin-degrees (* 3 sun-anomaly)))
+ (* 0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly
+ (* -2 moon-argument))))
+ (* 0.00003 (solar-sin-degrees
+ (+ (* 2 moon-anomaly) (* 2 moon-argument))))
+ (* -0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly
+ (* 2 moon-argument))))
+ (* 0.00003 (solar-sin-degrees (- moon-anomaly sun-anomaly
+ (* -2 moon-argument))))
+ (* -0.00002 (solar-sin-degrees (- moon-anomaly sun-anomaly
+ (* 2 moon-argument))))
+ (* -0.00002 (solar-sin-degrees
+ (+ (* 3 moon-anomaly) sun-anomaly)))
+ (* 0.00002 (solar-sin-degrees (* 4 moon-anomaly)))))
+ (additional
+ (+ (* 0.000325 (solar-sin-degrees A1))
+ (* 0.000165 (solar-sin-degrees A2))
+ (* 0.000164 (solar-sin-degrees A3))
+ (* 0.000126 (solar-sin-degrees A4))
+ (* 0.000110 (solar-sin-degrees A5))
+ (* 0.000062 (solar-sin-degrees A6))
+ (* 0.000060 (solar-sin-degrees A7))
+ (* 0.000056 (solar-sin-degrees A8))
+ (* 0.000047 (solar-sin-degrees A9))
+ (* 0.000042 (solar-sin-degrees A10))
+ (* 0.000040 (solar-sin-degrees A11))
+ (* 0.000037 (solar-sin-degrees A12))
+ (* 0.000035 (solar-sin-degrees A13))
+ (* 0.000023 (solar-sin-degrees A14))))
+ (newJDE (+ JDE correction additional)))
(+ newJDE
(- (solar-ephemeris-correction
(extract-calendar-year
(let* ((date (calendar-gregorian-from-absolute
(floor (calendar-absolute-from-astro d))))
(year (+ (extract-calendar-year date)
- (/ (calendar-day-number date) 365.25)))
- (k (floor (* (- year 2000.0) 12.3685)))
+ (/ (calendar-day-number date) 365.25)))
+ (k (floor (* (- year 2000.0) 12.3685)))
(date (lunar-new-moon-time k)))
(while (< date d)
(setq k (1+ k))
projects / emacs.git / commitdiff