1 ;;; diary.el --- diary functions.
3 ;; Copyright (C) 1989, 1990, 1992, 1993 Free Software Foundation, Inc.
5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
8 ;; This file is part of GNU Emacs.
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)
15 ;; GNU Emacs is distributed in the hope that it will be useful,
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.
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.
26 ;; This collection of functions implements the diary features as described
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
40 (defun diary (&optional arg
)
41 "Generate the diary window for ARG days starting with the current date.
42 If no argument is provided, the number of days of diary entries is governed
43 by the variable `number-of-diary-entries'. This function is suitable for
44 execution in a `.emacs' file."
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
)
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!"))))
60 (defun view-diary-entries (arg)
61 "Prepare and display a buffer with diary entries.
62 Searches the file named in `diary-file' for entries that
63 match ARG days starting with the date indicated by the cursor position
64 in the displayed three-month calendar."
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
)
69 (list-diary-entries (calendar-cursor-to-date t
) arg
)
70 (error "Your diary file is not readable!"))
71 (error "You don't have a diary file!"))))
73 (autoload 'check-calendar-holidays
"holidays"
74 "Check the list of holidays for any that occur on DATE.
75 The value returned is a list of strings of relevant holiday descriptions.
76 The holidays are those in the list `calendar-holidays'."
80 (autoload 'calendar-holiday-list
"holidays"
81 "Form the list of holidays that occur on dates in the calendar window.
82 The holidays are those in the list `calendar-holidays'."
85 (autoload 'diary-french-date
"cal-french"
86 "French calendar equivalent of date diary entry."
89 (autoload 'diary-mayan-date
"cal-mayan"
90 "Mayan calendar equivalent of date diary entry."
93 (autoload 'diary-phases-of-moon
"lunar" "Moon phases diary entry." t
)
95 (autoload 'diary-sunrise-sunset
"solar"
96 "Local time of sunrise and sunset as a diary entry."
99 (autoload 'diary-sabbath-candles
"solar"
100 "Local time of candle lighting diary entry--applies if date is a Friday.
101 No diary entry if there is no sunset on that date."
104 (defvar diary-syntax-table
(copy-syntax-table (standard-syntax-table))
105 "The syntax table used when parsing dates in the diary file.
106 It is the standard syntax table used in Fundamental mode, but with the
107 syntax of `*' changed to be a word constituent.")
109 (modify-syntax-entry ?
* "w" diary-syntax-table
)
111 (defun list-diary-entries (date number
)
112 "Create and display a buffer containing the relevant lines in diary-file.
113 The arguments are DATE and NUMBER; the entries selected are those
114 for NUMBER days starting with date DATE. The other entries are hidden
115 using selective display.
117 Returns a list of all relevant diary entries found, if any, in order by date.
118 The list entries have the form ((month day year) string). If the variable
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.
122 After the list is prepared, the hooks `nongregorian-diary-listing-hook',
123 `list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run.
124 These hooks have the following distinct roles:
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.
130 `list-diary-entries-hook' adds or manipulates diary entries from
131 external sources. Used, for example, to include diary entries
132 from other files or to sort the diary entries. Invoked *once* only,
133 before the display hook is run.
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.
140 `diary-hook' is run last. This can be used for an appointment
141 notification function."
144 (let* ((original-date date
);; save for possible use in the hooks
145 (old-diary-syntax-table)
147 (date-string (calendar-date-string date
))
148 (d-file (substitute-in-file-name diary-file
)))
149 (message "Preparing diary...")
151 (let ((diary-buffer (get-file-buffer d-file
)))
152 (set-buffer (if 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
)
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"))
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
)))
180 ((date-form (if (equal (car (car d
)) 'backup
)
183 (backup (equal (car (car d
)) 'backup
))
186 (calendar-day-name date
) "\\|"
187 (substring (calendar-day-name date
) 0 3) ".?"))
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
)))
197 "\\*\\|0*" (int-to-string year
)
198 (if abbreviated-calendar-year
199 (concat "\\|" (int-to-string (% year
100)))
203 "\\(\\`\\|\^M\\|\n\\)" mark
"?\\("
204 (mapconcat 'eval date-form
"\\)\\(")
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.
215 ;; Found a nonempty diary entry--make it visible and
216 ;; add it to the list.
218 (let ((entry-start (point))
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
))
226 (subst-char-in-region date-start
229 date
(buffer-substring entry-start
(point)))))))
232 (not diary-list-include-blanks
)
233 (setq diary-entries-list
234 (append diary-entries-list
235 (list (list 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
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
)
249 diary-entries-list
))))
251 (defun include-other-diary-files ()
252 "Include the diary entries from other diary files with those of diary-file.
253 This function is suitable for use in `list-diary-entries-hook';
254 it enables you to use shared diary files together with your own.
255 The files included are specified in the diaryfile by lines of this form:
256 #include \"filename\"
257 This is recursive; that is, #include directives in diary files thus included
258 are obeyed. You can change the `#include' to some other string by
259 changing the variable `diary-include-string'."
260 (goto-char (point-min))
261 (while (re-search-forward
263 "\\(\\`\\|\^M\\|\n\\)"
264 (regexp-quote diary-include-string
)
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
)
271 (diary-display-hook 'ignore
)
273 (if (file-exists-p diary-file
)
274 (if (file-readable-p diary-file
)
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
)))
281 (message "Can't read included diary file %s" diary-file
)
284 (message "Can't find included diary file %s" diary-file
)
286 (goto-char (point-min)))
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
))) "")))
298 (if (<= (length msg
) (frame-width))
300 (set-buffer (get-buffer-create holiday-buffer
))
301 (setq buffer-read-only nil
)
302 (calendar-set-mode-line date-string
)
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
))
310 (calendar-set-mode-line
311 (concat "Diary for " date-string
312 (if holiday-list
": " "")
313 (mapconcat 'identity holiday-list
"; ")))
314 (display-buffer (get-file-buffer d-file
))
315 (message "Preparing diary...done"))))
317 (defun fancy-diary-display ()
318 "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
319 This function is provided for optional use as the `diary-display-hook'."
320 (if (or (not diary-entries-list
)
321 (and (not (cdr diary-entries-list
))
322 (string-equal (car (cdr (car diary-entries-list
))) "")))
323 (let* ((holiday-list (if holidays-in-diary-buffer
324 (check-calendar-holidays original-date
)))
325 (msg (format "No diary entries for %s %s"
326 (concat date-string
(if holiday-list
":" ""))
327 (mapconcat 'identity holiday-list
"; "))))
328 (if (<= (length msg
) (frame-width))
330 (set-buffer (get-buffer-create holiday-buffer
))
331 (setq buffer-read-only nil
)
332 (calendar-set-mode-line date-string
)
334 (insert (mapconcat 'identity holiday-list
"\n"))
335 (goto-char (point-min))
336 (set-buffer-modified-p nil
)
337 (setq buffer-read-only t
)
338 (display-buffer holiday-buffer
)
339 (message "No diary entries for %s" date-string
)))
340 (save-excursion;; Turn off selective-display in the diary file's buffer.
341 (set-buffer (get-file-buffer (substitute-in-file-name diary-file
)))
342 (let ((diary-modified (buffer-modified-p)))
343 (subst-char-in-region (point-min) (point-max) ?\^M ?
\n t
)
344 (setq selective-display nil
)
345 (kill-local-variable 'mode-line-format
)
346 (set-buffer-modified-p diary-modified
)))
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
)
351 (calendar-set-mode-line "Diary Entries")
353 (let ((entry-list diary-entries-list
)
355 (holiday-list-last-month 1)
356 (holiday-list-last-year 1)
359 (if (not (calendar-date-equal date
(car (car entry-list
))))
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
))
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)
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
))
385 (let ((h holiday-list
)
387 ;; Make a list of all holidays for date.
389 (if (calendar-date-equal date
(car (car h
)))
390 (setq d
(append d
(cdr (car h
)))))
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"))))
409 (defun print-diary-entries ()
410 "Print a hard copy of the diary display.
412 If the simple diary display is being used, prepare a temp buffer with the
413 visible lines of the diary buffer, add a heading line composed from the mode
414 line, print the temp buffer, and destroy it.
416 If the fancy diary display is being used, just print the buffer.
418 The hooks given by the variable `print-diary-entries-hook' are called to do
419 the actual printing."
421 (if (bufferp (get-buffer fancy-diary-buffer
))
423 (set-buffer (get-buffer fancy-diary-buffer
))
424 (run-hooks 'print-diary-entries-hook
))
426 (get-file-buffer (substitute-in-file-name diary-file
))))
428 (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))
431 (set-buffer diary-buffer
)
433 (if (not (stringp mode-line-format
))
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
)
442 (goto-char (point-min))
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!")))))
449 (defun show-all-diary-entries ()
450 "Show all of the diary entries in the diary file.
451 This function gets rid of the selective display of the diary file so that
452 all entries, not just some, are visible. If there is no diary buffer, one
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
)
459 (let ((diary-buffer (get-file-buffer d-file
)))
460 (set-buffer (if 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
)
468 (setq mode-line-format default-mode-line-format
)
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!"))))
474 (defun diary-name-pattern (string-array &optional fullname
)
475 "Convert an STRING-ARRAY, an array of strings to a pattern.
476 The pattern will match any of the strings, either entirely or abbreviated
477 to three characters. An abbreviated form will match with or without a period;
478 If the optional FULLNAME is t, abbreviations will not match, just the full
481 (calendar-for-loop i from
0 to
(1- (length string-array
)) do
485 (if (string-equal pattern
"") "" "\\|")
486 (aref string-array i
)
491 (substring (aref string-array i
) 0 3) ".?")))))
494 (defun mark-diary-entries ()
495 "Mark days in the calendar window that have diary entries.
496 Each entry in the diary file visible in the calendar window is marked.
497 After the entries are marked, the hooks `nongregorian-diary-marking-hook' and
498 `mark-diary-entries-hook' are run."
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
)
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
)
513 ((date-form (if (equal (car (car d
)) 'backup
)
515 (car d
)));; ignore 'backup directive
516 (dayname (diary-name-pattern calendar-day-name-array
))
519 (diary-name-pattern calendar-month-name-array
)
521 (month "[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
)))
537 "\\(\\`\\|\^M\\|\n\\)\\("
538 (mapconcat 'eval date-form
"\\)\\(")
540 (case-fold-search t
))
541 (goto-char (point-min))
542 (while (re-search-forward regexp nil t
)
546 (match-beginning d-name-pos
)
547 (match-end d-name-pos
))))
551 (match-beginning m-name-pos
)
552 (match-end m-name-pos
))))
556 (match-beginning m-pos
)
562 (match-beginning d-pos
)
567 (match-beginning y-pos
)
571 (if (and (= (length y-str
) 2)
572 abbreviated-calendar-year
)
574 (extract-calendar-year
575 (calendar-current-date)))
576 (y (+ (string-to-int y-str
)
578 (/ current-y
100)))))
579 (if (> (- y current-y
) 50)
581 (if (> (- current-y y
) 50)
584 (string-to-int y-str
)))))
586 (mark-calendar-days-named
587 (cdr (assoc (capitalize (substring dd-name
0 3))
589 calendar-day-name-array
591 '(lambda (x) (substring x
0 3))))))
593 (if (string-equal mm-name
"*")
598 (substring mm-name
0 3))
600 calendar-month-name-array
602 '(lambda (x) (substring x
0 3)))
604 (mark-calendar-date-pattern mm dd yy
))))
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!"))))
614 (defun mark-sexp-diary-entries ()
615 "Mark days in the calendar window that have sexp diary entries.
616 Each entry in the diary file (or included files) visible in the calendar window
617 is 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
"("))
625 (set-buffer calendar-buffer
)
626 (setq m displayed-month
)
627 (setq y displayed-year
))
628 (increment-calendar-month m y -
1)
630 (calendar-absolute-from-gregorian (list m
1 y
)))
631 (increment-calendar-month m y
2)
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
)
638 (let ((sexp-start (point))
644 (setq sexp
(buffer-substring sexp-start
(point)))
646 (re-search-backward "\^M\\|\n\\|\\`")
647 (setq line-start
(point)))
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
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
))
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
))))))))
669 (defun mark-included-diary-files ()
670 "Mark the diary entries from other diary files with those of the diary file.
671 This function is suitable for use as the `mark-diary-entries-hook'; it enables
672 you to use shared diary files together with your own. The files included are
673 specified in the diary-file by lines of this form:
674 #include \"filename\"
675 This is recursive; that is, #include directives in diary files thus included
676 are obeyed. You can change the `#include' to some other string by
677 changing the variable `diary-include-string'."
678 (goto-char (point-min))
679 (while (re-search-forward
681 "\\(\\`\\|\^M\\|\n\\)"
682 (regexp-quote diary-include-string
)
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
)
692 (kill-buffer (get-file-buffer diary-file
)))
694 (message "Can't read included diary file %s" diary-file
)
697 (message "Can't find included diary file %s" diary-file
)
699 (goto-char (point-min)))
701 (defun mark-calendar-days-named (dayname)
702 "Mark all dates in the calendar window that are day DAYNAME of the week.
703 0 means all Sundays, 1 means all Mondays, and so on."
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
)
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))))))
722 (defun mark-calendar-date-pattern (month day year
)
723 "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
724 A value of 0 in any position is a wildcard."
726 (set-buffer calendar-buffer
)
727 (let ((m displayed-month
)
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)))))
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.
736 A value of 0 in any position of the pattern is a wildcard."
737 (if (or (and (= month p-month
)
738 (or (= p-year
0) (= year p-year
)))
740 (or (= p-year
0) (= year p-year
))))
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
)))))
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
)))
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
)))))))
758 (defun diary-entry-time (s)
759 "Time at the beginning of the string S in a military-style integer.
760 For example, returns 1325 for 1:25pm. Returns -9999 if no time is recognized.
761 The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm,
762 and 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)))
773 (if (string-equal "a"
774 (substring s
(match-beginning 2) (match-end 2)))
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)))
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)))
785 (t -
9999)));; Unrecognizable
787 (defun list-hebrew-diary-entries ()
788 "Add any Hebrew date entries from the diary file to `diary-entries-list'.
789 Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol'
790 (normally an `H'). The same diary date forms govern the style of the Hebrew
791 calendar entries, except that the Hebrew month names must be spelled in full.
792 The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
793 Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
794 common Hebrew year. If a Hebrew date diary entry begins with a
795 `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
796 not be marked in the calendar. This function is provided for use with the
797 `nongregorian-diary-listing-hook'."
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
)))
812 ((date-form (if (equal (car (car d
)) 'backup
)
815 (backup (equal (car (car d
)) 'backup
))
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
)
825 (calendar-month-name month
)))
826 (month (concat "\\*\\|0*" (int-to-string month
)))
827 (day (concat "\\*\\|0*" (int-to-string day
)))
830 "\\*\\|0*" (int-to-string year
)
831 (if abbreviated-calendar-year
832 (concat "\\|" (int-to-string (% year
100)))
836 "\\(\\`\\|\^M\\|\n\\)" mark
"?"
837 (regexp-quote hebrew-diary-entry-symbol
)
839 (mapconcat 'eval date-form
"\\)\\(")
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.
850 ;; Found a nonempty diary entry--make it visible and
851 ;; add it to the list.
852 (let ((entry-start (point))
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
))
860 (subst-char-in-region date-start
(point) ?\^M ?
\n t
)
862 gdate
(buffer-substring entry-start
(point)))))))
865 (calendar-gregorian-from-absolute
866 (1+ (calendar-absolute-from-gregorian gdate
)))))
867 (set-buffer-modified-p diary-modified
))
868 (goto-char (point-min))))
870 (defun mark-hebrew-diary-entries ()
871 "Mark days in the calendar window that have Hebrew date diary entries.
872 Each entry in diary-file (or included files) visible in the calendar window
873 is marked. Hebrew date entries are prefaced by a hebrew-diary-entry-symbol
874 (normally an `H'). The same diary-date-forms govern the style of the Hebrew
875 calendar entries, except that the Hebrew month names must be spelled in full.
876 The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
877 Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
878 common Hebrew year. Hebrew date diary entries that begin with a
879 diary-nonmarking symbol will not be marked in the calendar. This function
880 is provided for use as part of the nongregorian-diary-marking-hook."
881 (let ((d diary-date-forms
))
884 ((date-form (if (equal (car (car d
)) 'backup
)
886 (car d
)));; ignore 'backup directive
887 (dayname (diary-name-pattern calendar-day-name-array
))
890 (diary-name-pattern calendar-hebrew-month-name-array-leap-year t
)
892 (month "[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
)))
908 "\\(\\`\\|\^M\\|\n\\)"
909 (regexp-quote hebrew-diary-entry-symbol
)
911 (mapconcat 'eval date-form
"\\)\\(")
913 (case-fold-search t
))
914 (goto-char (point-min))
915 (while (re-search-forward regexp nil t
)
919 (match-beginning d-name-pos
)
920 (match-end d-name-pos
))))
924 (match-beginning m-name-pos
)
925 (match-end m-name-pos
))))
929 (match-beginning m-pos
)
935 (match-beginning d-pos
)
940 (match-beginning y-pos
)
944 (if (and (= (length y-str
) 2)
945 abbreviated-calendar-year
)
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)
955 (if (> (- current-y y
) 50)
958 (string-to-int y-str
)))))
960 (mark-calendar-days-named
961 (cdr (assoc (capitalize (substring dd-name
0 3))
963 calendar-day-name-array
965 '(lambda (x) (substring x
0 3))))))
967 (if (string-equal mm-name
"*")
975 calendar-hebrew-month-name-array-leap-year
))))))
976 (mark-hebrew-calendar-date-pattern mm dd yy
)))))
979 (defun mark-hebrew-calendar-date-pattern (month day year
)
980 "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR.
981 A value of 0 in any position is a wildcard."
983 (set-buffer calendar-buffer
)
984 (if (and (/= 0 month
) (/= 0 day
))
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
)
1002 (m2 displayed-month
)
1005 (increment-calendar-month m1 y1 -
1)
1006 (increment-calendar-month m2 y2
1)
1007 (let* ((start-date (calendar-absolute-from-gregorian
1009 (end-date (calendar-absolute-from-gregorian
1011 (calendar-last-day-of-month m2 y2
)
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
)
1031 (increment-calendar-month m y -
1)
1033 (calendar-absolute-from-gregorian
1035 (increment-calendar-month m y
2)
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
)
1050 (mark-visible-calendar-date
1051 (calendar-gregorian-from-absolute date
)))))))))
1053 (defun list-sexp-diary-entries (date)
1054 "Add sexp entries for DATE from the diary file to `diary-entries-list'.
1055 Also, Make them visible in the diary file. Returns t if any entries were
1058 Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally
1059 `%%'). The form of a sexp diary entry is
1063 Both ENTRY and DATE are globally available when the SEXP is evaluated. If the
1064 SEXP yields the value nil, the diary entry does not apply. If it yields a
1065 non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a
1066 string, that string will be the diary entry in the fancy diary display.
1068 For example, the following diary entry will apply to the 21st of the month
1069 if it is a weekday and the Friday before if the 21st is on a weekend:
1071 &%%(let ((dayname (calendar-day-of-week date))
1072 (day (extract-calendar-day date)))
1074 (and (= day 21) (memq dayname '(1 2 3 4 5)))
1075 (and (memq day '(19 20)) (= dayname 5)))
1076 ) UIUC pay checks deposited
1078 A number of built-in functions are available for this type of diary entry:
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.
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,
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.
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.
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.
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.
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.
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.
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.
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.
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
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.
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.
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.)
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.
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.
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.
1182 Marking these entries is *extremely* time consuming, so these entries are
1183 best 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
"("))
1188 (goto-char (point-min))
1189 (while (re-search-forward s-entry nil t
)
1191 (let ((sexp-start (point))
1197 (setq sexp
(buffer-substring sexp-start
(point)))
1199 (re-search-backward "\^M\\|\n\\|\\`")
1200 (setq line-start
(point)))
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
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
))
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
)))
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
)))))
1223 (defun diary-sexp-entry (sexp entry date
)
1224 "Process a SEXP diary ENTRY for DATE."
1225 (let ((result (if calendar-debug-sexp
1226 (let ((stack-trace-on-error t
))
1227 (eval (car (read-from-string sexp
))))
1229 (eval (car (read-from-string sexp
)))
1232 (message "Bad sexp at line %d in %s: %s"
1235 (narrow-to-region 1 (point))
1236 (goto-char (point-min))
1238 (while (re-search-forward "\n\\|\^M" nil t
)
1239 (setq lines
(1+ lines
)))
1243 (if (stringp result
)
1249 (defun diary-block (m1 d1 y1 m2 d2 y2
)
1251 Entry applies if date is between two dates. Order of the parameters is
1252 M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and
1253 D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t."
1254 (let ((date1 (calendar-absolute-from-gregorian
1255 (if european-calendar-style
1258 (date2 (calendar-absolute-from-gregorian
1259 (if european-calendar-style
1262 (d (calendar-absolute-from-gregorian date
)))
1263 (if (and (<= date1 d
) (<= d date2
))
1266 (defun diary-float (month dayname n
)
1267 "Floating diary entry--entry applies if date is the nth dayname of month.
1268 Parameters are MONTH, DAYNAME, N. MONTH can be a list of months, the constant
1269 t, or an integer. The constant t means all months. If N is negative, count
1270 backward from the end of the month."
1271 (let ((m (extract-calendar-month date
))
1272 (y (extract-calendar-year date
)))
1274 (or (and (listp month
) (memq m month
))
1277 (calendar-date-equal date
(calendar-nth-named-day n dayname m y
)))
1280 (defun diary-anniversary (month day year
)
1281 "Anniversary diary entry.
1282 Entry 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
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
1288 to be March 1 in non-leap years."
1289 (let* ((d (if european-calendar-style
1292 (m (if european-calendar-style
1295 (y (extract-calendar-year date
))
1297 (if (and (= m
2) (= d
29) (not (calendar-leap-year-p y
)))
1300 (if (and (> diff
0) (calendar-date-equal (list m d y
) date
))
1301 (format entry diff
(diary-ordinal-suffix diff
)))))
1303 (defun diary-cyclic (n month day year
)
1304 "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
1305 If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
1306 ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
1307 years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal
1308 ending of that number (that is, `st', `nd', `rd' or `th', as appropriate."
1309 (let* ((d (if european-calendar-style
1312 (m (if european-calendar-style
1315 (diff (- (calendar-absolute-from-gregorian date
)
1316 (calendar-absolute-from-gregorian
1319 (if (and (>= diff
0) (zerop (% diff n
)))
1320 (format entry cycle
(diary-ordinal-suffix cycle
)))))
1322 (defun diary-ordinal-suffix (n)
1323 "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
1324 (if (or (memq (% n
100) '(11 12 13))
1327 (aref ["th" "st" "nd" "rd"] (% n
10))))
1329 (defun diary-day-of-year ()
1330 "Day of year and number of days remaining in the year of date diary entry."
1331 (calendar-day-of-year-string date
))
1333 (defun diary-iso-date ()
1334 "ISO calendar equivalent of date diary entry."
1335 (format "ISO date: %s" (calendar-iso-date-string date
)))
1337 (defun diary-islamic-date ()
1338 "Islamic calendar equivalent of date diary entry."
1339 (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t
))))
1340 (if (string-equal i
"")
1341 "Date is pre-Islamic"
1342 (format "Islamic date (until sunset): %s" i
))))
1344 (defun diary-hebrew-date ()
1345 "Hebrew calendar equivalent of date diary entry."
1346 (format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date
)))
1348 (defun diary-julian-date ()
1349 "Julian calendar equivalent of date diary entry."
1350 (format "Julian date: %s" (calendar-julian-date-string date
)))
1352 (defun diary-astro-day-number ()
1353 "Astronomical (Julian) day number diary entry."
1354 (format "Astronomical (Julian) day number %s"
1355 (calendar-astro-date-string date
)))
1357 (defun diary-omer ()
1358 "Omer count diary entry.
1359 Entry applies if date is within 50 days after Passover."
1361 (calendar-absolute-from-hebrew
1362 (list 1 15 (+ (extract-calendar-year date
) 3760))))
1363 (omer (- (calendar-absolute-from-gregorian date
) passover
))
1366 (if (and (> omer
0) (< omer
50))
1367 (format "Day %d%s of the omer (until sunset)"
1371 (format ", that is, %d week%s%s"
1373 (if (= week
1) "" "s")
1376 (format " and %d day%s"
1377 day
(if (= day
1) "" "s")))))))))
1379 (defun diary-yahrzeit (death-month death-day death-year
)
1380 "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.
1381 Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed
1382 to be the name of the person. Date of death is on the *civil* calendar;
1383 although the date of death is specified by the civil calendar, the proper
1384 Hebrew calendar yahrzeit is determined. If `european-calendar-style' is t, the
1385 order 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"
1401 (if (= y d
) "" " (evening)")
1403 (cond ((= (% diff
10) 1) "st")
1404 ((= (% diff
10) 2) "nd")
1405 ((= (% diff
10) 3) "rd")
1408 (defun diary-rosh-hodesh ()
1409 "Rosh Hodesh diary entry.
1410 Entry applies if date is Rosh Hodesh, the day before, or the Saturday before."
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
))
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)))
1431 ;; next month must be in the same year since this
1432 ;; month can't be the last month of the year since
1434 (aref h-month-names h-month
))
1435 (if (= h-yesterday
30)
1436 (format "%s (second day)" this-month
)
1438 (if (= (% d
7) 6);; Saturday--check for Shabbat Mevarhim
1439 (cond ((and (> h-day
22) (/= h-month
6) (= 29 last-day
))
1440 (format "Mevarhim Rosh Hodesh %s (%s)"
1443 (hebrew-calendar-last-month-of-year
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
)
1452 (aref calendar-day-name-array
(- 29 h-day
)))
1453 (aref calendar-day-name-array
1454 (%
(- 30 h-day
) 7)))))
1455 (if (and (= h-day
29) (/= h-month
6))
1456 (format "Erev Rosh Hodesh %s"
1459 (hebrew-calendar-last-month-of-year
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
1468 ((h-year (extract-calendar-year
1469 (calendar-hebrew-from-absolute d
)))
1471 (calendar-absolute-from-hebrew (list 7 1 h-year
)))
1473 (calendar-absolute-from-hebrew (list 1 15 h-year
)))
1475 (aref calendar-day-name-array
(% rosh-hashannah
7)))
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")
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
)))
1495 (if (listp parasha
);; Israel differs from diaspora
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
))))))))
1504 (defun add-to-diary-list (date string
)
1505 "Add the entry (DATE STRING) to `diary-entries-list'.
1506 Do nothing if DATE or STRING is nil."
1508 (setq diary-entries-list
1509 (append diary-entries-list
(list (list date string
))))))
1511 (defvar hebrew-calendar-parashiot-names
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.")
1523 ;; The seven ordinary year types (keviot)
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]
1529 "The structure of the parashiot.
1530 Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have
1531 29 days), and has Passover start on Sunday.")
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]]
1537 "The structure of the parashiot.
1538 Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
1539 have 30 days), and has Passover start on Tuesday.")
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]]
1545 "The structure of the parashiot.
1546 Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
1547 have 29 days), and has Passover start on Tuesday.")
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]
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]]
1553 "The structure of the parashiot.
1554 Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
1555 30 days), and has Passover start on Thursday.")
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]
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]]
1561 "The structure of the parashiot.
1562 Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
1563 Kislev has 30 days), and has Passover start on Thursday.")
1565 (defconst hebrew-calendar-year-Thursday-regular-Saturday
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
1570 "The structure of the parashiot.
1571 Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and
1572 Kislev has 30 days), and has Passover start on Saturday.")
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]
1578 "The structure of the parashiot.
1579 Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each
1580 have 30 days), and has Passover start on Sunday.")
1582 ;; The seven leap year types (keviot)
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]]
1588 "The structure of the parashiot.
1589 Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each
1590 have 29 days), and has Passover start on Tuesday.")
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
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]]
1596 "The structure of the parashiot.
1597 Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
1598 have 30 days), and has Passover start on Thursday.")
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
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]]
1604 "The structure of the parashiot.
1605 Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
1606 have 29 days), and has Passover start on Thursday.")
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
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]
1613 "The structure of the parashiot.
1614 Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
1615 30 days), and has Passover start on Saturday.")
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
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]
1622 "The structure of the parashiot.
1623 Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
1624 Kislev has 30 days), and has Passover start on Saturday.")
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]
1630 "The structure of the parashiot.
1631 Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both
1632 have 29 days), and has Passover start on Sunday.")
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]]
1638 "The structure of the parashiot.
1639 Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
1640 have 30 days), and has Passover start on Tuesday.")
1642 (defun hebrew-calendar-parasha-name (p)
1643 "Name(s) corresponding to parasha P."
1644 (if (arrayp p
);; combined parasha
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
)))
1650 (defun list-islamic-diary-entries ()
1651 "Add any Islamic date entries from the diary file to `diary-entries-list'.
1652 Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol'
1653 (normally an `I'). The same diary date forms govern the style of the Islamic
1654 calendar entries, except that the Islamic month names must be spelled in full.
1655 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
1656 Dhu al-Hijjah. If an Islamic date diary entry begins with a
1657 `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
1658 not be marked in the calendar. This function is provided for use with the
1659 `nongregorian-diary-listing-hook'."
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
)))
1674 ((date-form (if (equal (car (car d
)) 'backup
)
1677 (backup (equal (car (car d
)) 'backup
))
1680 (calendar-day-name gdate
) "\\|"
1681 (substring (calendar-day-name gdate
) 0 3) ".?"))
1682 (calendar-month-name-array
1683 calendar-islamic-month-name-array
)
1687 (calendar-month-name month
)))
1688 (month (concat "\\*\\|0*" (int-to-string month
)))
1689 (day (concat "\\*\\|0*" (int-to-string day
)))
1692 "\\*\\|0*" (int-to-string year
)
1693 (if abbreviated-calendar-year
1694 (concat "\\|" (int-to-string (% year
100)))
1698 "\\(\\`\\|\^M\\|\n\\)" mark
"?"
1699 (regexp-quote islamic-diary-entry-symbol
)
1701 (mapconcat 'eval date-form
"\\)\\(")
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.
1712 ;; Found a nonempty diary entry--make it visible and
1713 ;; add it to the list.
1714 (let ((entry-start (point))
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
))
1722 (subst-char-in-region date-start
(point) ?\^M ?
\n t
)
1724 gdate
(buffer-substring entry-start
(point)))))))
1727 (calendar-gregorian-from-absolute
1728 (1+ (calendar-absolute-from-gregorian gdate
)))))
1729 (set-buffer-modified-p diary-modified
))
1730 (goto-char (point-min))))
1732 (defun mark-islamic-diary-entries ()
1733 "Mark days in the calendar window that have Islamic date diary entries.
1734 Each entry in diary-file (or included files) visible in the calendar window
1735 is marked. Islamic date entries are prefaced by a islamic-diary-entry-symbol
1736 (normally an `I'). The same diary-date-forms govern the style of the Islamic
1737 calendar entries, except that the Islamic month names must be spelled in full.
1738 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
1739 Dhu al-Hijjah. Islamic date diary entries that begin with a
1740 diary-nonmarking-symbol will not be marked in the calendar. This function is
1741 provided for use as part of the nongregorian-diary-marking-hook."
1742 (let ((d diary-date-forms
))
1745 ((date-form (if (equal (car (car d
)) 'backup
)
1747 (car d
)));; ignore 'backup directive
1748 (dayname (diary-name-pattern calendar-day-name-array
))
1751 (diary-name-pattern calendar-islamic-month-name-array t
)
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
)))
1769 "\\(\\`\\|\^M\\|\n\\)"
1770 (regexp-quote islamic-diary-entry-symbol
)
1772 (mapconcat 'eval date-form
"\\)\\(")
1774 (case-fold-search t
))
1775 (goto-char (point-min))
1776 (while (re-search-forward regexp nil t
)
1780 (match-beginning d-name-pos
)
1781 (match-end d-name-pos
))))
1785 (match-beginning m-name-pos
)
1786 (match-end m-name-pos
))))
1790 (match-beginning m-pos
)
1796 (match-beginning d-pos
)
1801 (match-beginning y-pos
)
1802 (match-end y-pos
))))
1805 (if (and (= (length y-str
) 2)
1806 abbreviated-calendar-year
)
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)
1816 (if (> (- current-y y
) 50)
1819 (string-to-int y-str
)))))
1821 (mark-calendar-days-named
1822 (cdr (assoc (capitalize (substring dd-name
0 3))
1823 (calendar-make-alist
1824 calendar-day-name-array
1826 '(lambda (x) (substring x
0 3))))))
1828 (if (string-equal mm-name
"*")
1832 (capitalize mm-name
)
1833 (calendar-make-alist
1834 calendar-islamic-month-name-array
))))))
1835 (mark-islamic-calendar-date-pattern mm dd yy
)))))
1838 (defun mark-islamic-calendar-date-pattern (month day year
)
1839 "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.
1840 A value of 0 in any position is a wildcard."
1842 (set-buffer calendar-buffer
)
1843 (if (and (/= 0 month
) (/= 0 day
))
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
))
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
)
1874 (increment-calendar-month m y -
1)
1876 (calendar-absolute-from-gregorian
1878 (increment-calendar-month m y
2)
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
)
1893 (mark-visible-calendar-date
1894 (calendar-gregorian-from-absolute date
)))))))))
1898 ;;; diary.el ends here