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