aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorJim Blandy1991-08-23 03:01:50 +0000
committerJim Blandy1991-08-23 03:01:50 +0000
commit1802278ad5663e87a0ece7df9e6eb4650683e883 (patch)
tree5c531fa022b48963f54c79f4551ca7c2c76f8cda
parenta553316bbc4c8d6f4457bf57496ab9e53dad85a1 (diff)
downloademacs-1802278ad5663e87a0ece7df9e6eb4650683e883.tar.gz
emacs-1802278ad5663e87a0ece7df9e6eb4650683e883.zip
Initial revision
Diffstat
-rw-r--r--lisp/calendar/holidays.el587
-rw-r--r--lisp/diary-lib.el2127
2 files changed, 2714 insertions, 0 deletions
diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el
new file mode 100644
index 00000000000..88185436778
--- /dev/null
+++ b/lisp/calendar/holidays.el
@@ -0,0 +1,587 @@
1;; Holiday functions.
2;; Copyright (C) 1989, 1990, 1991 Free Software Foundation, Inc.
3
4;; This file is part of GNU Emacs.
5
6;; GNU Emacs is distributed in the hope that it will be useful,
7;; but WITHOUT ANY WARRANTY. No author or distributor
8;; accepts responsibility to anyone for the consequences of using it
9;; or for whether it serves any particular purpose or works at all,
10;; unless he says so in writing. Refer to the GNU Emacs General Public
11;; License for full details.
12
13;; Everyone is granted permission to copy, modify and redistribute
14;; GNU Emacs, but only under the conditions described in the
15;; GNU Emacs General Public License. A copy of this license is
16;; supposed to have been given to you along with GNU Emacs so you
17;; can know your rights and responsibilities. It should be in a
18;; file named COPYING. Among other things, the copyright notice
19;; and this notice must be preserved on all copies.
20
21;; This collection of functions implements the holiday features as described
22;; in calendar.el.
23
24;; Comments, corrections, and improvements should be sent to
25;; Edward M. Reingold Department of Computer Science
26;; (217) 333-6733 University of Illinois at Urbana-Champaign
27;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
28;; Urbana, Illinois 61801
29
30;; Technical details of all the calendrical calculations can be found in
31;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold,
32;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990),
33;; pages 899-928.
34
35(require 'calendar)
36(provide 'holidays)
37
38(defun holidays ()
39 "Display the holidays for last month, this month, and next month.
40This function is suitable for execution in a .emacs file."
41 (interactive)
42 (save-excursion
43 (let* ((date (calendar-current-date))
44 (displayed-month (extract-calendar-month date))
45 (displayed-year (extract-calendar-year date)))
46 (list-calendar-holidays))))
47
48(defun check-calendar-holidays (date)
49 "Check the list of holidays for any that occur on DATE.
50The value returned is a list of strings of relevant holiday descriptions.
51The holidays are those in the list calendar-holidays."
52 (let* ((displayed-month (extract-calendar-month date))
53 (displayed-year (extract-calendar-year date))
54 (h (calendar-holiday-list))
55 (holiday-list))
56 (while h
57 (if (calendar-date-equal date (car (car h)))
58 (setq holiday-list (append holiday-list (cdr (car h)))))
59 (setq h (cdr h)))
60 holiday-list))
61
62(defun calendar-cursor-holidays ()
63 "Find holidays for the date specified by the cursor in the calendar window."
64 (interactive)
65 (message "Checking holidays...")
66 (let* ((date (calendar-cursor-to-date))
67 (date-string (calendar-date-string date))
68 (holiday-list (check-calendar-holidays date))
69 (holiday-string (mapconcat 'identity holiday-list "; "))
70 (msg (format "%s: %s" date-string holiday-string)))
71 (if (not holiday-list)
72 (message "No holidays known for %s" date-string)
73 (if (<= (length msg) (screen-width))
74 (message msg)
75 (set-buffer (get-buffer-create holiday-buffer))
76 (setq buffer-read-only nil)
77 (setq mode-line-format
78 (format "--------------------------%s%%-"
79 date-string))
80 (erase-buffer)
81 (insert (mapconcat 'identity holiday-list "\n"))
82 (goto-char (point-min))
83 (set-buffer-modified-p nil)
84 (setq buffer-read-only t)
85 (display-buffer holiday-buffer)
86 (message "Checking holidays...done")))))
87
88(defun mark-calendar-holidays ()
89 "Mark notable days in the calendar window."
90 (interactive)
91 (setq mark-holidays-in-calendar t)
92 (message "Marking holidays...")
93 (let ((holiday-list (calendar-holiday-list)))
94 (while holiday-list
95 (mark-visible-calendar-date
96 (car (car holiday-list)) calendar-holiday-marker)
97 (setq holiday-list (cdr holiday-list))))
98 (message "Marking holidays...done"))
99
100(defun list-calendar-holidays ()
101 "Create a buffer containing the holidays for the current calendar window.
102The holidays are those in the list calendar-notable-days. Returns t if any
103holidays are found, nil if not."
104 (interactive)
105 (message "Looking up holidays...")
106 (let ((holiday-list (calendar-holiday-list))
107 (m1 displayed-month)
108 (y1 displayed-year)
109 (m2 displayed-month)
110 (y2 displayed-year))
111 (if (not holiday-list)
112 (progn
113 (message "Looking up holidays...none found")
114 nil)
115 (set-buffer (get-buffer-create holiday-buffer))
116 (setq buffer-read-only nil)
117 (increment-calendar-month m1 y1 -1)
118 (increment-calendar-month m2 y2 1)
119 (setq mode-line-format
120 (format "-------------Notable Dates from %s, %d to %s, %d%%-"
121 (calendar-month-name m1) y1 (calendar-month-name m2) y2))
122 (erase-buffer)
123 (insert
124 (mapconcat
125 '(lambda (x) (concat (calendar-date-string (car x))
126 ": " (car (cdr x))))
127 holiday-list "\n"))
128 (goto-char (point-min))
129 (set-buffer-modified-p nil)
130 (setq buffer-read-only t)
131 (display-buffer holiday-buffer)
132 (message "Looking up holidays...done")
133 t)))
134
135(defun calendar-holiday-list ()
136 "Form the list of holidays that occur on dates in the calendar window.
137The holidays are those in the list calendar-holidays."
138 (let ((p calendar-holidays)
139 (holiday-list))
140 (while p
141 (let* ((function-name
142 (intern (format "calendar-holiday-function-%s" (car (car p)))))
143 (holidays
144 (if (cdr (car p));; optional arguments
145 (funcall function-name (cdr (car p)))
146 (funcall function-name))))
147 (if holidays
148 (setq holiday-list (append holidays holiday-list))))
149 (setq p (cdr p)))
150 (setq holiday-list (sort holiday-list 'calendar-date-compare))))
151
152;; Below are the functions that calculate the dates of holidays; these
153;; are called by the funcall in the function calendar-holiday-list. If you
154;; write other such functions, be sure to imitate the style used below,
155;; including the evaluation of each element in the list that constitutes
156;; the argument to the function. If you don't do this evaluation, the
157;; list calendar-holidays cannot contain expressions (as, for example, in
158;; the entry for the Islamic new year. Also remember that each function
159;; must return a list of items of the form ((month day year) string);
160;; the date (month day year) should be visible in the calendar window.
161
162(defun calendar-holiday-function-fixed (x)
163 "Returns the corresponding Gregorian date, if visible in the window, to
164month, year where month is (car X) and year is (car (cdr X)). If it is
165visible, the value returned is the list (((month day year) string)) where
166string is (car (nthcdr 2 X)). Returns nil if it is not visible in the
167current calendar window."
168 (let* ((month (eval (car x)))
169 (day (eval (car (cdr x))))
170 (string (eval (car (nthcdr 2 x))))
171 (m displayed-month)
172 (y displayed-year))
173 (increment-calendar-month m y (- 11 month))
174 (if (> m 9)
175 (list (list (list month day y) string)))))
176
177(defun calendar-holiday-function-float (x)
178 "Returns the corresponding Gregorian date, if visible in the window, to the
179n-th occurrence (negative counts from the end of the month) of dayname in
180month, year where month is (car X), year is (car (cdr X)), n is
181\(car \(nthcdr 2 X\)\). If it is visible, the value returned is the list
182\(\(\(month day year)\ string\)\) where string is (car (nthcdr 3 X)).
183Returns nil if it is not visible in the current calendar window."
184 (let* ((month (eval (car x)))
185 (dayname (eval (car (cdr x))))
186 (n (eval (car (nthcdr 2 x))))
187 (string (eval (car (nthcdr 3 x))))
188 (m displayed-month)
189 (y displayed-year))
190 (increment-calendar-month m y (- 11 month))
191 (if (> m 9)
192 (list (list (calendar-nth-named-day n dayname month y) string)))))
193
194(defun calendar-holiday-function-julian (x)
195 "Returns the corresponding Gregorian date, if visible in the window, to the
196Julian date month, year where month is (car X) and year is (car (cdr X)).
197If it is visible, the value returned is the list (((month day year) string))
198where string is (car (nthcdr 2 X)). Returns nil if it is not visible in the
199current calendar window."
200 (let* ((month (eval (car x)))
201 (day (eval (car (cdr x))))
202 (string (eval (car (nthcdr 2 x))))
203 (m1 displayed-month)
204 (y1 displayed-year)
205 (m2 displayed-month)
206 (y2 displayed-year)
207 (year))
208 (increment-calendar-month m1 y1 -1)
209 (increment-calendar-month m2 y2 1)
210 (let* ((start-date (calendar-absolute-from-gregorian
211 (list m1 1 y1)))
212 (end-date (calendar-absolute-from-gregorian
213 (list m2 (calendar-last-day-of-month m2 y2) y2)))
214 (julian-start (calendar-julian-from-absolute start-date))
215 (julian-end (calendar-julian-from-absolute end-date))
216 (julian-y1 (extract-calendar-year julian-start))
217 (julian-y2 (extract-calendar-year julian-end)))
218 (setq year (if (< 10 month) julian-y1 julian-y2))
219 (let ((date (calendar-gregorian-from-absolute
220 (calendar-absolute-from-julian
221 (list month day year)))))
222 (if (calendar-date-is-visible-p date)
223 (list (list date string)))))))
224
225(defun calendar-holiday-function-islamic (x)
226 "Returns the corresponding Gregorian date, if visible in the window, to the
227Islamic date month, day where month is (car X) and day is (car (cdr X)).
228If it is visible, the value returned is the list (((month day year) string))
229where string is (car (nthcdr 2 X)). Returns nil if it is not visible in
230the current calendar window."
231 (let* ((month (eval (car x)))
232 (day (eval (car (cdr x))))
233 (string (eval (car (nthcdr 2 x))))
234 (islamic-date (calendar-islamic-from-absolute
235 (calendar-absolute-from-gregorian
236 (list displayed-month 15 displayed-year))))
237 (m (extract-calendar-month islamic-date))
238 (y (extract-calendar-year islamic-date))
239 (date))
240 (if (< m 1)
241 nil;; Islamic calendar doesn't apply.
242 (increment-calendar-month m y (- 10 month))
243 (if (> m 7);; Islamic date might be visible
244 (let ((date (calendar-gregorian-from-absolute
245 (calendar-absolute-from-islamic (list month day y)))))
246 (if (calendar-date-is-visible-p date)
247 (list (list date string))))))))
248
249(defun calendar-holiday-function-hebrew (x)
250 "Returns the corresponding Gregorian date, if visible in the window, to the
251Hebrew date month, day where month is (car X) and day is (car (cdr X)).
252If it is visible, the value returned is the list (((month day year) string))
253where string is (car (nthcdr 2 X)). Returns nil if it is not visible in
254the current calendar window."
255 (let* ((month (eval (car x)))
256 (day (eval (car (cdr x))))
257 (string (eval (car (nthcdr 2 x)))))
258 (if (memq displayed-month;; This test is only to speed things up a bit;
259 (list ;; it works fine without the test too.
260 (if (< 11 month) (- month 11) (+ month 1))
261 (if (< 10 month) (- month 10) (+ month 2))
262 (if (< 9 month) (- month 9) (+ month 3))
263 (if (< 8 month) (- month 8) (+ month 4))
264 (if (< 7 month) (- month 7) (+ month 5))))
265 (let ((m1 displayed-month)
266 (y1 displayed-year)
267 (m2 displayed-month)
268 (y2 displayed-year)
269 (year))
270 (increment-calendar-month m1 y1 -1)
271 (increment-calendar-month m2 y2 1)
272 (let* ((start-date (calendar-absolute-from-gregorian
273 (list m1 1 y1)))
274 (end-date (calendar-absolute-from-gregorian
275 (list m2 (calendar-last-day-of-month m2 y2) y2)))
276 (hebrew-start (calendar-hebrew-from-absolute start-date))
277 (hebrew-end (calendar-hebrew-from-absolute end-date))
278 (hebrew-y1 (extract-calendar-year hebrew-start))
279 (hebrew-y2 (extract-calendar-year hebrew-end)))
280 (setq year (if (< 6 month) hebrew-y2 hebrew-y1))
281 (let ((date (calendar-gregorian-from-absolute
282 (calendar-absolute-from-hebrew
283 (list month day year)))))
284 (if (calendar-date-is-visible-p date)
285 (list (list date string)))))))))
286
287(defun calendar-holiday-function-if (x)
288 "Conditional holiday for dates in the calendar window.
289The boolean condition is (car X). If t, the holiday (car (cdr X)) is
290checked. If nil, the holiday (car (cdr (cdr X))), if there, is checked."
291 (let* ((boolean (eval (car x)))
292 (h (if boolean (car (cdr x)) (car (cdr (cdr x))))))
293 (if h
294 (let* ((function-name
295 (intern (format "calendar-holiday-function-%s" (car h))))
296 (holidays
297 (if (cdr h);; optional arguments
298 (funcall function-name (cdr h))
299 (funcall function-name))))
300 holidays))))
301
302(defun calendar-holiday-function-advent ()
303 "Date of Advent, if visible in calendar window."
304 (let ((year displayed-year)
305 (month displayed-month))
306 (increment-calendar-month month year -1)
307 (let ((advent (calendar-gregorian-from-absolute
308 (calendar-dayname-on-or-before 0
309 (calendar-absolute-from-gregorian
310 (list 12 3 year))))))
311 (if (calendar-date-is-visible-p advent)
312 (list (list advent "Advent"))))))
313
314(defun calendar-holiday-function-easter-etc ()
315 "List of dates related to Easter, as visible in calendar window."
316 (if (and (> displayed-month 5) (not all-christian-calendar-holidays))
317 nil;; Ash Wednesday, Good Friday, and Easter are not visible.
318 (let* ((century (1+ (/ displayed-year 100)))
319 (shifted-epact ;; Age of moon for April 5...
320 (% (+ 14 (* 11 (% displayed-year 19));; ...by Nicaean rule
321 (- ;; ...corrected for the Gregorian century rule
322 (/ (* 3 century) 4))
323 (/ ;; ...corrected for Metonic cycle inaccuracy.
324 (+ 5 (* 8 century)) 25)
325 (* 30 century));; Keeps value positive.
326 30))
327 (adjusted-epact ;; Adjust for 29.5 day month.
328 (if (or (= shifted-epact 0)
329 (and (= shifted-epact 1) (< 10 (% displayed-year 19))))
330 (1+ shifted-epact)
331 shifted-epact))
332 (paschal-moon ;; Day after the full moon on or after March 21.
333 (- (calendar-absolute-from-gregorian (list 4 19 displayed-year))
334 adjusted-epact))
335 (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7)))
336 (mandatory
337 (list
338 (list (calendar-gregorian-from-absolute abs-easter)
339 "Easter Sunday")
340 (list (calendar-gregorian-from-absolute (- abs-easter 2))
341 "Good Friday")
342 (list (calendar-gregorian-from-absolute (- abs-easter 46))
343 "Ash Wednesday")))
344 (optional
345 (list
346 (list (calendar-gregorian-from-absolute (- abs-easter 63))
347 "Septuagesima Sunday")
348 (list (calendar-gregorian-from-absolute (- abs-easter 56))
349 "Sexagesima Sunday")
350 (list (calendar-gregorian-from-absolute (- abs-easter 49))
351 "Shrove Sunday")
352 (list (calendar-gregorian-from-absolute (- abs-easter 48))
353 "Shrove Monday")
354 (list (calendar-gregorian-from-absolute (- abs-easter 47))
355 "Shrove Tuesday")
356 (list (calendar-gregorian-from-absolute (- abs-easter 14))
357 "Passion Sunday")
358 (list (calendar-gregorian-from-absolute (- abs-easter 7))
359 "Palm Sunday")
360 (list (calendar-gregorian-from-absolute (- abs-easter 3))
361 "Maundy Thursday")
362 (list (calendar-gregorian-from-absolute (+ abs-easter 35))
363 "Rogation Sunday")
364 (list (calendar-gregorian-from-absolute (+ abs-easter 39))
365 "Ascension Sunday")
366 (list (calendar-gregorian-from-absolute (+ abs-easter 49))
367 "Pentecost (Whitsunday)")
368 (list (calendar-gregorian-from-absolute (+ abs-easter 50))
369 "Whitmunday")
370 (list (calendar-gregorian-from-absolute (+ abs-easter 56))
371 "Trinity Sunday")
372 (list (calendar-gregorian-from-absolute (+ abs-easter 60))
373 "Corpus Christi")))
374 (output-list
375 (filter-visible-calendar-holidays mandatory)))
376 (if all-christian-calendar-holidays
377 (setq output-list
378 (append
379 (filter-visible-calendar-holidays optional)
380 output-list)))
381 output-list)))
382
383(defun calendar-holiday-function-rosh-hashanah-etc ()
384 "List of dates related to Rosh Hashanah, as visible in calendar window."
385 (if (or (< displayed-month 8)
386 (> displayed-month 11))
387 nil;; None of the dates is visible
388 (let* ((abs-r-h (calendar-absolute-from-hebrew
389 (list 7 1 (+ displayed-year 3761))))
390 (mandatory
391 (list
392 (list (calendar-gregorian-from-absolute abs-r-h)
393 (format "Rosh HaShanah %d" (+ 3761 displayed-year)))
394 (list (calendar-gregorian-from-absolute (+ abs-r-h 9))
395 "Yom Kippur")
396 (list (calendar-gregorian-from-absolute (+ abs-r-h 14))
397 "Sukkot")
398 (list (calendar-gregorian-from-absolute (+ abs-r-h 21))
399 "Shemini Atzeret")
400 (list (calendar-gregorian-from-absolute (+ abs-r-h 22))
401 "Simchat Torah")))
402 (optional
403 (list
404 (list (calendar-gregorian-from-absolute
405 (calendar-dayname-on-or-before 6 (- abs-r-h 4)))
406 "Selichot (night)")
407 (list (calendar-gregorian-from-absolute (1- abs-r-h))
408 "Erev Rosh HaShannah")
409 (list (calendar-gregorian-from-absolute (1+ abs-r-h))
410 "Rosh HaShanah (second day)")
411 (list (calendar-gregorian-from-absolute
412 (if (= (% abs-r-h 7) 4) (+ abs-r-h 3) (+ abs-r-h 2)))
413 "Tzom Gedaliah")
414 (list (calendar-gregorian-from-absolute
415 (calendar-dayname-on-or-before 6 (+ 7 abs-r-h)))
416 "Shabbat Shuvah")
417 (list (calendar-gregorian-from-absolute (+ abs-r-h 8))
418 "Erev Yom Kippur")
419 (list (calendar-gregorian-from-absolute (+ abs-r-h 13))
420 "Erev Sukkot")
421 (list (calendar-gregorian-from-absolute (+ abs-r-h 15))
422 "Sukkot (second day)")
423 (list (calendar-gregorian-from-absolute (+ abs-r-h 16))
424 "Hol Hamoed Sukkot (first day)")
425 (list (calendar-gregorian-from-absolute (+ abs-r-h 17))
426 "Hol Hamoed Sukkot (second day)")
427 (list (calendar-gregorian-from-absolute (+ abs-r-h 18))
428 "Hol Hamoed Sukkot (third day)")
429 (list (calendar-gregorian-from-absolute (+ abs-r-h 19))
430 "Hol Hamoed Sukkot (fourth day)")
431 (list (calendar-gregorian-from-absolute (+ abs-r-h 20))
432 "Hoshannah Rabbah")))
433 (output-list
434 (filter-visible-calendar-holidays mandatory)))
435 (if all-hebrew-calendar-holidays
436 (setq output-list
437 (append
438 (filter-visible-calendar-holidays optional)
439 output-list)))
440 output-list)))
441
442(defun calendar-holiday-function-hanukkah ()
443 "List of dates related to Hanukkah, as visible in calendar window."
444 (if (memq displayed-month;; This test is only to speed things up a bit;
445 '(10 11 12 1 2));; it works fine without the test too.
446 (let ((m displayed-month)
447 (y displayed-year))
448 (increment-calendar-month m y 1)
449 (let* ((h-y (extract-calendar-year
450 (calendar-hebrew-from-absolute
451 (calendar-absolute-from-gregorian
452 (list m (calendar-last-day-of-month m y) y)))))
453 (abs-h (calendar-absolute-from-hebrew (list 9 25 h-y))))
454 (filter-visible-calendar-holidays
455 (list
456 (list (calendar-gregorian-from-absolute (1- abs-h))
457 "Erev Hanukkah")
458 (list (calendar-gregorian-from-absolute abs-h)
459 "Hanukkah (first day)")
460 (list (calendar-gregorian-from-absolute (1+ abs-h))
461 "Hanukkah (second day)")
462 (list (calendar-gregorian-from-absolute (+ abs-h 2))
463 "Hanukkah (third day)")
464 (list (calendar-gregorian-from-absolute (+ abs-h 3))
465 "Hanukkah (fourth day)")
466 (list (calendar-gregorian-from-absolute (+ abs-h 4))
467 "Hanukkah (fifth day)")
468 (list (calendar-gregorian-from-absolute (+ abs-h 5))
469 "Hanukkah (sixth day)")
470 (list (calendar-gregorian-from-absolute (+ abs-h 6))
471 "Hanukkah (seventh day)")
472 (list (calendar-gregorian-from-absolute (+ abs-h 7))
473 "Hanukkah (eighth day)")))))))
474
475(defun calendar-holiday-function-passover-etc ()
476 "List of dates related to Passover, as visible in calendar window."
477 (if (< 7 displayed-month)
478 nil;; None of the dates is visible
479 (let* ((abs-p (calendar-absolute-from-hebrew
480 (list 1 15 (+ displayed-year 3760))))
481 (mandatory
482 (list
483 (list (calendar-gregorian-from-absolute abs-p)
484 "Passover")
485 (list (calendar-gregorian-from-absolute (+ abs-p 50))
486 "Shavuot")))
487 (optional
488 (list
489 (list (calendar-gregorian-from-absolute
490 (calendar-dayname-on-or-before 6 (- abs-p 43)))
491 "Shabbat Shekalim")
492 (list (calendar-gregorian-from-absolute
493 (calendar-dayname-on-or-before 6 (- abs-p 30)))
494 "Shabbat Zachor")
495 (list (calendar-gregorian-from-absolute
496 (if (= (% abs-p 7) 2) (- abs-p 33) (- abs-p 31)))
497 "Fast of Esther")
498 (list (calendar-gregorian-from-absolute (- abs-p 31))
499 "Erev Purim")
500 (list (calendar-gregorian-from-absolute (- abs-p 30))
501 "Purim")
502 (list (calendar-gregorian-from-absolute
503 (if (zerop (% abs-p 7)) (- abs-p 28) (- abs-p 29)))
504 "Shushan Purim")
505 (list (calendar-gregorian-from-absolute
506 (- (calendar-dayname-on-or-before 6 (- abs-p 14)) 7))
507 "Shabbat Parah")
508 (list (calendar-gregorian-from-absolute
509 (calendar-dayname-on-or-before 6 (- abs-p 14)))
510 "Shabbat HaHodesh")
511 (list (calendar-gregorian-from-absolute
512 (calendar-dayname-on-or-before 6 (1- abs-p)))
513 "Shabbat HaGadol")
514 (list (calendar-gregorian-from-absolute (1- abs-p))
515 "Erev Passover")
516 (list (calendar-gregorian-from-absolute (1+ abs-p))
517 "Passover (second day)")
518 (list (calendar-gregorian-from-absolute (+ abs-p 2))
519 "Hol Hamoed Passover (first day)")
520 (list (calendar-gregorian-from-absolute (+ abs-p 3))
521 "Hol Hamoed Passover (second day)")
522 (list (calendar-gregorian-from-absolute (+ abs-p 4))
523 "Hol Hamoed Passover (third day)")
524 (list (calendar-gregorian-from-absolute (+ abs-p 5))
525 "Hol Hamoed Passover (fourth day)")
526 (list (calendar-gregorian-from-absolute (+ abs-p 6))
527 "Passover (seventh day)")
528 (list (calendar-gregorian-from-absolute (+ abs-p 7))
529 "Passover (eighth day)")
530 (list (calendar-gregorian-from-absolute (+ abs-p 12))
531 "Yom HaShoah")
532 (list (calendar-gregorian-from-absolute
533 (if (zerop (% abs-p 7))
534 (+ abs-p 18)
535 (if (= (% abs-p 7) 6)
536 (+ abs-p 19)
537 (+ abs-p 20))))
538 "Yom HaAtzma'ut")
539 (list (calendar-gregorian-from-absolute (+ abs-p 33))
540 "Lag BaOmer")
541 (list (calendar-gregorian-from-absolute (+ abs-p 43))
542 "Yom Yerushalim")
543 (list (calendar-gregorian-from-absolute (+ abs-p 49))
544 "Erev Shavuot")
545 (list (calendar-gregorian-from-absolute (+ abs-p 51))
546 "Shavuot (second day)")))
547 (output-list
548 (filter-visible-calendar-holidays mandatory)))
549 (if all-hebrew-calendar-holidays
550 (setq output-list
551 (append
552 (filter-visible-calendar-holidays optional)
553 output-list)))
554 output-list)))
555
556(defun calendar-holiday-function-tisha-b-av-etc ()
557 "List of dates around Tisha B'Av, as visible in calendar window."
558 (if (or (< displayed-month 5)
559 (> displayed-month 9))
560 nil;; None of the dates is visible
561 (let* ((abs-t-a (calendar-absolute-from-hebrew
562 (list 5 9 (+ displayed-year 3760)))))
563
564 (filter-visible-calendar-holidays
565 (list
566 (list (calendar-gregorian-from-absolute
567 (if (= (% abs-t-a 7) 6) (- abs-t-a 20) (- abs-t-a 21)))
568 "Tzom Tammuz")
569 (list (calendar-gregorian-from-absolute
570 (calendar-dayname-on-or-before 6 abs-t-a))
571 "Shabbat Hazon")
572 (list (calendar-gregorian-from-absolute
573 (if (= (% abs-t-a 7) 6) (1+ abs-t-a) abs-t-a))
574 "Tisha B'Av")
575 (list (calendar-gregorian-from-absolute
576 (calendar-dayname-on-or-before 6 (+ abs-t-a 7)))
577 "Shabbat Nahamu"))))))
578
579(defun filter-visible-calendar-holidays (l)
580 "Return a list of all visible holidays of those on L."
581 (let ((visible)
582 (p l))
583 (while p
584 (if (calendar-date-is-visible-p (car (car p)))
585 (setq visible (append (list (car p)) visible)))
586 (setq p (cdr p)))
587 visible))
diff --git a/lisp/diary-lib.el b/lisp/diary-lib.el
new file mode 100644
index 00000000000..26aa7f5d478
--- /dev/null
+++ b/lisp/diary-lib.el
@@ -0,0 +1,2127 @@
1;; Diary functions.
2;; Copyright (C) 1989, 1990, 1991 Free Software Foundation, Inc.
3
4;; This file is part of GNU Emacs.
5
6;; GNU Emacs is distributed in the hope that it will be useful,
7;; but WITHOUT ANY WARRANTY. No author or distributor
8;; accepts responsibility to anyone for the consequences of using it
9;; or for whether it serves any particular purpose or works at all,
10;; unless he says so in writing. Refer to the GNU Emacs General Public
11;; License for full details.
12
13;; Everyone is granted permission to copy, modify and redistribute
14;; GNU Emacs, but only under the conditions described in the
15;; GNU Emacs General Public License. A copy of this license is
16;; supposed to have been given to you along with GNU Emacs so you
17;; can know your rights and responsibilities. It should be in a
18;; file named COPYING. Among other things, the copyright notice
19;; and this notice must be preserved on all copies.
20
21;; This collection of functions implements the diary features as described
22;; in calendar.el.
23
24;; Comments, corrections, and improvements should be sent to
25;; Edward M. Reingold Department of Computer Science
26;; (217) 333-6733 University of Illinois at Urbana-Champaign
27;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
28;; Urbana, Illinois 61801
29
30(require 'calendar)
31(provide 'diary)
32
33(defun diary (&optional arg)
34 "Generate the diary window for ARG days starting with the current date.
35If no argument is provided, the number of days of diary entries is governed
36by the variable `number-of-diary-entries'. This function is suitable for
37execution in a .emacs file."
38 (interactive "P")
39 (let ((d-file (substitute-in-file-name diary-file))
40 (date (calendar-current-date)))
41 (if (and d-file (file-exists-p d-file))
42 (if (file-readable-p d-file)
43 (list-diary-entries
44 date
45 (cond
46 (arg (prefix-numeric-value arg))
47 ((vectorp number-of-diary-entries)
48 (aref number-of-diary-entries (calendar-day-of-week date)))
49 (t number-of-diary-entries)))
50 (error "Your diary file is not readable!"))
51 (error "You don't have a diary file!"))))
52
53(defun view-diary-entries (arg)
54 "Prepare and display a buffer with diary entries.
55Searches the file diary-file for entries that match ARG days starting with
56the date indicated by the cursor position in the displayed three-month
57calendar."
58 (interactive "p")
59 (let ((d-file (substitute-in-file-name diary-file)))
60 (if (and d-file (file-exists-p d-file))
61 (if (file-readable-p d-file)
62 (list-diary-entries (or (calendar-cursor-to-date)
63 (error "Cursor is not on a date!"))
64 arg)
65 (error "Your diary file is not readable!"))
66 (error "You don't have a diary file!"))))
67
68(autoload 'check-calendar-holidays "holidays"
69 "Check the list of holidays for any that occur on DATE.
70The value returned is a list of strings of relevant holiday descriptions.
71The holidays are those in the list calendar-holidays.")
72
73(autoload 'calendar-holiday-list "holidays"
74 "Form the list of holidays that occur on dates in the calendar window.
75The holidays are those in the list calendar-holidays.")
76
77(defvar diary-syntax-table
78 (standard-syntax-table)
79 "The syntax table used when parsing dates in the diary file.
80It is the standard syntax table used in Fundamental mode, but with the
81syntax of `*' changed to be a word constituent.")
82
83(modify-syntax-entry ?* "w" diary-syntax-table)
84
85(defun list-diary-entries (date number)
86 "Create and display a buffer containing the relevant lines in diary-file.
87All lines that apply to DATE and the next NUMBER-1 days are included.
88
89Makes all diary entries in the diary file invisible (using selective display),
90*except* those that are relevant.
91
92Returns a list of all relevant diary entries found, if any, in order by date.
93The list entries have the form ((month day year) string). If the variable
94`diary-list-include-blanks' is t, this list will include a dummy diary entry
95\(consisting of the empty string\) for a date with no diary entries.
96
97After the list is prepared, the hooks `nongregorian-diary-listing-hook',
98`list-diary-entries-hook', and `diary-display-hook' are run. These hooks
99have the following distinct roles:
100
101 `nongregorian-diary-listing-hook' can cull dates from the diary
102 and each included file. Usually used for Hebrew or Islamic
103 diary entries in files. Applied to *each* file.
104
105 `list-diary-entries-hook' adds or manipulates diary entries from
106 external sources. Used, for example, to include diary entries
107 from other files or to sort the diary entries. Invoked *once* only.
108
109 `diary-display-hook' does the actual display of information. Could be
110 used also for an appointment notification function."
111
112 (if (< 0 number)
113 (let* ((original-date date);; save for possible use in the hooks
114 (old-diary-syntax-table)
115 (diary-entries-list)
116 (date-string (calendar-date-string date))
117 (d-file (substitute-in-file-name diary-file)))
118 (message "Preparing diary...")
119 (save-excursion
120 (let ((diary-buffer (get-file-buffer d-file)))
121 (set-buffer (if diary-buffer
122 diary-buffer
123 (find-file-noselect d-file t))))
124 (setq selective-display t)
125 (setq selective-display-ellipses nil)
126 (setq old-diary-syntax-table (syntax-table))
127 (set-syntax-table diary-syntax-table)
128 (unwind-protect
129 (let ((buffer-read-only nil)
130 (diary-modified (buffer-modified-p))
131 (mark (regexp-quote diary-nonmarking-symbol)))
132 (goto-char (1- (point-max)))
133 (if (not (looking-at "\^M\\|\n"))
134 (progn
135 (forward-char 1)
136 (insert-string "\^M")))
137 (goto-char (point-min))
138 (if (not (looking-at "\^M\\|\n"))
139 (insert-string "\^M"))
140 (subst-char-in-region (point-min) (point-max) ?\n ?\^M t)
141 (calendar-for-loop i from 1 to number do
142 (let ((d diary-date-forms)
143 (month (extract-calendar-month date))
144 (day (extract-calendar-day date))
145 (year (extract-calendar-year date))
146 (entry-found (list-sexp-diary-entries date)))
147 (while d
148 (let*
149 ((date-form (if (equal (car (car d)) 'backup)
150 (cdr (car d))
151 (car d)))
152 (backup (equal (car (car d)) 'backup))
153 (dayname
154 (concat
155 (calendar-day-name date) "\\|"
156 (substring (calendar-day-name date) 0 3) ".?"))
157 (monthname
158 (concat
159 "\\*\\|"
160 (calendar-month-name month) "\\|"
161 (substring (calendar-month-name month) 0 3) ".?"))
162 (month (concat "\\*\\|0*" (int-to-string month)))
163 (day (concat "\\*\\|0*" (int-to-string day)))
164 (year
165 (concat
166 "\\*\\|0*" (int-to-string year)
167 (if abbreviated-calendar-year
168 (concat "\\|" (int-to-string (% year 100)))
169 "")))
170 (regexp
171 (concat
172 "\\(\\`\\|\^M\\|\n\\)" mark "?\\("
173 (mapconcat 'eval date-form "\\)\\(")
174 "\\)"))
175 (case-fold-search t))
176 (goto-char (point-min))
177 (while (re-search-forward regexp nil t)
178 (if backup (re-search-backward "\\<" nil t))
179 (if (and (or (char-equal (preceding-char) ?\^M)
180 (char-equal (preceding-char) ?\n))
181 (not (looking-at " \\|\^I")))
182 ;; Diary entry that consists only of date.
183 (backward-char 1)
184 ;; Found a nonempty diary entry--make it visible and
185 ;; add it to the list.
186 (setq entry-found t)
187 (let ((entry-start (point))
188 (date-start))
189 (re-search-backward "\^M\\|\n\\|\\`")
190 (setq date-start (point))
191 (re-search-forward "\^M\\|\n" nil t 2)
192 (while (looking-at " \\|\^I")
193 (re-search-forward "\^M\\|\n" nil t))
194 (backward-char 1)
195 (subst-char-in-region date-start
196 (point) ?\^M ?\n t)
197 (add-to-diary-list
198 date (buffer-substring entry-start (point)))))))
199 (setq d (cdr d)))
200 (or entry-found
201 (not diary-list-include-blanks)
202 (setq diary-entries-list
203 (append diary-entries-list
204 (list (list date "")))))
205 (setq date
206 (calendar-gregorian-from-absolute
207 (1+ (calendar-absolute-from-gregorian date))))
208 (setq entry-found nil)))
209 (set-buffer-modified-p diary-modified))
210 (set-syntax-table old-diary-syntax-table))
211 (goto-char (point-min))
212 (run-hooks 'nongregorian-diary-listing-hook
213 'list-diary-entries-hook
214 'diary-display-hook)
215 diary-entries-list))))
216
217(defun include-other-diary-files ()
218 "Include the diary entries from other diary files with those of diary-file.
219This function is suitable for use just before fancy-diary-display as the
220list-diary-entries-hook; it enables you to use shared diary files together
221with your own. The files included are specified in the diary-file by lines of
222the form
223 #include \"filename\"
224This is recursive; that is, #include directives in diary files thus included
225are obeyed. You can change the \"#include\" to some other string by
226changing the variable `diary-include-string'."
227 (goto-char (point-min))
228 (while (re-search-forward
229 (concat
230 "\\(\\`\\|\^M\\|\n\\)"
231 (regexp-quote diary-include-string)
232 " \"\\([^\"]*\\)\"")
233 nil t)
234 (let ((diary-file (substitute-in-file-name
235 (buffer-substring (match-beginning 2) (match-end 2))))
236 (diary-list-include-blanks nil)
237 (list-diary-entries-hook 'include-other-diary-files)
238 (diary-display-hook nil))
239 (if (file-exists-p diary-file)
240 (if (file-readable-p diary-file)
241 (unwind-protect
242 (setq diary-entries-list
243 (append diary-entries-list
244 (list-diary-entries original-date number)))
245 (kill-buffer (get-file-buffer diary-file)))
246 (beep)
247 (message "Can't read included diary file %s" diary-file)
248 (sleep-for 2))
249 (beep)
250 (message "Can't find included diary file %s" diary-file)
251 (sleep-for 2))))
252 (goto-char (point-min)))
253
254(defun simple-diary-display ()
255 "Display the diary buffer if there are any relevant entries or holidays."
256 (let* ((holiday-list (if holidays-in-diary-buffer
257 (check-calendar-holidays original-date)))
258 (msg (format "No diary entries for %s %s"
259 (concat date-string (if holiday-list ":" ""))
260 (mapconcat 'identity holiday-list "; "))))
261 (if (or (not diary-entries-list)
262 (and (not (cdr diary-entries-list))
263 (string-equal (car (cdr (car diary-entries-list))) "")))
264 (if (<= (length msg) (screen-width))
265 (message msg)
266 (set-buffer (get-buffer-create holiday-buffer))
267 (setq buffer-read-only nil)
268 (setq mode-line-format
269 (format "--------------------------%s%%-" date-string))
270 (erase-buffer)
271 (insert (mapconcat 'identity holiday-list "\n"))
272 (goto-char (point-min))
273 (set-buffer-modified-p nil)
274 (setq buffer-read-only t)
275 (display-buffer holiday-buffer)
276 (message "No diary entries for %s" date-string))
277 (setq mode-line-format
278 (format "%%*--%sDiary %s %s%s%s%%-"
279 (if holiday-list "" "---------------")
280 (if holiday-list "for" "entries for")
281 date-string
282 (if holiday-list ": " "")
283 (mapconcat 'identity holiday-list "; ")))
284 (display-buffer (get-file-buffer d-file))
285 (message "Preparing diary...done"))))
286
287(defun fancy-diary-display ()
288 "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
289This function is provided for optional use as the `list-diary-entries-hook'."
290 (if (or (not diary-entries-list)
291 (and (not (cdr diary-entries-list))
292 (string-equal (car (cdr (car diary-entries-list))) "")))
293 (let* ((holiday-list (if holidays-in-diary-buffer
294 (check-calendar-holidays original-date)))
295 (msg (format "No diary entries for %s %s"
296 (concat date-string (if holiday-list ":" ""))
297 (mapconcat 'identity holiday-list "; "))))
298 (if (<= (length msg) (screen-width))
299 (message msg)
300 (set-buffer (get-buffer-create holiday-buffer))
301 (setq buffer-read-only nil)
302 (setq mode-line-format
303 (format "--------------------------%s%%-" date-string))
304 (erase-buffer)
305 (insert (mapconcat 'identity holiday-list "\n"))
306 (goto-char (point-min))
307 (set-buffer-modified-p nil)
308 (setq buffer-read-only t)
309 (display-buffer holiday-buffer)
310 (message "No diary entries for %s" date-string)))
311 (save-excursion;; Turn off selective-display in the diary file's buffer.
312 (set-buffer (get-file-buffer (substitute-in-file-name diary-file)))
313 (let ((diary-modified (buffer-modified-p)))
314 (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
315 (setq selective-display nil)
316 (kill-local-variable 'mode-line-format)
317 (set-buffer-modified-p diary-modified)))
318 (save-excursion;; Prepare the fancy diary buffer.
319 (set-buffer (get-buffer-create fancy-diary-buffer))
320 (setq buffer-read-only nil)
321 (make-local-variable 'mode-line-format)
322 (setq mode-line-format "---------------------------Diary Entries%-")
323 (erase-buffer)
324 (let ((entry-list diary-entries-list)
325 (holiday-list)
326 (holiday-list-last-month 1)
327 (holiday-list-last-year 1)
328 (date (list 0 0 0)))
329 (while entry-list
330 (if (not (calendar-date-equal date (car (car entry-list))))
331 (progn
332 (setq date (car (car entry-list)))
333 (and holidays-in-diary-buffer
334 (calendar-date-compare
335 (list (list holiday-list-last-month
336 (calendar-last-day-of-month
337 holiday-list-last-month
338 holiday-list-last-year)
339 holiday-list-last-year))
340 (list date))
341 ;; We need to get the holidays for the next 3 months.
342 (setq holiday-list-last-month
343 (extract-calendar-month date))
344 (setq holiday-list-last-year
345 (extract-calendar-year date))
346 (increment-calendar-month
347 holiday-list-last-month holiday-list-last-year 1)
348 (setq holiday-list
349 (let ((displayed-month holiday-list-last-month)
350 (displayed-year holiday-list-last-year))
351 (calendar-holiday-list)))
352 (increment-calendar-month
353 holiday-list-last-month holiday-list-last-year 1))
354 (let* ((date-string (calendar-date-string date))
355 (date-holiday-list
356 (let ((h holiday-list)
357 (d))
358 ;; Make a list of all holidays for date.
359 (while h
360 (if (calendar-date-equal date (car (car h)))
361 (setq d (append d (cdr (car h)))))
362 (setq h (cdr h)))
363 d)))
364 (insert (if (= (point) (point-min)) "" ?\n) date-string)
365 (if date-holiday-list (insert ": "))
366 (let ((l (current-column)))
367 (insert (mapconcat 'identity date-holiday-list
368 (concat "\n" (make-string l ? )))))
369 (let ((l (current-column)))
370 (insert ?\n (make-string l ?=) ?\n)))))
371 (if (< 0 (length (car (cdr (car entry-list)))))
372 (insert (car (cdr (car entry-list))) ?\n))
373 (setq entry-list (cdr entry-list))))
374 (set-buffer-modified-p nil)
375 (goto-char (point-min))
376 (setq buffer-read-only t)
377 (display-buffer fancy-diary-buffer)
378 (message "Preparing diary...done"))))
379
380(defun print-diary-entries ()
381 "Print a hard copy of the entries visible in the diary window.
382The hooks given by the variable `print-diary-entries-hook' are called after
383the temporary buffer of visible diary entries is prepared; it is the hooks
384that do the actual printing and kill the buffer."
385 (interactive)
386 (let ((diary-buffer (get-file-buffer (substitute-in-file-name diary-file))))
387 (if diary-buffer
388 (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*")))
389 (save-excursion
390 (set-buffer diary-buffer)
391 (copy-to-buffer temp-buffer (point-min) (point-max))
392 (set-buffer temp-buffer)
393 (while (re-search-forward "\^M.*$" nil t)
394 (replace-match ""))
395 (run-hooks 'print-diary-entries-hook)))
396 (error "You don't have a diary buffer!"))))
397
398(defun add-diary-heading ()
399 "Add a heading to the diary entries for printing.
400The heading is formed from the mode line of the diary buffer. This function
401is used in the default value of the variable `print-diary-entry-hooks'."
402 (save-excursion
403 (let ((heading))
404 (set-buffer diary-buffer)
405 (setq heading mode-line-format)
406 (string-match "%\\*-*\\([^-].*\\)%-$" heading)
407 (setq heading
408 (substring heading (match-beginning 1) (match-end 1)))
409 (set-buffer temp-buffer)
410 (goto-char (point-min))
411 (insert heading "\n"
412 (make-string (length heading) ?=) "\n"))))
413
414(defun show-all-diary-entries ()
415 "Show all of the diary entries in the diary-file.
416This function gets rid of the selective display of the diary-file so that
417all entries, not just some, are visible. If there is no diary buffer, one
418is created."
419 (interactive)
420 (let ((d-file (substitute-in-file-name diary-file)))
421 (if (and d-file (file-exists-p d-file))
422 (if (file-readable-p d-file)
423 (save-excursion
424 (let ((diary-buffer (get-file-buffer d-file)))
425 (set-buffer (if diary-buffer
426 diary-buffer
427 (find-file-noselect d-file t)))
428 (let ((buffer-read-only nil)
429 (diary-modified (buffer-modified-p)))
430 (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
431 (setq selective-display nil)
432 (make-local-variable 'mode-line-format)
433 (setq mode-line-format
434 "%*---------------------------All Diary Entries%-")
435 (display-buffer (current-buffer))
436 (set-buffer-modified-p diary-modified))))
437 (error "Your diary file is not readable!"))
438 (error "You don't have a diary file!"))))
439
440(defun diary-name-pattern (string-array &optional fullname)
441 "Convert an STRING-ARRAY, an array of strings to a pattern.
442The pattern will match any of the strings, either entirely or abbreviated
443to three characters. An abbreviated form will match with or without a period;
444If the optional FULLNAME is t, abbreviations will not match, just the full
445name."
446 (let ((pattern ""))
447 (calendar-for-loop i from 0 to (1- (length string-array)) do
448 (setq pattern
449 (concat
450 pattern
451 (if (string-equal pattern "") "" "\\|")
452 (aref string-array i)
453 (if fullname
454 ""
455 (concat
456 "\\|"
457 (substring (aref string-array i) 0 3) ".?")))))
458 pattern))
459
460(defun mark-diary-entries ()
461 "Mark days in the calendar window that have diary entries.
462Each entry in diary-file visible in the calendar window is marked. After the
463entries are marked, the hooks `nongregorian-diary-marking-hook' and
464`mark-diary-entries-hook' are run."
465 (interactive)
466 (setq mark-diary-entries-in-calendar t)
467 (let ((d-file (substitute-in-file-name diary-file)))
468 (if (and d-file (file-exists-p d-file))
469 (if (file-readable-p d-file)
470 (save-excursion
471 (message "Marking diary entries...")
472 (set-buffer (find-file-noselect d-file t))
473 (let ((d diary-date-forms)
474 (old-diary-syntax-table))
475 (setq old-diary-syntax-table (syntax-table))
476 (set-syntax-table diary-syntax-table)
477 (while d
478 (let*
479 ((date-form (if (equal (car (car d)) 'backup)
480 (cdr (car d))
481 (car d)));; ignore 'backup directive
482 (dayname (diary-name-pattern calendar-day-name-array))
483 (monthname
484 (concat
485 (diary-name-pattern calendar-month-name-array)
486 "\\|\\*"))
487 (month "[0-9]+\\|\\*")
488 (day "[0-9]+\\|\\*")
489 (year "[0-9]+\\|\\*")
490 (l (length date-form))
491 (d-name-pos (- l (length (memq 'dayname date-form))))
492 (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
493 (m-name-pos (- l (length (memq 'monthname date-form))))
494 (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
495 (d-pos (- l (length (memq 'day date-form))))
496 (d-pos (if (/= l d-pos) (+ 2 d-pos)))
497 (m-pos (- l (length (memq 'month date-form))))
498 (m-pos (if (/= l m-pos) (+ 2 m-pos)))
499 (y-pos (- l (length (memq 'year date-form))))
500 (y-pos (if (/= l y-pos) (+ 2 y-pos)))
501 (regexp
502 (concat
503 "\\(\\`\\|\^M\\|\n\\)\\("
504 (mapconcat 'eval date-form "\\)\\(")
505 "\\)"))
506 (case-fold-search t))
507 (goto-char (point-min))
508 (while (re-search-forward regexp nil t)
509 (let* ((dd-name
510 (if d-name-pos
511 (buffer-substring
512 (match-beginning d-name-pos)
513 (match-end d-name-pos))))
514 (mm-name
515 (if m-name-pos
516 (buffer-substring
517 (match-beginning m-name-pos)
518 (match-end m-name-pos))))
519 (mm (string-to-int
520 (if m-pos
521 (buffer-substring
522 (match-beginning m-pos)
523 (match-end m-pos))
524 "")))
525 (dd (string-to-int
526 (if d-pos
527 (buffer-substring
528 (match-beginning d-pos)
529 (match-end d-pos))
530 "")))
531 (y-str (if y-pos
532 (buffer-substring
533 (match-beginning y-pos)
534 (match-end y-pos))))
535 (yy (if (not y-str)
536 0
537 (if (and (= (length y-str) 2)
538 abbreviated-calendar-year)
539 (let* ((current-y
540 (extract-calendar-year
541 (calendar-current-date)))
542 (y (+ (string-to-int y-str)
543 (* 100
544 (/ current-y 100)))))
545 (if (> (- y current-y) 50)
546 (- y 100)
547 (if (> (- current-y y) 50)
548 (+ y 100)
549 y)))
550 (string-to-int y-str)))))
551 (if dd-name
552 (mark-calendar-days-named
553 (cdr (assoc (capitalize (substring dd-name 0 3))
554 (calendar-make-alist
555 calendar-day-name-array
556 0
557 '(lambda (x) (substring x 0 3))))))
558 (if mm-name
559 (if (string-equal mm-name "*")
560 (setq mm 0)
561 (setq mm
562 (cdr (assoc
563 (capitalize
564 (substring mm-name 0 3))
565 (calendar-make-alist
566 calendar-month-name-array
567 1
568 '(lambda (x) (substring x 0 3)))
569 )))))
570 (mark-calendar-date-pattern mm dd yy))))
571 (setq d (cdr d))))
572 (mark-sexp-diary-entries)
573 (run-hooks 'nongregorian-diary-marking-hook
574 'mark-diary-entries-hook)
575 (set-syntax-table old-diary-syntax-table)
576 (message "Marking diary entries...done")))
577 (error "Your diary file is not readable!"))
578 (error "You don't have a diary file!"))))
579
580(defun mark-sexp-diary-entries ()
581 "Mark days in the calendar window that have sexp diary entries.
582Each entry in diary-file (or included files) visible in the calendar window
583is marked. See the documentation for the function `list-sexp-diary-entries'."
584 (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
585 (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" sexp-mark "("))
586 (m)
587 (y)
588 (first-date)
589 (last-date))
590 (save-excursion
591 (set-buffer calendar-buffer)
592 (setq m displayed-month)
593 (setq y displayed-year))
594 (increment-calendar-month m y -1)
595 (setq first-date
596 (calendar-absolute-from-gregorian (list m 1 y)))
597 (increment-calendar-month m y 2)
598 (setq last-date
599 (calendar-absolute-from-gregorian
600 (list m (calendar-last-day-of-month m y) y)))
601 (goto-char (point-min))
602 (while (re-search-forward s-entry nil t)
603 (backward-char 1)
604 (let ((sexp-start (point))
605 (sexp)
606 (entry)
607 (entry-start)
608 (line-start))
609 (forward-sexp)
610 (setq sexp (buffer-substring sexp-start (point)))
611 (save-excursion
612 (re-search-backward "\^M\\|\n\\|\\`")
613 (setq line-start (point)))
614 (forward-char 1)
615 (if (and (or (char-equal (preceding-char) ?\^M)
616 (char-equal (preceding-char) ?\n))
617 (not (looking-at " \\|\^I")))
618 (progn;; Diary entry consists only of the sexp
619 (backward-char 1)
620 (setq entry ""))
621 (setq entry-start (point))
622 (re-search-forward "\^M\\|\n" nil t)
623 (while (looking-at " \\|\^I")
624 (re-search-forward "\^M\\|\n" nil t))
625 (backward-char 1)
626 (setq entry (buffer-substring entry-start (point)))
627 (while (string-match "[\^M]" entry)
628 (aset entry (match-beginning 0) ?\n )))
629 (calendar-for-loop date from first-date to last-date do
630 (if (diary-sexp-entry sexp entry
631 (calendar-gregorian-from-absolute date))
632 (mark-visible-calendar-date
633 (calendar-gregorian-from-absolute date))))))))
634
635(defun mark-included-diary-files ()
636 "Mark the diary entries from other diary files with those of diary-file.
637This function is suitable for use as the mark-diary-entries-hook; it enables
638you to use shared diary files together with your own. The files included are
639specified in the diary-file by lines of the form
640 #include \"filename\"
641This is recursive; that is, #include directives in diary files thus included
642are obeyed. You can change the \"#include\" to some other string by
643changing the variable `diary-include-string'."
644 (goto-char (point-min))
645 (while (re-search-forward
646 (concat
647 "\\(\\`\\|\^M\\|\n\\)"
648 (regexp-quote diary-include-string)
649 " \"\\([^\"]*\\)\"")
650 nil t)
651 (let ((diary-file (substitute-in-file-name
652 (buffer-substring (match-beginning 2) (match-end 2))))
653 (mark-diary-entries-hook 'mark-included-diary-files))
654 (if (file-exists-p diary-file)
655 (if (file-readable-p diary-file)
656 (progn
657 (mark-diary-entries)
658 (kill-buffer (get-file-buffer diary-file)))
659 (beep)
660 (message "Can't read included diary file %s" diary-file)
661 (sleep-for 2))
662 (beep)
663 (message "Can't find included diary file %s" diary-file)
664 (sleep-for 2))))
665 (goto-char (point-min)))
666
667(defun mark-calendar-days-named (dayname)
668 "Mark all dates in the calendar window that are day DAYNAME of the week.
6690 means all Sundays, 1 means all Mondays, and so on."
670 (save-excursion
671 (set-buffer calendar-buffer)
672 (let ((prev-month displayed-month)
673 (prev-year displayed-year)
674 (succ-month displayed-month)
675 (succ-year displayed-year)
676 (last-day)
677 (day))
678 (increment-calendar-month succ-month succ-year 1)
679 (increment-calendar-month prev-month prev-year -1)
680 (setq day (calendar-absolute-from-gregorian
681 (calendar-nth-named-day 1 dayname prev-month prev-year)))
682 (setq last-day (calendar-absolute-from-gregorian
683 (calendar-nth-named-day -1 dayname succ-month succ-year)))
684 (while (<= day last-day)
685 (mark-visible-calendar-date (calendar-gregorian-from-absolute day))
686 (setq day (+ day 7))))))
687
688(defun mark-calendar-date-pattern (month day year)
689 "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
690A value of 0 in any position is a wild-card."
691 (save-excursion
692 (set-buffer calendar-buffer)
693 (let ((m displayed-month)
694 (y displayed-year))
695 (increment-calendar-month m y -1)
696 (calendar-for-loop i from 0 to 2 do
697 (mark-calendar-month m y month day year)
698 (increment-calendar-month m y 1)))))
699
700(defun mark-calendar-month (month year p-month p-day p-year)
701 "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
702A value of 0 in any position of the pattern is a wild-card."
703 (if (or (and (= month p-month)
704 (or (= p-year 0) (= year p-year)))
705 (and (= p-month 0)
706 (or (= p-year 0) (= year p-year))))
707 (if (= p-day 0)
708 (calendar-for-loop
709 i from 1 to (calendar-last-day-of-month month year) do
710 (mark-visible-calendar-date (list month i year)))
711 (mark-visible-calendar-date (list month p-day year)))))
712
713(defun diary-entry-compare (e1 e2)
714 "Returns t if E1 is earlier than E2."
715 (or (calendar-date-compare e1 e2)
716 (and (calendar-date-equal (car e1) (car e2))
717 (< (diary-entry-time (car (cdr e1)))
718 (diary-entry-time (car (cdr e2)))))))
719
720(defun diary-entry-time (s)
721 "Time at the beginning of the string S in a military-style integer.
722For example, returns 1325 for 1:25pm. Returns -9999 if no time is recognized.
723The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm,
724and XX:XXam or XX:XXpm."
725 (cond ((string-match;; Military time
726 "^ *\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s)
727 (+ (* 100 (string-to-int
728 (substring s (match-beginning 1) (match-end 1))))
729 (string-to-int (substring s (match-beginning 2) (match-end 2)))))
730 ((string-match;; Hour only XXam or XXpm
731 "^ *\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
732 (+ (* 100 (% (string-to-int
733 (substring s (match-beginning 1) (match-end 1)))
734 12))
735 (if (string-equal "a"
736 (substring s (match-beginning 2) (match-end 2)))
737 0 1200)))
738 ((string-match;; Hour and minute XX:XXam or XX:XXpm
739 "^ *\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
740 (+ (* 100 (% (string-to-int
741 (substring s (match-beginning 1) (match-end 1)))
742 12))
743 (string-to-int (substring s (match-beginning 2) (match-end 2)))
744 (if (string-equal "a"
745 (substring s (match-beginning 3) (match-end 3)))
746 0 1200)))
747 (t -9999)));; Unrecognizable
748
749(defun list-hebrew-diary-entries ()
750 "Add any Hebrew date entries from the diary-file to diary-entries-list.
751Hebrew date diary entries must be prefaced by a hebrew-diary-entry-symbol
752\(normally an `H'\). The same diary-date-forms govern the style of the Hebrew
753calendar entries, except that the Hebrew month names must be spelled in full.
754The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
755Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
756common Hebrew year. If a Hebrew date diary entry begins with a
757diary-nonmarking-symbol the entry will appear in the diary listing, but will
758not be marked in the calendar. This function is provided for use with the
759nongregorian-diary-listing-hook."
760 (if (< 0 number)
761 (let ((buffer-read-only nil)
762 (diary-modified (buffer-modified-p))
763 (gdate original-date)
764 (mark (regexp-quote diary-nonmarking-symbol)))
765 (calendar-for-loop i from 1 to number do
766 (let* ((d diary-date-forms)
767 (hdate (calendar-hebrew-from-absolute
768 (calendar-absolute-from-gregorian gdate)))
769 (month (extract-calendar-month hdate))
770 (day (extract-calendar-day hdate))
771 (year (extract-calendar-year hdate)))
772 (while d
773 (let*
774 ((date-form (if (equal (car (car d)) 'backup)
775 (cdr (car d))
776 (car d)))
777 (backup (equal (car (car d)) 'backup))
778 (dayname
779 (concat
780 (calendar-day-name gdate) "\\|"
781 (substring (calendar-day-name gdate) 0 3) ".?"))
782 (calendar-month-name-array
783 calendar-hebrew-month-name-array-leap-year)
784 (monthname
785 (concat
786 "\\*\\|"
787 (calendar-month-name month)))
788 (month (concat "\\*\\|0*" (int-to-string month)))
789 (day (concat "\\*\\|0*" (int-to-string day)))
790 (year
791 (concat
792 "\\*\\|0*" (int-to-string year)
793 (if abbreviated-calendar-year
794 (concat "\\|" (int-to-string (% year 100)))
795 "")))
796 (regexp
797 (concat
798 "\\(\\`\\|\^M\\|\n\\)" mark "?"
799 (regexp-quote hebrew-diary-entry-symbol)
800 "\\("
801 (mapconcat 'eval date-form "\\)\\(")
802 "\\)"))
803 (case-fold-search t))
804 (goto-char (point-min))
805 (while (re-search-forward regexp nil t)
806 (if backup (re-search-backward "\\<" nil t))
807 (if (and (or (char-equal (preceding-char) ?\^M)
808 (char-equal (preceding-char) ?\n))
809 (not (looking-at " \\|\^I")))
810 ;; Diary entry that consists only of date.
811 (backward-char 1)
812 ;; Found a nonempty diary entry--make it visible and
813 ;; add it to the list.
814 (let ((entry-start (point))
815 (date-start))
816 (re-search-backward "\^M\\|\n\\|\\`")
817 (setq date-start (point))
818 (re-search-forward "\^M\\|\n" nil t 2)
819 (while (looking-at " \\|\^I")
820 (re-search-forward "\^M\\|\n" nil t))
821 (backward-char 1)
822 (subst-char-in-region date-start (point) ?\^M ?\n t)
823 (add-to-diary-list
824 gdate (buffer-substring entry-start (point)))))))
825 (setq d (cdr d))))
826 (setq gdate
827 (calendar-gregorian-from-absolute
828 (1+ (calendar-absolute-from-gregorian gdate)))))
829 (set-buffer-modified-p diary-modified))
830 (goto-char (point-min))))
831
832(defun mark-hebrew-diary-entries ()
833 "Mark days in the calendar window that have Hebrew date diary entries.
834Each entry in diary-file (or included files) visible in the calendar window
835is marked. Hebrew date entries are prefaced by a hebrew-diary-entry-symbol
836\(normally an `H'\). The same diary-date-forms govern the style of the Hebrew
837calendar entries, except that the Hebrew month names must be spelled in full.
838The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
839Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
840common Hebrew year. Hebrew date diary entries that begin with a
841diary-nonmarking symbol will not be marked in the calendar. This function
842is provided for use as part of the nongregorian-diary-marking-hook."
843 (let ((d diary-date-forms))
844 (while d
845 (let*
846 ((date-form (if (equal (car (car d)) 'backup)
847 (cdr (car d))
848 (car d)));; ignore 'backup directive
849 (dayname (diary-name-pattern calendar-day-name-array))
850 (monthname
851 (concat
852 (diary-name-pattern calendar-hebrew-month-name-array-leap-year t)
853 "\\|\\*"))
854 (month "[0-9]+\\|\\*")
855 (day "[0-9]+\\|\\*")
856 (year "[0-9]+\\|\\*")
857 (l (length date-form))
858 (d-name-pos (- l (length (memq 'dayname date-form))))
859 (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
860 (m-name-pos (- l (length (memq 'monthname date-form))))
861 (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
862 (d-pos (- l (length (memq 'day date-form))))
863 (d-pos (if (/= l d-pos) (+ 2 d-pos)))
864 (m-pos (- l (length (memq 'month date-form))))
865 (m-pos (if (/= l m-pos) (+ 2 m-pos)))
866 (y-pos (- l (length (memq 'year date-form))))
867 (y-pos (if (/= l y-pos) (+ 2 y-pos)))
868 (regexp
869 (concat
870 "\\(\\`\\|\^M\\|\n\\)"
871 (regexp-quote hebrew-diary-entry-symbol)
872 "\\("
873 (mapconcat 'eval date-form "\\)\\(")
874 "\\)"))
875 (case-fold-search t))
876 (goto-char (point-min))
877 (while (re-search-forward regexp nil t)
878 (let* ((dd-name
879 (if d-name-pos
880 (buffer-substring
881 (match-beginning d-name-pos)
882 (match-end d-name-pos))))
883 (mm-name
884 (if m-name-pos
885 (buffer-substring
886 (match-beginning m-name-pos)
887 (match-end m-name-pos))))
888 (mm (string-to-int
889 (if m-pos
890 (buffer-substring
891 (match-beginning m-pos)
892 (match-end m-pos))
893 "")))
894 (dd (string-to-int
895 (if d-pos
896 (buffer-substring
897 (match-beginning d-pos)
898 (match-end d-pos))
899 "")))
900 (y-str (if y-pos
901 (buffer-substring
902 (match-beginning y-pos)
903 (match-end y-pos))))
904 (yy (if (not y-str)
905 0
906 (if (and (= (length y-str) 2)
907 abbreviated-calendar-year)
908 (let* ((current-y
909 (extract-calendar-year
910 (calendar-hebrew-from-absolute
911 (calendar-absolute-from-gregorian
912 (calendar-current-date)))))
913 (y (+ (string-to-int y-str)
914 (* 100 (/ current-y 100)))))
915 (if (> (- y current-y) 50)
916 (- y 100)
917 (if (> (- current-y y) 50)
918 (+ y 100)
919 y)))
920 (string-to-int y-str)))))
921 (if dd-name
922 (mark-calendar-days-named
923 (cdr (assoc (capitalize (substring dd-name 0 3))
924 (calendar-make-alist
925 calendar-day-name-array
926 0
927 '(lambda (x) (substring x 0 3))))))
928 (if mm-name
929 (if (string-equal mm-name "*")
930 (setq mm 0)
931 (setq
932 mm
933 (cdr
934 (assoc
935 (capitalize mm-name)
936 (calendar-make-alist
937 calendar-hebrew-month-name-array-leap-year))))))
938 (mark-hebrew-calendar-date-pattern mm dd yy)))))
939 (setq d (cdr d)))))
940
941(defun mark-hebrew-calendar-date-pattern (month day year)
942 "Mark all dates in the calendar window that conform to the Hebrew date
943MONTH/DAY/YEAR. A value of 0 in any position is a wild-card."
944 (save-excursion
945 (set-buffer calendar-buffer)
946 (if (and (/= 0 month) (/= 0 day))
947 (if (/= 0 year)
948 ;; Fully specified Hebrew date.
949 (let ((date (calendar-gregorian-from-absolute
950 (calendar-absolute-from-hebrew
951 (list month day year)))))
952 (if (calendar-date-is-visible-p date)
953 (mark-visible-calendar-date date)))
954 ;; Month and day in any year--this taken from the holiday stuff.
955 (if (memq displayed-month;; This test is only to speed things up a
956 (list ;; bit; it works fine without the test too.
957 (if (< 11 month) (- month 11) (+ month 1))
958 (if (< 10 month) (- month 10) (+ month 2))
959 (if (< 9 month) (- month 9) (+ month 3))
960 (if (< 8 month) (- month 8) (+ month 4))
961 (if (< 7 month) (- month 7) (+ month 5))))
962 (let ((m1 displayed-month)
963 (y1 displayed-year)
964 (m2 displayed-month)
965 (y2 displayed-year)
966 (year))
967 (increment-calendar-month m1 y1 -1)
968 (increment-calendar-month m2 y2 1)
969 (let* ((start-date (calendar-absolute-from-gregorian
970 (list m1 1 y1)))
971 (end-date (calendar-absolute-from-gregorian
972 (list m2
973 (calendar-last-day-of-month m2 y2)
974 y2)))
975 (hebrew-start
976 (calendar-hebrew-from-absolute start-date))
977 (hebrew-end (calendar-hebrew-from-absolute end-date))
978 (hebrew-y1 (extract-calendar-year hebrew-start))
979 (hebrew-y2 (extract-calendar-year hebrew-end)))
980 (setq year (if (< 6 month) hebrew-y2 hebrew-y1))
981 (let ((date (calendar-gregorian-from-absolute
982 (calendar-absolute-from-hebrew
983 (list month day year)))))
984 (if (calendar-date-is-visible-p date)
985 (mark-visible-calendar-date date)))))))
986 ;; Not one of the simple cases--check all visible dates for match.
987 ;; Actually, the following code takes care of ALL of the cases, but
988 ;; it's much too slow to be used for the simple (common) cases.
989 (let ((m displayed-month)
990 (y displayed-year)
991 (first-date)
992 (last-date))
993 (increment-calendar-month m y -1)
994 (setq first-date
995 (calendar-absolute-from-gregorian
996 (list m 1 y)))
997 (increment-calendar-month m y 2)
998 (setq last-date
999 (calendar-absolute-from-gregorian
1000 (list m (calendar-last-day-of-month m y) y)))
1001 (calendar-for-loop date from first-date to last-date do
1002 (let* ((h-date (calendar-hebrew-from-absolute date))
1003 (h-month (extract-calendar-month h-date))
1004 (h-day (extract-calendar-day h-date))
1005 (h-year (extract-calendar-year h-date)))
1006 (and (or (zerop month)
1007 (= month h-month))
1008 (or (zerop day)
1009 (= day h-day))
1010 (or (zerop year)
1011 (= year h-year))
1012 (mark-visible-calendar-date
1013 (calendar-gregorian-from-absolute date)))))))))
1014
1015(defun list-sexp-diary-entries (date)
1016 "Add any sexp entries for DATE from the diary-file to diary-entries-list
1017and make them visible in the diary file. Returns t if any entries were found.
1018
1019Sexp diary entries must be prefaced by a sexp-diary-entry-symbol (normally
1020`%%'). The form of a sexp diary entry is
1021
1022 %%(SEXP) ENTRY
1023
1024Both ENTRY and DATE are globally available when the SEXP is evaluated. If the
1025SEXP yields the value nil, the diary entry does not apply. If it yields a
1026non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a
1027string, that string will be the diary entry in the fancy diary display.
1028
1029For example, the following diary entry will apply to the 21st of the month
1030if it is a weekday and the Friday before if the 21st is on a weekend:
1031
1032 &%%(let ((dayname (calendar-day-of-week date))
1033 (day (extract-calendar-day date)))
1034 (or
1035 (and (= day 21) (memq dayname '(1 2 3 4 5)))
1036 (and (memq day '(19 20)) (= dayname 5)))
1037 ) UIUC pay checks deposited
1038
1039A number of built-in functions are available for this type of diary entry:
1040
1041 %%(diary-float MONTH DAYNAME N) text
1042 Entry will appear on the Nth DAYNAME of MONTH.
1043 (DAYNAME=0 means Sunday, 1 means Monday, and so on;
1044 if N is negative it counts backward from the end of
1045 the month. MONTH can be a list of months, a single
1046 month, or t to specify all months.
1047
1048 %%(diary-block M1 D1 Y1 M2 D2 Y2) text
1049 Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,
1050 inclusive. (If `european-calendar-style' is t, the
1051 order of the parameters should be changed to D1, M1, Y1,
1052 D2, M2, Y2.)
1053
1054 %%(diary-anniversary MONTH DAY YEAR) text
1055 Entry will appear on anniversary dates of MONTH DAY, YEAR.
1056 (If `european-calendar-style' is t, the order of the
1057 parameters should be changed to DAY, MONTH, YEAR.) Text
1058 can contain %d or %d%s; %d will be replaced by the number
1059 of years since the MONTH DAY, YEAR and %s will be replaced
1060 by the ordinal ending of that number (that is, `st', `nd',
1061 `rd' or `th', as appropriate. The anniversary of February
1062 29 is considered to be March 1 in a non-leap year.
1063
1064 %%(diary-cyclic N MONTH DAY YEAR) text
1065 Entry will appear every N days, starting MONTH DAY, YEAR.
1066 (If `european-calendar-style' is t, the order of the
1067 parameters should be changed to N, DAY, MONTH, YEAR.) Text
1068 can contain %d or %d%s; %d will be replaced by the number
1069 of repetitions since the MONTH DAY, YEAR and %s will
1070 be replaced by the ordinal ending of that number (that is,
1071 `st', `nd', `rd' or `th', as appropriate.
1072
1073 %%(diary-day-of-year)
1074 Diary entries giving the day of the year and the number of
1075 days remaining in the year will be made every day. Note
1076 that since there is no text, it makes sense only if the
1077 fancy diary display is used.
1078
1079 %%(diary-iso-date)
1080 Diary entries giving the corresponding ISO commercial date
1081 will be made every day. Note that since there is no text,
1082 it makes sense only if the fancy diary display is used.
1083
1084 %%(diary-french-date)
1085 Diary entries giving the corresponding French Revolutionary
1086 date will be made every day. Note that since there is no
1087 text, it makes sense only if the fancy diary display is used.
1088
1089 %%(diary-islamic-date)
1090 Diary entries giving the corresponding Islamic date will be
1091 made every day. Note that since there is no text, it
1092 makes sense only if the fancy diary display is used.
1093
1094 %%(diary-hebrew-date)
1095 Diary entries giving the corresponding Hebrew date will be
1096 made every day. Note that since there is no text, it
1097 makes sense only if the fancy diary display is used.
1098
1099 %%(diary-yahrzeit MONTH DAY YEAR) text
1100 Text is assumed to be the name of the person; the date is
1101 the date of death on the *civil* calendar. The diary entry
1102 will appear on the proper Hebrew-date anniversary and on the
1103 day before. (If `european-calendar-style' is t, the order
1104 of the parameters should be changed to DAY, MONTH, YEAR.)
1105
1106 %%(diary-rosh-hodesh)
1107 Diary entries will be made on the dates of Rosh Hodesh on
1108 the Hebrew calendar. Note that since there is no text, it
1109 makes sense only if the fancy diary display is used.
1110
1111 %%(diary-parasha)
1112 Diary entries giving the weekly parasha will be made on
1113 every Saturday. Note that since there is no text, it
1114 makes sense only if the fancy diary display is used.
1115
1116 %%(diary-omer)
1117 Diary entries giving the omer count will be made every day
1118 from Passover to Shavuoth. Note that since there is no text,
1119 it makes sense only if the fancy diary display is used.
1120
1121Marking these entries is *extremely* time consuming, so these entries are
1122best if they are nonmarking."
1123 (let* ((mark (regexp-quote diary-nonmarking-symbol))
1124 (sexp-mark (regexp-quote sexp-diary-entry-symbol))
1125 (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))
1126 (entry-found))
1127 (goto-char (point-min))
1128 (while (re-search-forward s-entry nil t)
1129 (backward-char 1)
1130 (let ((sexp-start (point))
1131 (sexp)
1132 (entry)
1133 (entry-start)
1134 (line-start))
1135 (forward-sexp)
1136 (setq sexp (buffer-substring sexp-start (point)))
1137 (save-excursion
1138 (re-search-backward "\^M\\|\n\\|\\`")
1139 (setq line-start (point)))
1140 (forward-char 1)
1141 (if (and (or (char-equal (preceding-char) ?\^M)
1142 (char-equal (preceding-char) ?\n))
1143 (not (looking-at " \\|\^I")))
1144 (progn;; Diary entry consists only of the sexp
1145 (backward-char 1)
1146 (setq entry ""))
1147 (setq entry-start (point))
1148 (re-search-forward "\^M\\|\n" nil t)
1149 (while (looking-at " \\|\^I")
1150 (re-search-forward "\^M\\|\n" nil t))
1151 (backward-char 1)
1152 (setq entry (buffer-substring entry-start (point)))
1153 (while (string-match "[\^M]" entry)
1154 (aset entry (match-beginning 0) ?\n )))
1155 (let ((diary-entry (diary-sexp-entry sexp entry date)))
1156 (if diary-entry
1157 (subst-char-in-region line-start (point) ?\^M ?\n t))
1158 (add-to-diary-list date diary-entry)
1159 (setq entry-found (or entry-found diary-entry)))))
1160 entry-found))
1161
1162(defun diary-sexp-entry (sexp entry date)
1163 "Process a SEXP diary ENTRY for DATE."
1164 (let ((result (condition-case nil
1165 (eval (car (read-from-string sexp)))
1166 (error
1167 (beep)
1168 (message "Bad sexp at line %d in %s: %s"
1169 (save-excursion
1170 (save-restriction
1171 (narrow-to-region 1 (point))
1172 (goto-char (point-min))
1173 (let ((lines 1))
1174 (while (re-search-forward "\n\\|\^M" nil t)
1175 (setq lines (1+ lines)))
1176 lines)))
1177 diary-file sexp)
1178 (sleep-for 2)))))
1179 (if (stringp result)
1180 result
1181 (if result
1182 entry
1183 nil))))
1184
1185(defun diary-block (m1 d1 y1 m2 d2 y2)
1186 "Block diary entry--entry applies if date is between two dates. Order of
1187the parameters is M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and
1188D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t."
1189 (let ((date1 (calendar-absolute-from-gregorian
1190 (if european-calendar-style
1191 (list d1 m1 y1)
1192 (list m1 d1 y1))))
1193 (date2 (calendar-absolute-from-gregorian
1194 (if european-calendar-style
1195 (list d2 m2 y2)
1196 (list m2 d2 y2))))
1197 (d (calendar-absolute-from-gregorian date)))
1198 (if (and (<= date1 d) (<= d date2))
1199 entry)))
1200
1201(defun diary-float (month dayname n)
1202 "Floating diary entry--entry applies if date is the nth dayname of month.
1203Parameters are MONTH, DAYNAME, N. MONTH can be a list of months, the constant
1204t, or an integer. The constant t means all months. If N is negative, count
1205backward from the end of the month."
1206 (let ((m (extract-calendar-month date))
1207 (y (extract-calendar-year date)))
1208 (if (and
1209 (or (and (listp month) (memq m month))
1210 (equal m month)
1211 (eq month t))
1212 (calendar-date-equal date (calendar-nth-named-day n dayname m y)))
1213 entry)))
1214
1215(defun diary-anniversary (month day year)
1216 "Anniversary diary entry--entry applies if date is the anniversary of
1217MONTH, DAY, YEAR if `european-calendar-style' is nil, and DAY, MONTH, YEAR
1218if `european-calendar-style' is t. Diary entry can contain `%d' or `%d%s'; the
1219%d will be replaced by the number of years since the MONTH DAY, YEAR and the
1220%s will be replaced by the ordinal ending of that number (that is, `st', `nd',
1221`rd' or `th', as appropriate. The anniversary of February 29 is considered
1222to be March 1 in non-leap years."
1223 (let* ((d (if european-calendar-style
1224 month
1225 day))
1226 (m (if european-calendar-style
1227 day
1228 month))
1229 (y (extract-calendar-year date))
1230 (diff (- y year)))
1231 (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y)))
1232 (setq m 3
1233 d 1))
1234 (if (and (> diff 0) (calendar-date-equal (list m d y) date))
1235 (format entry diff (diary-ordinal-suffix diff)))))
1236
1237(defun diary-cyclic (n month day year)
1238 "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
1239If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
1240ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
1241years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal
1242ending of that number (that is, `st', `nd', `rd' or `th', as appropriate."
1243 (let* ((d (if european-calendar-style
1244 month
1245 day))
1246 (m (if european-calendar-style
1247 day
1248 month))
1249 (diff (- (calendar-absolute-from-gregorian date)
1250 (calendar-absolute-from-gregorian
1251 (list m d year))))
1252 (cycle (/ diff n)))
1253 (if (and (>= diff 0) (zerop (% diff n)))
1254 (format entry cycle (diary-ordinal-suffix cycle)))))
1255
1256(defun diary-ordinal-suffix (n)
1257 "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
1258 (if (or (and (< 9 n) (< n 20))
1259 (memq (% n 10) '(4 5 6 7 8 9 0)))
1260 "th"
1261 (aref ["th" "st" "nd" "rd"] (% n 10))))
1262
1263(defun diary-day-of-year ()
1264 "Day of year and number of days remaining in the year of date diary entry."
1265 (let* ((year (extract-calendar-year date))
1266 (day (calendar-day-number date))
1267 (days-remaining (- (calendar-day-number (list 12 31 year)) day)))
1268 (format "Day %d of %d; %d day%s remaining in the year"
1269 day year days-remaining (if (= days-remaining 1) "" "s"))))
1270
1271(defun diary-iso-date ()
1272 "ISO calendar equivalent of date diary entry."
1273 (let ((day (% (calendar-absolute-from-gregorian date) 7))
1274 (iso-date (calendar-iso-from-absolute
1275 (calendar-absolute-from-gregorian date))))
1276 (format "ISO date: Day %s of week %d of %d."
1277 (if (zerop day) 7 day)
1278 (extract-calendar-month iso-date)
1279 (extract-calendar-year iso-date))))
1280
1281(defun diary-islamic-date ()
1282 "Islamic calendar equivalent of date diary entry."
1283 (let* ((calendar-date-display-form
1284 (if european-calendar-style
1285 '(day " " monthname " " year)
1286 '(monthname " " day ", " year)))
1287 (i-date (calendar-islamic-from-absolute
1288 (calendar-absolute-from-gregorian date)))
1289 (calendar-month-name-array calendar-islamic-month-name-array))
1290 (if (>= (extract-calendar-year i-date) 1)
1291 (format "Islamic date: %s" (calendar-date-string i-date)))))
1292
1293(defun diary-hebrew-date ()
1294 "Hebrew calendar equivalent of date diary entry."
1295 (let* ((calendar-date-display-form
1296 (if european-calendar-style
1297 '(day " " monthname " " year)
1298 '(monthname " " day ", " year)))
1299 (h-date (calendar-hebrew-from-absolute
1300 (calendar-absolute-from-gregorian date)))
1301 (calendar-month-name-array
1302 (if (hebrew-calendar-leap-year-p
1303 (extract-calendar-year h-date))
1304 calendar-hebrew-month-name-array-leap-year
1305 calendar-hebrew-month-name-array-common-year)))
1306 (format "Hebrew date: %s" (calendar-date-string h-date))))
1307
1308(defun diary-french-date ()
1309 "French calendar equivalent of date diary entry."
1310 (let* ((french-date (calendar-french-from-absolute
1311 (calendar-absolute-from-gregorian date)))
1312 (y (extract-calendar-year french-date))
1313 (m (extract-calendar-month french-date))
1314 (d (extract-calendar-day french-date)))
1315 (if (> y 0)
1316 (if (= m 13)
1317 (format "Jour %s de l'Annee %d de la Revolution"
1318 (aref french-calendar-special-days-array (1- d))
1319 y)
1320 (format "Decade %s, %s de %s de l'Annee %d de la Revolution"
1321 (make-string (1+ (/ (1- d) 10)) ?I)
1322 (aref french-calendar-day-name-array (% (1- d) 10))
1323 (aref french-calendar-month-name-array (1- m))
1324 y)))))
1325
1326(defun diary-omer ()
1327 "Omer count diary entry--entry applies if date is within 50 days after
1328Passover."
1329 (let* ((passover
1330 (calendar-absolute-from-hebrew
1331 (list 1 15 (+ (extract-calendar-year date) 3760))))
1332 (omer (- (calendar-absolute-from-gregorian date) passover))
1333 (week (/ omer 7))
1334 (day (% omer 7)))
1335 (if (and (> omer 0) (< omer 50))
1336 (format "Day %d%s of the omer (until sunset)"
1337 omer
1338 (if (zerop week)
1339 ""
1340 (format ", that is, %d week%s%s"
1341 week
1342 (if (= week 1) "" "s")
1343 (if (zerop day)
1344 ""
1345 (format " and %d day%s"
1346 day (if (= day 1) "" "s")))))))))
1347
1348(defun diary-yahrzeit (death-month death-day death-year)
1349 "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.
1350Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed
1351to be the name of the person. Date of death is on the *civil* calendar;
1352although the date of death is specified by the civil calendar, the proper
1353Hebrew calendar yahrzeit is determined. If european-calendar-style is t, the
1354order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR."
1355 (let* ((h-date (calendar-hebrew-from-absolute
1356 (calendar-absolute-from-gregorian
1357 (if european-calendar-style
1358 (list death-day death-month death-year)
1359 (list death-month death-day death-year)))))
1360 (h-month (extract-calendar-month h-date))
1361 (h-day (extract-calendar-day h-date))
1362 (h-year (extract-calendar-year h-date))
1363 (d (calendar-absolute-from-gregorian date))
1364 (yr (extract-calendar-year (calendar-hebrew-from-absolute d)))
1365 (diff (- yr h-year))
1366 (y (hebrew-calendar-yahrzeit h-date yr)))
1367 (if (and (> diff 0) (or (= y d) (= y (1+ d))))
1368 (format "Yahrzeit of %s%s: %d%s anniversary"
1369 entry
1370 (if (= y d) "" " (evening)")
1371 diff
1372 (cond ((= (% diff 10) 1) "st")
1373 ((= (% diff 10) 2) "nd")
1374 ((= (% diff 10) 3) "rd")
1375 (t "th"))))))
1376
1377(defun diary-rosh-hodesh ()
1378 "Rosh Hodesh diary entry--entry applies if date is Rosh Hodesh or the
1379Saturday before."
1380 (let* ((d (calendar-absolute-from-gregorian date))
1381 (h-date (calendar-hebrew-from-absolute d))
1382 (h-month (extract-calendar-month h-date))
1383 (h-day (extract-calendar-day h-date))
1384 (h-year (extract-calendar-year h-date))
1385 (leap-year (hebrew-calendar-leap-year-p h-year))
1386 (last-day (hebrew-calendar-last-day-of-month h-month h-year))
1387 (h-month-names
1388 (if leap-year
1389 calendar-hebrew-month-name-array-leap-year
1390 calendar-hebrew-month-name-array-common-year))
1391 (this-month (aref h-month-names (1- h-month)))
1392 (h-yesterday (extract-calendar-day
1393 (calendar-hebrew-from-absolute (1- d)))))
1394 (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7)))
1395 (format
1396 "Rosh Hodesh %s"
1397 (if (= h-day 30)
1398 (format
1399 "%s (first day)"
1400 ;; next month must be in the same year since this
1401 ;; month can't be the last month of the year since
1402 ;; it has 30 days
1403 (aref h-month-names h-month))
1404 (if (= h-yesterday 30)
1405 (format "%s (second day)" this-month)
1406 this-month)))
1407 (if (= (mod d 7) 6);; Saturday--check for Shabbat Mevarhim
1408 (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
1409 (format "Mevarhim Rosh Hodesh %s (%s)"
1410 (aref h-month-names
1411 (if (= h-month
1412 (hebrew-calendar-last-month-of-year
1413 h-year))
1414 0 h-month))
1415 (aref calendar-day-name-array (- 29 h-day))))
1416 ((and (< h-day 30) (> h-day 22) (= 30 last-day))
1417 (format "Mevarhim Rosh Hodesh %s (%s-%s)"
1418 (aref h-month-names h-month)
1419 (aref calendar-day-name-array (- 29 h-day))
1420 (aref calendar-day-name-array
1421 (mod (- 30 h-day) 7)))))))))
1422
1423(defun diary-parasha ()
1424 "Parasha diary entry--entry applies if date is a Saturday."
1425 (let ((d (calendar-absolute-from-gregorian date)))
1426 (if (= (% d 7) 6);; Saturday
1427 (let*
1428 ((h-year (extract-calendar-year
1429 (calendar-hebrew-from-absolute d)))
1430 (rosh-hashannah
1431 (calendar-absolute-from-hebrew (list 7 1 h-year)))
1432 (passover
1433 (calendar-absolute-from-hebrew (list 1 15 h-year)))
1434 (rosh-hashannah-day
1435 (aref calendar-day-name-array (% rosh-hashannah 7)))
1436 (passover-day
1437 (aref calendar-day-name-array (% passover 7)))
1438 (long-h (hebrew-calendar-long-heshvan-p h-year))
1439 (short-k (hebrew-calendar-short-kislev-p h-year))
1440 (type (cond ((and long-h (not short-k)) "complete")
1441 ((and (not long-h) short-k) "incomplete")
1442 (t "regular")))
1443 (year-format
1444 (symbol-value
1445 (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah
1446 rosh-hashannah-day type passover-day))))
1447 (first-saturday;; of Hebrew year
1448 (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah)))
1449 (saturday;; which Saturday of the Hebrew year
1450 (/ (- d first-saturday) 7))
1451 (parasha (aref year-format saturday)))
1452 (if parasha
1453 (format
1454 "Parashat %s"
1455 (if (listp parasha);; Israel differs from diaspora
1456 (if (car parasha)
1457 (format "%s (diaspora), %s (Israel)"
1458 (hebrew-calendar-parasha-name (car parasha))
1459 (hebrew-calendar-parasha-name (cdr parasha)))
1460 (format "%s (Israel)"
1461 (hebrew-calendar-parasha-name (cdr parasha))))
1462 (hebrew-calendar-parasha-name parasha))))))))
1463
1464(defun add-to-diary-list (date string)
1465 "Add the entry (DATE STRING) to the diary-entries-list.
1466Do nothing if DATE or STRING is nil."
1467 (and date string
1468 (setq diary-entries-list
1469 (append diary-entries-list (list (list date string))))))
1470
1471(defconst hebrew-calendar-parashiot-names
1472["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth"
1473 "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi"
1474 "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim"
1475 "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra"
1476 "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim"
1477 "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha"
1478 "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth"
1479 "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim"
1480 "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"]
1481 "The names of the parashiot in the Torah.")
1482
1483;; The seven ordinary year types (keviot)
1484
1485(defconst hebrew-calendar-year-Saturday-incomplete-Sunday
1486 [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]
1487 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1488 43 44 45 46 47 48 49 50]
1489 "The structure of the parashiot in a Hebrew year that starts on Saturday,
1490is `incomplete' (Heshvan and Kislev each have 29 days), and has Passover
1491start on Sunday.")
1492
1493(defconst hebrew-calendar-year-Saturday-complete-Tuesday
1494 [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]
1495 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1496 43 44 45 46 47 48 49 [50 51]]
1497 "The structure of the parashiot in a Hebrew year that starts on Saturday,
1498is `complete' (Heshvan and Kislev each have 30 days), and has Passover
1499start on Tuesday.")
1500
1501(defconst hebrew-calendar-year-Monday-incomplete-Tuesday
1502 [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]
1503 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1504 43 44 45 46 47 48 49 [50 51]]
1505 "The structure of the parashiot in a Hebrew year that starts on Monday,
1506is `incomplete' (Heshvan and Kislev each have 29 days), and has Passover
1507start on Tuesday.")
1508
1509(defconst hebrew-calendar-year-Monday-complete-Thursday
1510 [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]
1511 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34.35) (35.36)
1512 (36.37) (37.38) ([38 39].39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1513 "The structure of the parashiot in a Hebrew year that starts on Monday,
1514is `complete' (Heshvan and Kislev each have 30 days), and has Passover
1515start on Thursday.")
1516
1517(defconst hebrew-calendar-year-Tuesday-regular-Thursday
1518 [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]
1519 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34.35) (35.36)
1520 (36.37) (37.38) ([38 39].39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1521 "The structure of the parashiot in a Hebrew year that starts on Tuesday,
1522is `regular' (Heshvan has 29 days and Kislev has 30 days), and has Passover
1523start on Thursday.")
1524
1525(defconst hebrew-calendar-year-Thursday-regular-Saturday
1526 [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]
1527 23 24 nil (nil . 25) (25.[26 27]) ([26 27].[28 29]) ([28 29].30) (30.31)
1528 ([31 32].32) 33 34 35 36 37 38 39 40 [41 42]
1529 43 44 45 46 47 48 49 50]
1530 "The structure of the parashiot in a Hebrew year that starts on Thursday,
1531is `regular' (Heshvan has 29 days and Kislev has 30 days), and has Passover
1532start on Saturday.")
1533
1534(defconst hebrew-calendar-year-Thursday-complete-Sunday
1535 [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
1536 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1537 43 44 45 46 47 48 49 50]
1538 "The structure of the parashiot in a Hebrew year that starts on Thursday,
1539is `complete' (Heshvan and Kislev each have 30 days), and has Passover
1540start on Sunday.")
1541
1542;; The seven leap year types (keviot)
1543
1544(defconst hebrew-calendar-year-Saturday-incomplete-Tuesday
1545 [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
1546 23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42]
1547 43 44 45 46 47 48 49 [50 51]]
1548 "The structure of the parashiot in a Hebrew year that starts on Saturday,
1549is `incomplete' (Heshvan and Kislev each have 29 days), and has Passover
1550start on Tuesday.")
1551
1552(defconst hebrew-calendar-year-Saturday-complete-Thursday
1553 [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
1554 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34.35) (35.36) (36.37)
1555 (37.38) ([38 39].39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1556 "The structure of the parashiot in a Hebrew year that starts on Saturday,
1557is `complete' (Heshvan and Kislev each have 30 days), and has Passover
1558start on Thursday.")
1559
1560(defconst hebrew-calendar-year-Monday-incomplete-Thursday
1561 [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
1562 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34.35) (35.36) (36.37)
1563 (37.38) ([38 39].39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1564 "The structure of the parashiot in a Hebrew year that starts on Monday,
1565is `incomplete' (Heshvan and Kislev each have 29 days), and has Passover
1566start on Thursday.")
1567
1568(defconst hebrew-calendar-year-Monday-complete-Saturday
1569 [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
1570 23 24 25 26 27 nil (nil . 28) (28.29) (29.30) (30.31) (31.32) (32.33)
1571 (33.34) (34.35) (35.36) (36.37) (37.38) (38.39) (39.40) (40.41) ([41 42].42)
1572 43 44 45 46 47 48 49 50]
1573 "The structure of the parashiot in a Hebrew year that starts on Monday,
1574is `complete' (Heshvan and Kislev each have 30 days), and has Passover
1575start on Saturday.")
1576
1577(defconst hebrew-calendar-year-Tuesday-regular-Saturday
1578 [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
1579 23 24 25 26 27 nil (nil . 28) (28.29) (29.30) (30.31) (31.32) (32.33)
1580 (33.34) (34.35) (35.36) (36.37) (37.38) (38.39) (39.40) (40.41) ([41 42].42)
1581 43 44 45 46 47 48 49 50]
1582 "The structure of the parashiot in a Hebrew year that starts on Tuesday,
1583is `regular' (Heshvan has 29 days and Kislev has 30 days), and has Passover
1584start on Saturday.")
1585
1586(defconst hebrew-calendar-year-Thursday-incomplete-Sunday
1587 [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
1588 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
1589 43 44 45 46 47 48 49 50]
1590 "The structure of the parashiot in a Hebrew year that starts on Thursday,
1591is `incomplete' (Heshvan and Kislev both have 29 days), and has Passover
1592start on Sunday.")
1593
1594(defconst hebrew-calendar-year-Thursday-complete-Tuesday
1595 [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
1596 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
1597 43 44 45 46 47 48 49 [50 51]]
1598 "The structure of the parashiot in a Hebrew year that starts on Thursday,
1599is `complete' (Heshvan and Kislev both have 30 days), and has Passover
1600start on Tuesday.")
1601
1602(defun hebrew-calendar-parasha-name (p)
1603 "Name(s) corresponding to parasha P."
1604 (if (arrayp p);; combined parasha
1605 (format "%s/%s"
1606 (aref hebrew-calendar-parashiot-names (aref p 0))
1607 (aref hebrew-calendar-parashiot-names (aref p 1)))
1608 (aref hebrew-calendar-parashiot-names p)))
1609
1610(defun hebrew-calendar-yahrzeit (death-date year)
1611 "Absolute date of the anniversary of Hebrew DEATH-DATE in Hebrew YEAR."
1612 (let* ((death-day (extract-calendar-day death-date))
1613 (death-month (extract-calendar-month death-date))
1614 (death-year (extract-calendar-year death-date)))
1615 (cond
1616 ;; If it's Heshvan 30 it depends on the first anniversary; if
1617 ;; that was not Heshvan 30, use the day before Kislev 1.
1618 ((and (= death-month 8)
1619 (= death-day 30)
1620 (not (hebrew-calendar-long-heshvan-p (1+ death-year))))
1621 (1- (calendar-absolute-from-hebrew (list 9 1 year))))
1622 ;; If it's Kislev 30 it depends on the first anniversary; if
1623 ;; that was not Kislev 30, use the day before Teveth 1.
1624 ((and (= death-month 9)
1625 (= death-day 30)
1626 (hebrew-calendar-short-kislev-p (1+ death-year)))
1627 (1- (calendar-absolute-from-hebrew (list 10 1 year))))
1628 ;; If it's Adar II, use the same day in last month of
1629 ;; year (Adar or Adar II).
1630 ((= death-month 13)
1631 (calendar-absolute-from-hebrew
1632 (list (last-month-of-hebrew-year year) death-day year)))
1633 ;; If it's the 30th in Adar I and $year$ is not a leap year
1634 ;; (so Adar has only 29 days), use the last day in Shevat.
1635 ((and (= death-day 30)
1636 (= death-month 12)
1637 (not (hebrew-calendar-leap-year-p death-year)))
1638 (calendar-absolute-from-hebrew (list 11 30 year)))
1639 ;; In all other cases, use the normal anniversary of the date of death.
1640 (t (calendar-absolute-from-hebrew
1641 (list death-month death-day year))))))
1642
1643(defun list-islamic-diary-entries ()
1644 "Add any Islamic date entries from the diary-file to diary-entries-list.
1645Islamic date diary entries must be prefaced by an islamic-diary-entry-symbol
1646\(normally an `I'\). The same diary-date-forms govern the style of the Islamic
1647calendar entries, except that the Islamic month names must be spelled in full.
1648The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
1649Dhu al-Hijjah. If an Islamic date diary entry begins with a
1650diary-nonmarking-symbol the entry will appear in the diary listing, but will
1651not be marked in the calendar. This function is provided for use with the
1652nongregorian-diary-listing-hook."
1653 (if (< 0 number)
1654 (let ((buffer-read-only nil)
1655 (diary-modified (buffer-modified-p))
1656 (gdate original-date)
1657 (mark (regexp-quote diary-nonmarking-symbol)))
1658 (calendar-for-loop i from 1 to number do
1659 (let* ((d diary-date-forms)
1660 (idate (calendar-islamic-from-absolute
1661 (calendar-absolute-from-gregorian gdate)))
1662 (month (extract-calendar-month idate))
1663 (day (extract-calendar-day idate))
1664 (year (extract-calendar-year idate)))
1665 (while d
1666 (let*
1667 ((date-form (if (equal (car (car d)) 'backup)
1668 (cdr (car d))
1669 (car d)))
1670 (backup (equal (car (car d)) 'backup))
1671 (dayname
1672 (concat
1673 (calendar-day-name gdate) "\\|"
1674 (substring (calendar-day-name gdate) 0 3) ".?"))
1675 (calendar-month-name-array
1676 calendar-islamic-month-name-array)
1677 (monthname
1678 (concat
1679 "\\*\\|"
1680 (calendar-month-name month)))
1681 (month (concat "\\*\\|0*" (int-to-string month)))
1682 (day (concat "\\*\\|0*" (int-to-string day)))
1683 (year
1684 (concat
1685 "\\*\\|0*" (int-to-string year)
1686 (if abbreviated-calendar-year
1687 (concat "\\|" (int-to-string (% year 100)))
1688 "")))
1689 (regexp
1690 (concat
1691 "\\(\\`\\|\^M\\|\n\\)" mark "?"
1692 (regexp-quote islamic-diary-entry-symbol)
1693 "\\("
1694 (mapconcat 'eval date-form "\\)\\(")
1695 "\\)"))
1696 (case-fold-search t))
1697 (goto-char (point-min))
1698 (while (re-search-forward regexp nil t)
1699 (if backup (re-search-backward "\\<" nil t))
1700 (if (and (or (char-equal (preceding-char) ?\^M)
1701 (char-equal (preceding-char) ?\n))
1702 (not (looking-at " \\|\^I")))
1703 ;; Diary entry that consists only of date.
1704 (backward-char 1)
1705 ;; Found a nonempty diary entry--make it visible and
1706 ;; add it to the list.
1707 (let ((entry-start (point))
1708 (date-start))
1709 (re-search-backward "\^M\\|\n\\|\\`")
1710 (setq date-start (point))
1711 (re-search-forward "\^M\\|\n" nil t 2)
1712 (while (looking-at " \\|\^I")
1713 (re-search-forward "\^M\\|\n" nil t))
1714 (backward-char 1)
1715 (subst-char-in-region date-start (point) ?\^M ?\n t)
1716 (add-to-diary-list
1717 gdate (buffer-substring entry-start (point)))))))
1718 (setq d (cdr d))))
1719 (setq gdate
1720 (calendar-gregorian-from-absolute
1721 (1+ (calendar-absolute-from-gregorian gdate)))))
1722 (set-buffer-modified-p diary-modified))
1723 (goto-char (point-min))))
1724
1725(defun mark-islamic-diary-entries ()
1726 "Mark days in the calendar window that have Islamic date diary entries.
1727Each entry in diary-file (or included files) visible in the calendar window
1728is marked. Islamic date entries are prefaced by a islamic-diary-entry-symbol
1729\(normally an `I'\). The same diary-date-forms govern the style of the Islamic
1730calendar entries, except that the Islamic month names must be spelled in full.
1731The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
1732Dhu al-Hijjah. Islamic date diary entries that begin with a
1733diary-nonmarking-symbol will not be marked in the calendar. This function is
1734provided for use as part of the nongregorian-diary-marking-hook."
1735 (let ((d diary-date-forms))
1736 (while d
1737 (let*
1738 ((date-form (if (equal (car (car d)) 'backup)
1739 (cdr (car d))
1740 (car d)));; ignore 'backup directive
1741 (dayname (diary-name-pattern calendar-day-name-array))
1742 (monthname
1743 (concat
1744 (diary-name-pattern calendar-islamic-month-name-array t)
1745 "\\|\\*"))
1746 (month "[0-9]+\\|\\*")
1747 (day "[0-9]+\\|\\*")
1748 (year "[0-9]+\\|\\*")
1749 (l (length date-form))
1750 (d-name-pos (- l (length (memq 'dayname date-form))))
1751 (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
1752 (m-name-pos (- l (length (memq 'monthname date-form))))
1753 (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
1754 (d-pos (- l (length (memq 'day date-form))))
1755 (d-pos (if (/= l d-pos) (+ 2 d-pos)))
1756 (m-pos (- l (length (memq 'month date-form))))
1757 (m-pos (if (/= l m-pos) (+ 2 m-pos)))
1758 (y-pos (- l (length (memq 'year date-form))))
1759 (y-pos (if (/= l y-pos) (+ 2 y-pos)))
1760 (regexp
1761 (concat
1762 "\\(\\`\\|\^M\\|\n\\)"
1763 (regexp-quote islamic-diary-entry-symbol)
1764 "\\("
1765 (mapconcat 'eval date-form "\\)\\(")
1766 "\\)"))
1767 (case-fold-search t))
1768 (goto-char (point-min))
1769 (while (re-search-forward regexp nil t)
1770 (let* ((dd-name
1771 (if d-name-pos
1772 (buffer-substring
1773 (match-beginning d-name-pos)
1774 (match-end d-name-pos))))
1775 (mm-name
1776 (if m-name-pos
1777 (buffer-substring
1778 (match-beginning m-name-pos)
1779 (match-end m-name-pos))))
1780 (mm (string-to-int
1781 (if m-pos
1782 (buffer-substring
1783 (match-beginning m-pos)
1784 (match-end m-pos))
1785 "")))
1786 (dd (string-to-int
1787 (if d-pos
1788 (buffer-substring
1789 (match-beginning d-pos)
1790 (match-end d-pos))
1791 "")))
1792 (y-str (if y-pos
1793 (buffer-substring
1794 (match-beginning y-pos)
1795 (match-end y-pos))))
1796 (yy (if (not y-str)
1797 0
1798 (if (and (= (length y-str) 2)
1799 abbreviated-calendar-year)
1800 (let* ((current-y
1801 (extract-calendar-year
1802 (calendar-islamic-from-absolute
1803 (calendar-absolute-from-gregorian
1804 (calendar-current-date)))))
1805 (y (+ (string-to-int y-str)
1806 (* 100 (/ current-y 100)))))
1807 (if (> (- y current-y) 50)
1808 (- y 100)
1809 (if (> (- current-y y) 50)
1810 (+ y 100)
1811 y)))
1812 (string-to-int y-str)))))
1813 (if dd-name
1814 (mark-calendar-days-named
1815 (cdr (assoc (capitalize (substring dd-name 0 3))
1816 (calendar-make-alist
1817 calendar-day-name-array
1818 0
1819 '(lambda (x) (substring x 0 3))))))
1820 (if mm-name
1821 (if (string-equal mm-name "*")
1822 (setq mm 0)
1823 (setq mm
1824 (cdr (assoc
1825 (capitalize mm-name)
1826 (calendar-make-alist
1827 calendar-islamic-month-name-array))))))
1828 (mark-islamic-calendar-date-pattern mm dd yy)))))
1829 (setq d (cdr d)))))
1830
1831(defun mark-islamic-calendar-date-pattern (month day year)
1832 "Mark all dates in the calendar window that conform to the Islamic date
1833MONTH/DAY/YEAR. A value of 0 in any position is a wild-card."
1834 (save-excursion
1835 (set-buffer calendar-buffer)
1836 (if (and (/= 0 month) (/= 0 day))
1837 (if (/= 0 year)
1838 ;; Fully specified Islamic date.
1839 (let ((date (calendar-gregorian-from-absolute
1840 (calendar-absolute-from-islamic
1841 (list month day year)))))
1842 (if (calendar-date-is-visible-p date)
1843 (mark-visible-calendar-date date)))
1844 ;; Month and day in any year--this taken from the holiday stuff.
1845 (let* ((islamic-date (calendar-islamic-from-absolute
1846 (calendar-absolute-from-gregorian
1847 (list displayed-month 15 displayed-year))))
1848 (m (extract-calendar-month islamic-date))
1849 (y (extract-calendar-year islamic-date))
1850 (date))
1851 (if (< m 1)
1852 nil;; Islamic calendar doesn't apply.
1853 (increment-calendar-month m y (- 10 month))
1854 (if (> m 7);; Islamic date might be visible
1855 (let ((date (calendar-gregorian-from-absolute
1856 (calendar-absolute-from-islamic
1857 (list month day y)))))
1858 (if (calendar-date-is-visible-p date)
1859 (mark-visible-calendar-date date)))))))
1860 ;; Not one of the simple cases--check all visible dates for match.
1861 ;; Actually, the following code takes care of ALL of the cases, but
1862 ;; it's much too slow to be used for the simple (common) cases.
1863 (let ((m displayed-month)
1864 (y displayed-year)
1865 (first-date)
1866 (last-date))
1867 (increment-calendar-month m y -1)
1868 (setq first-date
1869 (calendar-absolute-from-gregorian
1870 (list m 1 y)))
1871 (increment-calendar-month m y 2)
1872 (setq last-date
1873 (calendar-absolute-from-gregorian
1874 (list m (calendar-last-day-of-month m y) y)))
1875 (calendar-for-loop date from first-date to last-date do
1876 (let* ((i-date (calendar-islamic-from-absolute date))
1877 (i-month (extract-calendar-month i-date))
1878 (i-day (extract-calendar-day i-date))
1879 (i-year (extract-calendar-year i-date)))
1880 (and (or (zerop month)
1881 (= month i-month))
1882 (or (zerop day)
1883 (= day i-day))
1884 (or (zerop year)
1885 (= year i-year))
1886 (mark-visible-calendar-date
1887 (calendar-gregorian-from-absolute date)))))))))
1888
1889(defun make-diary-entry (string &optional nonmarking file)
1890 "Insert a diary entry STRING which may be NONMARKING in FILE.
1891If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."
1892 (find-file-other-window
1893 (substitute-in-file-name (if file file diary-file)))
1894 (goto-char (point-max))
1895 (insert
1896 (if (bolp) "" "\n")
1897 (if nonmarking diary-nonmarking-symbol "")
1898 string " "))
1899
1900(defun insert-diary-entry (arg)
1901 "Insert a diary entry for the date indicated by point.
1902Prefix arg will make the entry nonmarking."
1903 (interactive "P")
1904 (let* ((calendar-date-display-form
1905 (if european-calendar-style
1906 '(day " " monthname " " year)
1907 '(monthname " " day ", " year))))
1908 (make-diary-entry
1909 (calendar-date-string
1910 (or (calendar-cursor-to-date)
1911 (error "Cursor is not on a date!"))
1912 t)
1913 arg)))
1914
1915(defun insert-weekly-diary-entry (arg)
1916 "Insert a weekly diary entry for the day of the week indicated by point.
1917Prefix arg will make the entry nonmarking."
1918 (interactive "P")
1919 (make-diary-entry
1920 (calendar-day-name
1921 (or (calendar-cursor-to-date)
1922 (error "Cursor is not on a date!")))
1923 arg))
1924
1925(defun insert-monthly-diary-entry (arg)
1926 "Insert a monthly diary entry for the day of the month indicated by point.
1927Prefix arg will make the entry nonmarking."
1928 (interactive "P")
1929 (let* ((calendar-date-display-form
1930 (if european-calendar-style
1931 '(day " * ")
1932 '("* " day))))
1933 (make-diary-entry
1934 (calendar-date-string
1935 (or (calendar-cursor-to-date)
1936 (error "Cursor is not on a date!"))
1937 t)
1938 arg)))
1939
1940(defun insert-yearly-diary-entry (arg)
1941 "Insert an annual diary entry for the day of the year indicated by point.
1942Prefix arg will make the entry nonmarking."
1943 (interactive "P")
1944 (let* ((calendar-date-display-form
1945 (if european-calendar-style
1946 '(day " " monthname)
1947 '(monthname " " day))))
1948 (make-diary-entry
1949 (calendar-date-string
1950 (or (calendar-cursor-to-date)
1951 (error "Cursor is not on a date!"))
1952 t)
1953 arg)))
1954
1955(defun insert-anniversary-diary-entry (arg)
1956 "Insert an anniversary diary entry for the date given by point.
1957Prefix arg will make the entry nonmarking."
1958 (interactive "P")
1959 (let* ((calendar-date-display-form
1960 (if european-calendar-style
1961 '(day " " month " " year)
1962 '(month " " day " " year))))
1963 (make-diary-entry
1964 (format "%s(diary-anniversary %s)"
1965 sexp-diary-entry-symbol
1966 (calendar-date-string
1967 (or (calendar-cursor-to-date)
1968 (error "Cursor is not on a date!"))))
1969 arg)))
1970
1971(defun insert-block-diary-entry (arg)
1972 "Insert a block diary entry for the days between the point and marked date.
1973Prefix arg will make the entry nonmarking."
1974 (interactive "P")
1975 (let* ((calendar-date-display-form
1976 (if european-calendar-style
1977 '(day " " month " " year)
1978 '(month " " day " " year)))
1979 (cursor (or (calendar-cursor-to-date)
1980 (error "Cursor is not on a date!")))
1981 (mark (or (car calendar-mark-ring)
1982 (error "No mark set in this buffer")))
1983 (start)
1984 (end))
1985 (if (< (calendar-absolute-from-gregorian mark)
1986 (calendar-absolute-from-gregorian cursor))
1987 (setq start mark
1988 end cursor)
1989 (setq start cursor
1990 end mark))
1991 (make-diary-entry
1992 (format "%s(diary-block %s %s)"
1993 sexp-diary-entry-symbol
1994 (calendar-date-string start)
1995 (calendar-date-string end))
1996 arg)))
1997
1998(defun insert-cyclic-diary-entry (arg)
1999 "Insert a cyclic diary entry starting at the date given by point.
2000Prefix arg will make the entry nonmarking."
2001 (interactive "P")
2002 (let* ((calendar-date-display-form
2003 (if european-calendar-style
2004 '(day " " month " " year)
2005 '(month " " day " " year))))
2006 (make-diary-entry
2007 (format "%s(diary-cyclic %d %s)"
2008 sexp-diary-entry-symbol
2009 (calendar-read "Repeat every how many days: "
2010 '(lambda (x) (> x 0)))
2011 (calendar-date-string
2012 (or (calendar-cursor-to-date)
2013 (error "Cursor is not on a date!"))))
2014 arg)))
2015
2016(defun insert-hebrew-diary-entry (arg)
2017 "Insert a diary entry for the Hebrew date corresponding to the date
2018indicated by point. Prefix arg will make the entry nonmarking."
2019 (interactive "P")
2020 (let* ((calendar-date-display-form
2021 (if european-calendar-style
2022 '(day " " monthname " " year)
2023 '(monthname " " day ", " year)))
2024 (calendar-month-name-array
2025 calendar-hebrew-month-name-array-leap-year))
2026 (make-diary-entry
2027 (concat
2028 hebrew-diary-entry-symbol
2029 (calendar-date-string
2030 (calendar-hebrew-from-absolute
2031 (calendar-absolute-from-gregorian
2032 (or (calendar-cursor-to-date)
2033 (error "Cursor is not on a date!"))))))
2034 arg)))
2035
2036(defun insert-monthly-hebrew-diary-entry (arg)
2037 "Insert a monthly diary entry for the day of the Hebrew month corresponding
2038to the date indicated by point. Prefix arg will make the entry nonmarking."
2039 (interactive "P")
2040 (let* ((calendar-date-display-form
2041 (if european-calendar-style '(day " * ") '("* " day )))
2042 (calendar-month-name-array
2043 calendar-hebrew-month-name-array-leap-year))
2044 (make-diary-entry
2045 (concat
2046 hebrew-diary-entry-symbol
2047 (calendar-date-string
2048 (calendar-hebrew-from-absolute
2049 (calendar-absolute-from-gregorian
2050 (or (calendar-cursor-to-date)
2051 (error "Cursor is not on a date!"))))))
2052 arg)))
2053
2054(defun insert-yearly-hebrew-diary-entry (arg)
2055 "Insert an annual diary entry for the day of the Hebrew year corresponding
2056to the date indicated by point. Prefix arg will make the entry nonmarking."
2057 (interactive "P")
2058 (let* ((calendar-date-display-form
2059 (if european-calendar-style
2060 '(day " " monthname)
2061 '(monthname " " day)))
2062 (calendar-month-name-array
2063 calendar-hebrew-month-name-array-leap-year))
2064 (make-diary-entry
2065 (concat
2066 hebrew-diary-entry-symbol
2067 (calendar-date-string
2068 (calendar-hebrew-from-absolute
2069 (calendar-absolute-from-gregorian
2070 (or (calendar-cursor-to-date)
2071 (error "Cursor is not on a date!"))))))
2072 arg)))
2073
2074(defun insert-islamic-diary-entry (arg)
2075 "Insert a diary entry for the Islamic date corresponding to the date
2076indicated by point. Prefix arg will make the entry nonmarking."
2077 (interactive "P")
2078 (let* ((calendar-date-display-form
2079 (if european-calendar-style
2080 '(day " " monthname " " year)
2081 '(monthname " " day ", " year)))
2082 (calendar-month-name-array calendar-islamic-month-name-array))
2083 (make-diary-entry
2084 (concat
2085 islamic-diary-entry-symbol
2086 (calendar-date-string
2087 (calendar-islamic-from-absolute
2088 (calendar-absolute-from-gregorian
2089 (or (calendar-cursor-to-date)
2090 (error "Cursor is not on a date!"))))))
2091 arg)))
2092
2093(defun insert-monthly-islamic-diary-entry (arg)
2094 "Insert a monthly diary entry for the day of the Islamic month corresponding
2095to the date indicated by point. Prefix arg will make the entry nonmarking."
2096 (interactive "P")
2097 (let* ((calendar-date-display-form
2098 (if european-calendar-style '(day " * ") '("* " day )))
2099 (calendar-month-name-array calendar-islamic-month-name-array))
2100 (make-diary-entry
2101 (concat
2102 islamic-diary-entry-symbol
2103 (calendar-date-string
2104 (calendar-islamic-from-absolute
2105 (calendar-absolute-from-gregorian
2106 (or (calendar-cursor-to-date)
2107 (error "Cursor is not on a date!"))))))
2108 arg)))
2109
2110(defun insert-yearly-islamic-diary-entry (arg)
2111 "Insert an annual diary entry for the day of the Islamic year corresponding
2112to the date indicated by point. Prefix arg will make the entry nonmarking."
2113 (interactive "P")
2114 (let* ((calendar-date-display-form
2115 (if european-calendar-style
2116 '(day " " monthname)
2117 '(monthname " " day)))
2118 (calendar-month-name-array calendar-islamic-month-name-array))
2119 (make-diary-entry
2120 (concat
2121 islamic-diary-entry-symbol
2122 (calendar-date-string
2123 (calendar-islamic-from-absolute
2124 (calendar-absolute-from-gregorian
2125 (or (calendar-cursor-to-date)
2126 (error "Cursor is not on a date!"))))))
2127 arg)))
generated by cgit v1.2.1 (git 2.18.0) at 2026-04-19 20:12:20 +0000