1 ;;; diary.el --- diary functions.
3 ;; Copyright (C) 1989, 1990 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 distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY. No author or distributor
12 ;; accepts responsibility to anyone for the consequences of using it
13 ;; or for whether it serves any particular purpose or works at all,
14 ;; unless he says so in writing. Refer to the GNU Emacs General Public
15 ;; License for full details.
17 ;; Everyone is granted permission to copy, modify and redistribute
18 ;; GNU Emacs, but only under the conditions described in the
19 ;; GNU Emacs General Public License. A copy of this license is
20 ;; supposed to have been given to you along with GNU Emacs so you
21 ;; can know your rights and responsibilities. It should be in a
22 ;; file named COPYING. Among other things, the copyright notice
23 ;; and this notice must be preserved on all copies.
27 ;; This collection of functions implements the diary features as described
30 ;; Comments, corrections, and improvements should be sent to
31 ;; Edward M. Reingold Department of Computer Science
32 ;; (217) 333-6733 University of Illinois at Urbana-Champaign
33 ;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
34 ;; Urbana, Illinois 61801
41 (defun diary (&optional arg
)
42 "Generate the diary window for ARG days starting with the current date.
43 If no argument is provided, the number of days of diary entries is governed
44 by the variable `number-of-diary-entries'. This function is suitable for
45 execution in a .emacs file."
47 (let ((d-file (substitute-in-file-name diary-file
))
48 (date (calendar-current-date)))
49 (if (and d-file
(file-exists-p d-file
))
50 (if (file-readable-p d-file
)
54 (arg (prefix-numeric-value arg
))
55 ((vectorp number-of-diary-entries
)
56 (aref number-of-diary-entries
(calendar-day-of-week date
)))
57 (t number-of-diary-entries
)))
58 (error "Your diary file is not readable!"))
59 (error "You don't have a diary file!"))))
61 (defun view-diary-entries (arg)
62 "Prepare and display a buffer with diary entries.
63 Searches the file diary-file for entries that match ARG days starting with
64 the date indicated by the cursor position in the displayed three-month
67 (let ((d-file (substitute-in-file-name diary-file
)))
68 (if (and d-file
(file-exists-p d-file
))
69 (if (file-readable-p d-file
)
70 (list-diary-entries (or (calendar-cursor-to-date)
71 (error "Cursor is not on a date!"))
73 (error "Your diary file is not readable!"))
74 (error "You don't have a diary file!"))))
76 (autoload 'check-calendar-holidays
"holidays"
77 "Check the list of holidays for any that occur on DATE.
78 The value returned is a list of strings of relevant holiday descriptions.
79 The holidays are those in the list calendar-holidays.")
81 (autoload 'calendar-holiday-list
"holidays"
82 "Form the list of holidays that occur on dates in the calendar window.
83 The holidays are those in the list calendar-holidays.")
85 (defvar diary-syntax-table
86 (standard-syntax-table)
87 "The syntax table used when parsing dates in the diary file.
88 It is the standard syntax table used in Fundamental mode, but with the
89 syntax of `*' changed to be a word constituent.")
91 (modify-syntax-entry ?
* "w" diary-syntax-table
)
93 (defun list-diary-entries (date number
)
94 "Create and display a buffer containing the relevant lines in diary-file.
95 All lines that apply to DATE and the next NUMBER-1 days are included.
97 Makes all diary entries in the diary file invisible (using selective display),
98 *except* those that are relevant.
100 Returns a list of all relevant diary entries found, if any, in order by date.
101 The list entries have the form ((month day year) string). If the variable
102 `diary-list-include-blanks' is t, this list will include a dummy diary entry
103 \(consisting of the empty string\) for a date with no diary entries.
105 After the list is prepared, the hooks `nongregorian-diary-listing-hook',
106 `list-diary-entries-hook', and `diary-display-hook' are run. These hooks
107 have the following distinct roles:
109 `nongregorian-diary-listing-hook' can cull dates from the diary
110 and each included file. Usually used for Hebrew or Islamic
111 diary entries in files. Applied to *each* file.
113 `list-diary-entries-hook' adds or manipulates diary entries from
114 external sources. Used, for example, to include diary entries
115 from other files or to sort the diary entries. Invoked *once* only.
117 `diary-display-hook' does the actual display of information. Could be
118 used also for an appointment notification function."
121 (let* ((original-date date
);; save for possible use in the hooks
122 (old-diary-syntax-table)
124 (date-string (calendar-date-string date
))
125 (d-file (substitute-in-file-name diary-file
)))
126 (message "Preparing diary...")
128 (let ((diary-buffer (get-file-buffer d-file
)))
129 (set-buffer (if diary-buffer
131 (find-file-noselect d-file t
))))
132 (setq selective-display t
)
133 (setq selective-display-ellipses nil
)
134 (setq old-diary-syntax-table
(syntax-table))
135 (set-syntax-table diary-syntax-table
)
137 (let ((buffer-read-only nil
)
138 (diary-modified (buffer-modified-p))
139 (mark (regexp-quote diary-nonmarking-symbol
)))
140 (goto-char (1- (point-max)))
141 (if (not (looking-at "\^M\\|\n"))
144 (insert-string "\^M")))
145 (goto-char (point-min))
146 (if (not (looking-at "\^M\\|\n"))
147 (insert-string "\^M"))
148 (subst-char-in-region (point-min) (point-max) ?
\n ?\^M t
)
149 (calendar-for-loop i from
1 to number do
150 (let ((d diary-date-forms
)
151 (month (extract-calendar-month date
))
152 (day (extract-calendar-day date
))
153 (year (extract-calendar-year date
))
154 (entry-found (list-sexp-diary-entries date
)))
157 ((date-form (if (equal (car (car d
)) 'backup
)
160 (backup (equal (car (car d
)) 'backup
))
163 (calendar-day-name date
) "\\|"
164 (substring (calendar-day-name date
) 0 3) ".?"))
168 (calendar-month-name month
) "\\|"
169 (substring (calendar-month-name month
) 0 3) ".?"))
170 (month (concat "\\*\\|0*" (int-to-string month
)))
171 (day (concat "\\*\\|0*" (int-to-string day
)))
174 "\\*\\|0*" (int-to-string year
)
175 (if abbreviated-calendar-year
176 (concat "\\|" (int-to-string (% year
100)))
180 "\\(\\`\\|\^M\\|\n\\)" mark
"?\\("
181 (mapconcat 'eval date-form
"\\)\\(")
183 (case-fold-search t
))
184 (goto-char (point-min))
185 (while (re-search-forward regexp nil t
)
186 (if backup
(re-search-backward "\\<" nil t
))
187 (if (and (or (char-equal (preceding-char) ?\^M
)
188 (char-equal (preceding-char) ?
\n))
189 (not (looking-at " \\|\^I")))
190 ;; Diary entry that consists only of date.
192 ;; Found a nonempty diary entry--make it visible and
193 ;; add it to the list.
195 (let ((entry-start (point))
197 (re-search-backward "\^M\\|\n\\|\\`")
198 (setq date-start
(point))
199 (re-search-forward "\^M\\|\n" nil t
2)
200 (while (looking-at " \\|\^I")
201 (re-search-forward "\^M\\|\n" nil t
))
203 (subst-char-in-region date-start
206 date
(buffer-substring entry-start
(point)))))))
209 (not diary-list-include-blanks
)
210 (setq diary-entries-list
211 (append diary-entries-list
212 (list (list date
"")))))
214 (calendar-gregorian-from-absolute
215 (1+ (calendar-absolute-from-gregorian date
))))
216 (setq entry-found nil
)))
217 (set-buffer-modified-p diary-modified
))
218 (set-syntax-table old-diary-syntax-table
))
219 (goto-char (point-min))
220 (run-hooks 'nongregorian-diary-listing-hook
221 'list-diary-entries-hook
223 diary-entries-list
))))
225 (defun include-other-diary-files ()
226 "Include the diary entries from other diary files with those of diary-file.
227 This function is suitable for use just before fancy-diary-display as the
228 list-diary-entries-hook; it enables you to use shared diary files together
229 with your own. The files included are specified in the diary-file by lines of
231 #include \"filename\"
232 This is recursive; that is, #include directives in diary files thus included
233 are obeyed. You can change the \"#include\" to some other string by
234 changing the variable `diary-include-string'."
235 (goto-char (point-min))
236 (while (re-search-forward
238 "\\(\\`\\|\^M\\|\n\\)"
239 (regexp-quote diary-include-string
)
242 (let ((diary-file (substitute-in-file-name
243 (buffer-substring (match-beginning 2) (match-end 2))))
244 (diary-list-include-blanks nil
)
245 (list-diary-entries-hook 'include-other-diary-files
)
246 (diary-display-hook nil
))
247 (if (file-exists-p diary-file
)
248 (if (file-readable-p diary-file
)
250 (setq diary-entries-list
251 (append diary-entries-list
252 (list-diary-entries original-date number
)))
253 (kill-buffer (get-file-buffer diary-file
)))
255 (message "Can't read included diary file %s" diary-file
)
258 (message "Can't find included diary file %s" diary-file
)
260 (goto-char (point-min)))
262 (defun simple-diary-display ()
263 "Display the diary buffer if there are any relevant entries or holidays."
264 (let* ((holiday-list (if holidays-in-diary-buffer
265 (check-calendar-holidays original-date
)))
266 (msg (format "No diary entries for %s %s"
267 (concat date-string
(if holiday-list
":" ""))
268 (mapconcat 'identity holiday-list
"; "))))
269 (if (or (not diary-entries-list
)
270 (and (not (cdr diary-entries-list
))
271 (string-equal (car (cdr (car diary-entries-list
))) "")))
272 (if (<= (length msg
) (frame-width))
274 (set-buffer (get-buffer-create holiday-buffer
))
275 (setq buffer-read-only nil
)
276 (setq mode-line-format
277 (format "--------------------------%s%%-" date-string
))
279 (insert (mapconcat 'identity holiday-list
"\n"))
280 (goto-char (point-min))
281 (set-buffer-modified-p nil
)
282 (setq buffer-read-only t
)
283 (display-buffer holiday-buffer
)
284 (message "No diary entries for %s" date-string
))
285 (setq mode-line-format
286 (format "%%*--%sDiary %s %s%s%s%%-"
287 (if holiday-list
"" "---------------")
288 (if holiday-list
"for" "entries for")
290 (if holiday-list
": " "")
291 (mapconcat 'identity holiday-list
"; ")))
292 (display-buffer (get-file-buffer d-file
))
293 (message "Preparing diary...done"))))
295 (defun fancy-diary-display ()
296 "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
297 This function is provided for optional use as the `list-diary-entries-hook'."
298 (if (or (not diary-entries-list
)
299 (and (not (cdr diary-entries-list
))
300 (string-equal (car (cdr (car diary-entries-list
))) "")))
301 (let* ((holiday-list (if holidays-in-diary-buffer
302 (check-calendar-holidays original-date
)))
303 (msg (format "No diary entries for %s %s"
304 (concat date-string
(if holiday-list
":" ""))
305 (mapconcat 'identity holiday-list
"; "))))
306 (if (<= (length msg
) (frame-width))
308 (set-buffer (get-buffer-create holiday-buffer
))
309 (setq buffer-read-only nil
)
310 (setq mode-line-format
311 (format "--------------------------%s%%-" date-string
))
313 (insert (mapconcat 'identity holiday-list
"\n"))
314 (goto-char (point-min))
315 (set-buffer-modified-p nil
)
316 (setq buffer-read-only t
)
317 (display-buffer holiday-buffer
)
318 (message "No diary entries for %s" date-string
)))
319 (save-excursion;; Turn off selective-display in the diary file's buffer.
320 (set-buffer (get-file-buffer (substitute-in-file-name diary-file
)))
321 (let ((diary-modified (buffer-modified-p)))
322 (subst-char-in-region (point-min) (point-max) ?\^M ?
\n t
)
323 (setq selective-display nil
)
324 (kill-local-variable 'mode-line-format
)
325 (set-buffer-modified-p diary-modified
)))
326 (save-excursion;; Prepare the fancy diary buffer.
327 (set-buffer (get-buffer-create fancy-diary-buffer
))
328 (setq buffer-read-only nil
)
329 (make-local-variable 'mode-line-format
)
330 (setq mode-line-format
"---------------------------Diary Entries%-")
332 (let ((entry-list diary-entries-list
)
334 (holiday-list-last-month 1)
335 (holiday-list-last-year 1)
338 (if (not (calendar-date-equal date
(car (car entry-list
))))
340 (setq date
(car (car entry-list
)))
341 (and holidays-in-diary-buffer
342 (calendar-date-compare
343 (list (list holiday-list-last-month
344 (calendar-last-day-of-month
345 holiday-list-last-month
346 holiday-list-last-year
)
347 holiday-list-last-year
))
349 ;; We need to get the holidays for the next 3 months.
350 (setq holiday-list-last-month
351 (extract-calendar-month date
))
352 (setq holiday-list-last-year
353 (extract-calendar-year date
))
354 (increment-calendar-month
355 holiday-list-last-month holiday-list-last-year
1)
357 (let ((displayed-month holiday-list-last-month
)
358 (displayed-year holiday-list-last-year
))
359 (calendar-holiday-list)))
360 (increment-calendar-month
361 holiday-list-last-month holiday-list-last-year
1))
362 (let* ((date-string (calendar-date-string date
))
364 (let ((h holiday-list
)
366 ;; Make a list of all holidays for date.
368 (if (calendar-date-equal date
(car (car h
)))
369 (setq d
(append d
(cdr (car h
)))))
372 (insert (if (= (point) (point-min)) "" ?
\n) date-string
)
373 (if date-holiday-list
(insert ": "))
374 (let ((l (current-column)))
375 (insert (mapconcat 'identity date-holiday-list
376 (concat "\n" (make-string l ?
)))))
377 (let ((l (current-column)))
378 (insert ?
\n (make-string l ?
=) ?
\n)))))
379 (if (< 0 (length (car (cdr (car entry-list
)))))
380 (insert (car (cdr (car entry-list
))) ?
\n))
381 (setq entry-list
(cdr entry-list
))))
382 (set-buffer-modified-p nil
)
383 (goto-char (point-min))
384 (setq buffer-read-only t
)
385 (display-buffer fancy-diary-buffer
)
386 (message "Preparing diary...done"))))
388 (defun print-diary-entries ()
389 "Print a hard copy of the entries visible in the diary window.
390 The hooks given by the variable `print-diary-entries-hook' are called after
391 the temporary buffer of visible diary entries is prepared; it is the hooks
392 that do the actual printing and kill the buffer."
394 (let ((diary-buffer (get-file-buffer (substitute-in-file-name diary-file
))))
396 (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*")))
398 (set-buffer diary-buffer
)
399 (copy-to-buffer temp-buffer
(point-min) (point-max))
400 (set-buffer temp-buffer
)
401 (while (re-search-forward "\^M.*$" nil t
)
403 (run-hooks 'print-diary-entries-hook
)))
404 (error "You don't have a diary buffer!"))))
406 (defun add-diary-heading ()
407 "Add a heading to the diary entries for printing.
408 The heading is formed from the mode line of the diary buffer. This function
409 is used in the default value of the variable `print-diary-entry-hooks'."
412 (set-buffer diary-buffer
)
413 (setq heading mode-line-format
)
414 (string-match "%\\*-*\\([^-].*\\)%-$" heading
)
416 (substring heading
(match-beginning 1) (match-end 1)))
417 (set-buffer temp-buffer
)
418 (goto-char (point-min))
420 (make-string (length heading
) ?
=) "\n"))))
422 (defun show-all-diary-entries ()
423 "Show all of the diary entries in the diary-file.
424 This function gets rid of the selective display of the diary-file so that
425 all entries, not just some, are visible. If there is no diary buffer, one
428 (let ((d-file (substitute-in-file-name diary-file
)))
429 (if (and d-file
(file-exists-p d-file
))
430 (if (file-readable-p d-file
)
432 (let ((diary-buffer (get-file-buffer d-file
)))
433 (set-buffer (if diary-buffer
435 (find-file-noselect d-file t
)))
436 (let ((buffer-read-only nil
)
437 (diary-modified (buffer-modified-p)))
438 (subst-char-in-region (point-min) (point-max) ?\^M ?
\n t
)
439 (setq selective-display nil
)
440 (make-local-variable 'mode-line-format
)
441 (setq mode-line-format
442 "%*---------------------------All Diary Entries%-")
443 (display-buffer (current-buffer))
444 (set-buffer-modified-p diary-modified
))))
445 (error "Your diary file is not readable!"))
446 (error "You don't have a diary file!"))))
448 (defun diary-name-pattern (string-array &optional fullname
)
449 "Convert an STRING-ARRAY, an array of strings to a pattern.
450 The pattern will match any of the strings, either entirely or abbreviated
451 to three characters. An abbreviated form will match with or without a period;
452 If the optional FULLNAME is t, abbreviations will not match, just the full
455 (calendar-for-loop i from
0 to
(1- (length string-array
)) do
459 (if (string-equal pattern
"") "" "\\|")
460 (aref string-array i
)
465 (substring (aref string-array i
) 0 3) ".?")))))
468 (defun mark-diary-entries ()
469 "Mark days in the calendar window that have diary entries.
470 Each entry in diary-file visible in the calendar window is marked. After the
471 entries are marked, the hooks `nongregorian-diary-marking-hook' and
472 `mark-diary-entries-hook' are run."
474 (setq mark-diary-entries-in-calendar t
)
475 (let ((d-file (substitute-in-file-name diary-file
)))
476 (if (and d-file
(file-exists-p d-file
))
477 (if (file-readable-p d-file
)
479 (message "Marking diary entries...")
480 (set-buffer (find-file-noselect d-file t
))
481 (let ((d diary-date-forms
)
482 (old-diary-syntax-table))
483 (setq old-diary-syntax-table
(syntax-table))
484 (set-syntax-table diary-syntax-table
)
487 ((date-form (if (equal (car (car d
)) 'backup
)
489 (car d
)));; ignore 'backup directive
490 (dayname (diary-name-pattern calendar-day-name-array
))
493 (diary-name-pattern calendar-month-name-array
)
495 (month "[0-9]+\\|\\*")
497 (year "[0-9]+\\|\\*")
498 (l (length date-form
))
499 (d-name-pos (- l
(length (memq 'dayname date-form
))))
500 (d-name-pos (if (/= l d-name-pos
) (+ 2 d-name-pos
)))
501 (m-name-pos (- l
(length (memq 'monthname date-form
))))
502 (m-name-pos (if (/= l m-name-pos
) (+ 2 m-name-pos
)))
503 (d-pos (- l
(length (memq 'day date-form
))))
504 (d-pos (if (/= l d-pos
) (+ 2 d-pos
)))
505 (m-pos (- l
(length (memq 'month date-form
))))
506 (m-pos (if (/= l m-pos
) (+ 2 m-pos
)))
507 (y-pos (- l
(length (memq 'year date-form
))))
508 (y-pos (if (/= l y-pos
) (+ 2 y-pos
)))
511 "\\(\\`\\|\^M\\|\n\\)\\("
512 (mapconcat 'eval date-form
"\\)\\(")
514 (case-fold-search t
))
515 (goto-char (point-min))
516 (while (re-search-forward regexp nil t
)
520 (match-beginning d-name-pos
)
521 (match-end d-name-pos
))))
525 (match-beginning m-name-pos
)
526 (match-end m-name-pos
))))
530 (match-beginning m-pos
)
536 (match-beginning d-pos
)
541 (match-beginning y-pos
)
545 (if (and (= (length y-str
) 2)
546 abbreviated-calendar-year
)
548 (extract-calendar-year
549 (calendar-current-date)))
550 (y (+ (string-to-int y-str
)
552 (/ current-y
100)))))
553 (if (> (- y current-y
) 50)
555 (if (> (- current-y y
) 50)
558 (string-to-int y-str
)))))
560 (mark-calendar-days-named
561 (cdr (assoc (capitalize (substring dd-name
0 3))
563 calendar-day-name-array
565 '(lambda (x) (substring x
0 3))))))
567 (if (string-equal mm-name
"*")
572 (substring mm-name
0 3))
574 calendar-month-name-array
576 '(lambda (x) (substring x
0 3)))
578 (mark-calendar-date-pattern mm dd yy
))))
580 (mark-sexp-diary-entries)
581 (run-hooks 'nongregorian-diary-marking-hook
582 'mark-diary-entries-hook
)
583 (set-syntax-table old-diary-syntax-table
)
584 (message "Marking diary entries...done")))
585 (error "Your diary file is not readable!"))
586 (error "You don't have a diary file!"))))
588 (defun mark-sexp-diary-entries ()
589 "Mark days in the calendar window that have sexp diary entries.
590 Each entry in diary-file (or included files) visible in the calendar window
591 is marked. See the documentation for the function `list-sexp-diary-entries'."
592 (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol
))
593 (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" sexp-mark
"("))
599 (set-buffer calendar-buffer
)
600 (setq m displayed-month
)
601 (setq y displayed-year
))
602 (increment-calendar-month m y -
1)
604 (calendar-absolute-from-gregorian (list m
1 y
)))
605 (increment-calendar-month m y
2)
607 (calendar-absolute-from-gregorian
608 (list m
(calendar-last-day-of-month m y
) y
)))
609 (goto-char (point-min))
610 (while (re-search-forward s-entry nil t
)
612 (let ((sexp-start (point))
618 (setq sexp
(buffer-substring sexp-start
(point)))
620 (re-search-backward "\^M\\|\n\\|\\`")
621 (setq line-start
(point)))
623 (if (and (or (char-equal (preceding-char) ?\^M
)
624 (char-equal (preceding-char) ?
\n))
625 (not (looking-at " \\|\^I")))
626 (progn;; Diary entry consists only of the sexp
629 (setq entry-start
(point))
630 (re-search-forward "\^M\\|\n" nil t
)
631 (while (looking-at " \\|\^I")
632 (re-search-forward "\^M\\|\n" nil t
))
634 (setq entry
(buffer-substring entry-start
(point)))
635 (while (string-match "[\^M]" entry
)
636 (aset entry
(match-beginning 0) ?
\n )))
637 (calendar-for-loop date from first-date to last-date do
638 (if (diary-sexp-entry sexp entry
639 (calendar-gregorian-from-absolute date
))
640 (mark-visible-calendar-date
641 (calendar-gregorian-from-absolute date
))))))))
643 (defun mark-included-diary-files ()
644 "Mark the diary entries from other diary files with those of diary-file.
645 This function is suitable for use as the mark-diary-entries-hook; it enables
646 you to use shared diary files together with your own. The files included are
647 specified in the diary-file by lines of the form
648 #include \"filename\"
649 This is recursive; that is, #include directives in diary files thus included
650 are obeyed. You can change the \"#include\" to some other string by
651 changing the variable `diary-include-string'."
652 (goto-char (point-min))
653 (while (re-search-forward
655 "\\(\\`\\|\^M\\|\n\\)"
656 (regexp-quote diary-include-string
)
659 (let ((diary-file (substitute-in-file-name
660 (buffer-substring (match-beginning 2) (match-end 2))))
661 (mark-diary-entries-hook 'mark-included-diary-files
))
662 (if (file-exists-p diary-file
)
663 (if (file-readable-p diary-file
)
666 (kill-buffer (get-file-buffer diary-file
)))
668 (message "Can't read included diary file %s" diary-file
)
671 (message "Can't find included diary file %s" diary-file
)
673 (goto-char (point-min)))
675 (defun mark-calendar-days-named (dayname)
676 "Mark all dates in the calendar window that are day DAYNAME of the week.
677 0 means all Sundays, 1 means all Mondays, and so on."
679 (set-buffer calendar-buffer
)
680 (let ((prev-month displayed-month
)
681 (prev-year displayed-year
)
682 (succ-month displayed-month
)
683 (succ-year displayed-year
)
686 (increment-calendar-month succ-month succ-year
1)
687 (increment-calendar-month prev-month prev-year -
1)
688 (setq day
(calendar-absolute-from-gregorian
689 (calendar-nth-named-day 1 dayname prev-month prev-year
)))
690 (setq last-day
(calendar-absolute-from-gregorian
691 (calendar-nth-named-day -
1 dayname succ-month succ-year
)))
692 (while (<= day last-day
)
693 (mark-visible-calendar-date (calendar-gregorian-from-absolute day
))
694 (setq day
(+ day
7))))))
696 (defun mark-calendar-date-pattern (month day year
)
697 "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
698 A value of 0 in any position is a wild-card."
700 (set-buffer calendar-buffer
)
701 (let ((m displayed-month
)
703 (increment-calendar-month m y -
1)
704 (calendar-for-loop i from
0 to
2 do
705 (mark-calendar-month m y month day year
)
706 (increment-calendar-month m y
1)))))
708 (defun mark-calendar-month (month year p-month p-day p-year
)
709 "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
710 A value of 0 in any position of the pattern is a wild-card."
711 (if (or (and (= month p-month
)
712 (or (= p-year
0) (= year p-year
)))
714 (or (= p-year
0) (= year p-year
))))
717 i from
1 to
(calendar-last-day-of-month month year
) do
718 (mark-visible-calendar-date (list month i year
)))
719 (mark-visible-calendar-date (list month p-day year
)))))
721 (defun diary-entry-compare (e1 e2
)
722 "Returns t if E1 is earlier than E2."
723 (or (calendar-date-compare e1 e2
)
724 (and (calendar-date-equal (car e1
) (car e2
))
725 (< (diary-entry-time (car (cdr e1
)))
726 (diary-entry-time (car (cdr e2
)))))))
728 (defun diary-entry-time (s)
729 "Time at the beginning of the string S in a military-style integer.
730 For example, returns 1325 for 1:25pm. Returns -9999 if no time is recognized.
731 The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm,
732 and XX:XXam or XX:XXpm."
733 (cond ((string-match;; Military time
734 "^ *\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s
)
735 (+ (* 100 (string-to-int
736 (substring s
(match-beginning 1) (match-end 1))))
737 (string-to-int (substring s
(match-beginning 2) (match-end 2)))))
738 ((string-match;; Hour only XXam or XXpm
739 "^ *\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s
)
740 (+ (* 100 (%
(string-to-int
741 (substring s
(match-beginning 1) (match-end 1)))
743 (if (string-equal "a"
744 (substring s
(match-beginning 2) (match-end 2)))
746 ((string-match;; Hour and minute XX:XXam or XX:XXpm
747 "^ *\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s
)
748 (+ (* 100 (%
(string-to-int
749 (substring s
(match-beginning 1) (match-end 1)))
751 (string-to-int (substring s
(match-beginning 2) (match-end 2)))
752 (if (string-equal "a"
753 (substring s
(match-beginning 3) (match-end 3)))
755 (t -
9999)));; Unrecognizable
757 (defun list-hebrew-diary-entries ()
758 "Add any Hebrew date entries from the diary-file to diary-entries-list.
759 Hebrew date diary entries must be prefaced by a hebrew-diary-entry-symbol
760 \(normally an `H'\). The same diary-date-forms govern the style of the Hebrew
761 calendar entries, except that the Hebrew month names must be spelled in full.
762 The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
763 Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
764 common Hebrew year. If a Hebrew date diary entry begins with a
765 diary-nonmarking-symbol the entry will appear in the diary listing, but will
766 not be marked in the calendar. This function is provided for use with the
767 nongregorian-diary-listing-hook."
769 (let ((buffer-read-only nil
)
770 (diary-modified (buffer-modified-p))
771 (gdate original-date
)
772 (mark (regexp-quote diary-nonmarking-symbol
)))
773 (calendar-for-loop i from
1 to number do
774 (let* ((d diary-date-forms
)
775 (hdate (calendar-hebrew-from-absolute
776 (calendar-absolute-from-gregorian gdate
)))
777 (month (extract-calendar-month hdate
))
778 (day (extract-calendar-day hdate
))
779 (year (extract-calendar-year hdate
)))
782 ((date-form (if (equal (car (car d
)) 'backup
)
785 (backup (equal (car (car d
)) 'backup
))
788 (calendar-day-name gdate
) "\\|"
789 (substring (calendar-day-name gdate
) 0 3) ".?"))
790 (calendar-month-name-array
791 calendar-hebrew-month-name-array-leap-year
)
795 (calendar-month-name month
)))
796 (month (concat "\\*\\|0*" (int-to-string month
)))
797 (day (concat "\\*\\|0*" (int-to-string day
)))
800 "\\*\\|0*" (int-to-string year
)
801 (if abbreviated-calendar-year
802 (concat "\\|" (int-to-string (% year
100)))
806 "\\(\\`\\|\^M\\|\n\\)" mark
"?"
807 (regexp-quote hebrew-diary-entry-symbol
)
809 (mapconcat 'eval date-form
"\\)\\(")
811 (case-fold-search t
))
812 (goto-char (point-min))
813 (while (re-search-forward regexp nil t
)
814 (if backup
(re-search-backward "\\<" nil t
))
815 (if (and (or (char-equal (preceding-char) ?\^M
)
816 (char-equal (preceding-char) ?
\n))
817 (not (looking-at " \\|\^I")))
818 ;; Diary entry that consists only of date.
820 ;; Found a nonempty diary entry--make it visible and
821 ;; add it to the list.
822 (let ((entry-start (point))
824 (re-search-backward "\^M\\|\n\\|\\`")
825 (setq date-start
(point))
826 (re-search-forward "\^M\\|\n" nil t
2)
827 (while (looking-at " \\|\^I")
828 (re-search-forward "\^M\\|\n" nil t
))
830 (subst-char-in-region date-start
(point) ?\^M ?
\n t
)
832 gdate
(buffer-substring entry-start
(point)))))))
835 (calendar-gregorian-from-absolute
836 (1+ (calendar-absolute-from-gregorian gdate
)))))
837 (set-buffer-modified-p diary-modified
))
838 (goto-char (point-min))))
840 (defun mark-hebrew-diary-entries ()
841 "Mark days in the calendar window that have Hebrew date diary entries.
842 Each entry in diary-file (or included files) visible in the calendar window
843 is marked. Hebrew date entries are prefaced by a hebrew-diary-entry-symbol
844 \(normally an `H'\). The same diary-date-forms govern the style of the Hebrew
845 calendar entries, except that the Hebrew month names must be spelled in full.
846 The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
847 Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
848 common Hebrew year. Hebrew date diary entries that begin with a
849 diary-nonmarking symbol will not be marked in the calendar. This function
850 is provided for use as part of the nongregorian-diary-marking-hook."
851 (let ((d diary-date-forms
))
854 ((date-form (if (equal (car (car d
)) 'backup
)
856 (car d
)));; ignore 'backup directive
857 (dayname (diary-name-pattern calendar-day-name-array
))
860 (diary-name-pattern calendar-hebrew-month-name-array-leap-year t
)
862 (month "[0-9]+\\|\\*")
864 (year "[0-9]+\\|\\*")
865 (l (length date-form
))
866 (d-name-pos (- l
(length (memq 'dayname date-form
))))
867 (d-name-pos (if (/= l d-name-pos
) (+ 2 d-name-pos
)))
868 (m-name-pos (- l
(length (memq 'monthname date-form
))))
869 (m-name-pos (if (/= l m-name-pos
) (+ 2 m-name-pos
)))
870 (d-pos (- l
(length (memq 'day date-form
))))
871 (d-pos (if (/= l d-pos
) (+ 2 d-pos
)))
872 (m-pos (- l
(length (memq 'month date-form
))))
873 (m-pos (if (/= l m-pos
) (+ 2 m-pos
)))
874 (y-pos (- l
(length (memq 'year date-form
))))
875 (y-pos (if (/= l y-pos
) (+ 2 y-pos
)))
878 "\\(\\`\\|\^M\\|\n\\)"
879 (regexp-quote hebrew-diary-entry-symbol
)
881 (mapconcat 'eval date-form
"\\)\\(")
883 (case-fold-search t
))
884 (goto-char (point-min))
885 (while (re-search-forward regexp nil t
)
889 (match-beginning d-name-pos
)
890 (match-end d-name-pos
))))
894 (match-beginning m-name-pos
)
895 (match-end m-name-pos
))))
899 (match-beginning m-pos
)
905 (match-beginning d-pos
)
910 (match-beginning y-pos
)
914 (if (and (= (length y-str
) 2)
915 abbreviated-calendar-year
)
917 (extract-calendar-year
918 (calendar-hebrew-from-absolute
919 (calendar-absolute-from-gregorian
920 (calendar-current-date)))))
921 (y (+ (string-to-int y-str
)
922 (* 100 (/ current-y
100)))))
923 (if (> (- y current-y
) 50)
925 (if (> (- current-y y
) 50)
928 (string-to-int y-str
)))))
930 (mark-calendar-days-named
931 (cdr (assoc (capitalize (substring dd-name
0 3))
933 calendar-day-name-array
935 '(lambda (x) (substring x
0 3))))))
937 (if (string-equal mm-name
"*")
945 calendar-hebrew-month-name-array-leap-year
))))))
946 (mark-hebrew-calendar-date-pattern mm dd yy
)))))
949 (defun mark-hebrew-calendar-date-pattern (month day year
)
950 "Mark all dates in the calendar window that conform to the Hebrew date
951 MONTH/DAY/YEAR. A value of 0 in any position is a wild-card."
953 (set-buffer calendar-buffer
)
954 (if (and (/= 0 month
) (/= 0 day
))
956 ;; Fully specified Hebrew date.
957 (let ((date (calendar-gregorian-from-absolute
958 (calendar-absolute-from-hebrew
959 (list month day year
)))))
960 (if (calendar-date-is-visible-p date
)
961 (mark-visible-calendar-date date
)))
962 ;; Month and day in any year--this taken from the holiday stuff.
963 (if (memq displayed-month
;; This test is only to speed things up a
964 (list ;; bit; it works fine without the test too.
965 (if (< 11 month
) (- month
11) (+ month
1))
966 (if (< 10 month
) (- month
10) (+ month
2))
967 (if (< 9 month
) (- month
9) (+ month
3))
968 (if (< 8 month
) (- month
8) (+ month
4))
969 (if (< 7 month
) (- month
7) (+ month
5))))
970 (let ((m1 displayed-month
)
975 (increment-calendar-month m1 y1 -
1)
976 (increment-calendar-month m2 y2
1)
977 (let* ((start-date (calendar-absolute-from-gregorian
979 (end-date (calendar-absolute-from-gregorian
981 (calendar-last-day-of-month m2 y2
)
984 (calendar-hebrew-from-absolute start-date
))
985 (hebrew-end (calendar-hebrew-from-absolute end-date
))
986 (hebrew-y1 (extract-calendar-year hebrew-start
))
987 (hebrew-y2 (extract-calendar-year hebrew-end
)))
988 (setq year
(if (< 6 month
) hebrew-y2 hebrew-y1
))
989 (let ((date (calendar-gregorian-from-absolute
990 (calendar-absolute-from-hebrew
991 (list month day year
)))))
992 (if (calendar-date-is-visible-p date
)
993 (mark-visible-calendar-date date
)))))))
994 ;; Not one of the simple cases--check all visible dates for match.
995 ;; Actually, the following code takes care of ALL of the cases, but
996 ;; it's much too slow to be used for the simple (common) cases.
997 (let ((m displayed-month
)
1001 (increment-calendar-month m y -
1)
1003 (calendar-absolute-from-gregorian
1005 (increment-calendar-month m y
2)
1007 (calendar-absolute-from-gregorian
1008 (list m
(calendar-last-day-of-month m y
) y
)))
1009 (calendar-for-loop date from first-date to last-date do
1010 (let* ((h-date (calendar-hebrew-from-absolute date
))
1011 (h-month (extract-calendar-month h-date
))
1012 (h-day (extract-calendar-day h-date
))
1013 (h-year (extract-calendar-year h-date
)))
1014 (and (or (zerop month
)
1020 (mark-visible-calendar-date
1021 (calendar-gregorian-from-absolute date
)))))))))
1023 (defun list-sexp-diary-entries (date)
1024 "Add any sexp entries for DATE from the diary-file to diary-entries-list
1025 and make them visible in the diary file. Returns t if any entries were found.
1027 Sexp diary entries must be prefaced by a sexp-diary-entry-symbol (normally
1028 `%%'). The form of a sexp diary entry is
1032 Both ENTRY and DATE are globally available when the SEXP is evaluated. If the
1033 SEXP yields the value nil, the diary entry does not apply. If it yields a
1034 non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a
1035 string, that string will be the diary entry in the fancy diary display.
1037 For example, the following diary entry will apply to the 21st of the month
1038 if it is a weekday and the Friday before if the 21st is on a weekend:
1040 &%%(let ((dayname (calendar-day-of-week date))
1041 (day (extract-calendar-day date)))
1043 (and (= day 21) (memq dayname '(1 2 3 4 5)))
1044 (and (memq day '(19 20)) (= dayname 5)))
1045 ) UIUC pay checks deposited
1047 A number of built-in functions are available for this type of diary entry:
1049 %%(diary-float MONTH DAYNAME N) text
1050 Entry will appear on the Nth DAYNAME of MONTH.
1051 (DAYNAME=0 means Sunday, 1 means Monday, and so on;
1052 if N is negative it counts backward from the end of
1053 the month. MONTH can be a list of months, a single
1054 month, or t to specify all months.
1056 %%(diary-block M1 D1 Y1 M2 D2 Y2) text
1057 Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,
1058 inclusive. (If `european-calendar-style' is t, the
1059 order of the parameters should be changed to D1, M1, Y1,
1062 %%(diary-anniversary MONTH DAY YEAR) text
1063 Entry will appear on anniversary dates of MONTH DAY, YEAR.
1064 (If `european-calendar-style' is t, the order of the
1065 parameters should be changed to DAY, MONTH, YEAR.) Text
1066 can contain %d or %d%s; %d will be replaced by the number
1067 of years since the MONTH DAY, YEAR and %s will be replaced
1068 by the ordinal ending of that number (that is, `st', `nd',
1069 `rd' or `th', as appropriate. The anniversary of February
1070 29 is considered to be March 1 in a non-leap year.
1072 %%(diary-cyclic N MONTH DAY YEAR) text
1073 Entry will appear every N days, starting MONTH DAY, YEAR.
1074 (If `european-calendar-style' is t, the order of the
1075 parameters should be changed to N, DAY, MONTH, YEAR.) Text
1076 can contain %d or %d%s; %d will be replaced by the number
1077 of repetitions since the MONTH DAY, YEAR and %s will
1078 be replaced by the ordinal ending of that number (that is,
1079 `st', `nd', `rd' or `th', as appropriate.
1081 %%(diary-day-of-year)
1082 Diary entries giving the day of the year and the number of
1083 days remaining in the year will be made every day. Note
1084 that since there is no text, it makes sense only if the
1085 fancy diary display is used.
1088 Diary entries giving the corresponding ISO commercial date
1089 will be made every day. Note that since there is no text,
1090 it makes sense only if the fancy diary display is used.
1092 %%(diary-french-date)
1093 Diary entries giving the corresponding French Revolutionary
1094 date will be made every day. Note that since there is no
1095 text, it makes sense only if the fancy diary display is used.
1097 %%(diary-islamic-date)
1098 Diary entries giving the corresponding Islamic date will be
1099 made every day. Note that since there is no text, it
1100 makes sense only if the fancy diary display is used.
1102 %%(diary-hebrew-date)
1103 Diary entries giving the corresponding Hebrew date will be
1104 made every day. Note that since there is no text, it
1105 makes sense only if the fancy diary display is used.
1107 %%(diary-yahrzeit MONTH DAY YEAR) text
1108 Text is assumed to be the name of the person; the date is
1109 the date of death on the *civil* calendar. The diary entry
1110 will appear on the proper Hebrew-date anniversary and on the
1111 day before. (If `european-calendar-style' is t, the order
1112 of the parameters should be changed to DAY, MONTH, YEAR.)
1114 %%(diary-rosh-hodesh)
1115 Diary entries will be made on the dates of Rosh Hodesh on
1116 the Hebrew calendar. Note that since there is no text, it
1117 makes sense only if the fancy diary display is used.
1120 Diary entries giving the weekly parasha will be made on
1121 every Saturday. Note that since there is no text, it
1122 makes sense only if the fancy diary display is used.
1125 Diary entries giving the omer count will be made every day
1126 from Passover to Shavuoth. Note that since there is no text,
1127 it makes sense only if the fancy diary display is used.
1129 Marking these entries is *extremely* time consuming, so these entries are
1130 best if they are nonmarking."
1131 (let* ((mark (regexp-quote diary-nonmarking-symbol
))
1132 (sexp-mark (regexp-quote sexp-diary-entry-symbol
))
1133 (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark
"?" sexp-mark
"("))
1135 (goto-char (point-min))
1136 (while (re-search-forward s-entry nil t
)
1138 (let ((sexp-start (point))
1144 (setq sexp
(buffer-substring sexp-start
(point)))
1146 (re-search-backward "\^M\\|\n\\|\\`")
1147 (setq line-start
(point)))
1149 (if (and (or (char-equal (preceding-char) ?\^M
)
1150 (char-equal (preceding-char) ?
\n))
1151 (not (looking-at " \\|\^I")))
1152 (progn;; Diary entry consists only of the sexp
1155 (setq entry-start
(point))
1156 (re-search-forward "\^M\\|\n" nil t
)
1157 (while (looking-at " \\|\^I")
1158 (re-search-forward "\^M\\|\n" nil t
))
1160 (setq entry
(buffer-substring entry-start
(point)))
1161 (while (string-match "[\^M]" entry
)
1162 (aset entry
(match-beginning 0) ?
\n )))
1163 (let ((diary-entry (diary-sexp-entry sexp entry date
)))
1165 (subst-char-in-region line-start
(point) ?\^M ?
\n t
))
1166 (add-to-diary-list date diary-entry
)
1167 (setq entry-found
(or entry-found diary-entry
)))))
1170 (defun diary-sexp-entry (sexp entry date
)
1171 "Process a SEXP diary ENTRY for DATE."
1172 (let ((result (condition-case nil
1173 (eval (car (read-from-string sexp
)))
1176 (message "Bad sexp at line %d in %s: %s"
1179 (narrow-to-region 1 (point))
1180 (goto-char (point-min))
1182 (while (re-search-forward "\n\\|\^M" nil t
)
1183 (setq lines
(1+ lines
)))
1187 (if (stringp result
)
1193 (defun diary-block (m1 d1 y1 m2 d2 y2
)
1194 "Block diary entry--entry applies if date is between two dates. Order of
1195 the parameters is M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and
1196 D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t."
1197 (let ((date1 (calendar-absolute-from-gregorian
1198 (if european-calendar-style
1201 (date2 (calendar-absolute-from-gregorian
1202 (if european-calendar-style
1205 (d (calendar-absolute-from-gregorian date
)))
1206 (if (and (<= date1 d
) (<= d date2
))
1209 (defun diary-float (month dayname n
)
1210 "Floating diary entry--entry applies if date is the nth dayname of month.
1211 Parameters are MONTH, DAYNAME, N. MONTH can be a list of months, the constant
1212 t, or an integer. The constant t means all months. If N is negative, count
1213 backward from the end of the month."
1214 (let ((m (extract-calendar-month date
))
1215 (y (extract-calendar-year date
)))
1217 (or (and (listp month
) (memq m month
))
1220 (calendar-date-equal date
(calendar-nth-named-day n dayname m y
)))
1223 (defun diary-anniversary (month day year
)
1224 "Anniversary diary entry--entry applies if date is the anniversary of
1225 MONTH, DAY, YEAR if `european-calendar-style' is nil, and DAY, MONTH, YEAR
1226 if `european-calendar-style' is t. Diary entry can contain `%d' or `%d%s'; the
1227 %d will be replaced by the number of years since the MONTH DAY, YEAR and the
1228 %s will be replaced by the ordinal ending of that number (that is, `st', `nd',
1229 `rd' or `th', as appropriate. The anniversary of February 29 is considered
1230 to be March 1 in non-leap years."
1231 (let* ((d (if european-calendar-style
1234 (m (if european-calendar-style
1237 (y (extract-calendar-year date
))
1239 (if (and (= m
2) (= d
29) (not (calendar-leap-year-p y
)))
1242 (if (and (> diff
0) (calendar-date-equal (list m d y
) date
))
1243 (format entry diff
(diary-ordinal-suffix diff
)))))
1245 (defun diary-cyclic (n month day year
)
1246 "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
1247 If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
1248 ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
1249 years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal
1250 ending of that number (that is, `st', `nd', `rd' or `th', as appropriate."
1251 (let* ((d (if european-calendar-style
1254 (m (if european-calendar-style
1257 (diff (- (calendar-absolute-from-gregorian date
)
1258 (calendar-absolute-from-gregorian
1261 (if (and (>= diff
0) (zerop (% diff n
)))
1262 (format entry cycle
(diary-ordinal-suffix cycle
)))))
1264 (defun diary-ordinal-suffix (n)
1265 "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
1266 (if (or (memq (% n
100) '(11 12 13))
1269 (aref ["th" "st" "nd" "rd"] (% n
10))))
1271 (defun diary-day-of-year ()
1272 "Day of year and number of days remaining in the year of date diary entry."
1273 (let* ((year (extract-calendar-year date
))
1274 (day (calendar-day-number date
))
1275 (days-remaining (- (calendar-day-number (list 12 31 year
)) day
)))
1276 (format "Day %d of %d; %d day%s remaining in the year"
1277 day year days-remaining
(if (= days-remaining
1) "" "s"))))
1279 (defun diary-iso-date ()
1280 "ISO calendar equivalent of date diary entry."
1281 (let ((day (%
(calendar-absolute-from-gregorian date
) 7))
1282 (iso-date (calendar-iso-from-absolute
1283 (calendar-absolute-from-gregorian date
))))
1284 (format "ISO date: Day %s of week %d of %d."
1285 (if (zerop day
) 7 day
)
1286 (extract-calendar-month iso-date
)
1287 (extract-calendar-year iso-date
))))
1289 (defun diary-islamic-date ()
1290 "Islamic calendar equivalent of date diary entry."
1291 (let* ((calendar-date-display-form
1292 (if european-calendar-style
1293 '(day " " monthname
" " year
)
1294 '(monthname " " day
", " year
)))
1295 (i-date (calendar-islamic-from-absolute
1296 (calendar-absolute-from-gregorian date
)))
1297 (calendar-month-name-array calendar-islamic-month-name-array
))
1298 (if (>= (extract-calendar-year i-date
) 1)
1299 (format "Islamic date: %s" (calendar-date-string i-date
)))))
1301 (defun diary-hebrew-date ()
1302 "Hebrew calendar equivalent of date diary entry."
1303 (let* ((calendar-date-display-form
1304 (if european-calendar-style
1305 '(day " " monthname
" " year
)
1306 '(monthname " " day
", " year
)))
1307 (h-date (calendar-hebrew-from-absolute
1308 (calendar-absolute-from-gregorian date
)))
1309 (calendar-month-name-array
1310 (if (hebrew-calendar-leap-year-p
1311 (extract-calendar-year h-date
))
1312 calendar-hebrew-month-name-array-leap-year
1313 calendar-hebrew-month-name-array-common-year
)))
1314 (format "Hebrew date: %s" (calendar-date-string h-date
))))
1316 (defun diary-french-date ()
1317 "French calendar equivalent of date diary entry."
1318 (let* ((french-date (calendar-french-from-absolute
1319 (calendar-absolute-from-gregorian date
)))
1320 (y (extract-calendar-year french-date
))
1321 (m (extract-calendar-month french-date
))
1322 (d (extract-calendar-day french-date
)))
1325 (format "Jour %s de l'Annee %d de la Revolution"
1326 (aref french-calendar-special-days-array
(1- d
))
1328 (format "Decade %s, %s de %s de l'Annee %d de la Revolution"
1329 (make-string (1+ (/ (1- d
) 10)) ?I
)
1330 (aref french-calendar-day-name-array
(%
(1- d
) 10))
1331 (aref french-calendar-month-name-array
(1- m
))
1334 (defun diary-omer ()
1335 "Omer count diary entry--entry applies if date is within 50 days after
1338 (calendar-absolute-from-hebrew
1339 (list 1 15 (+ (extract-calendar-year date
) 3760))))
1340 (omer (- (calendar-absolute-from-gregorian date
) passover
))
1343 (if (and (> omer
0) (< omer
50))
1344 (format "Day %d%s of the omer (until sunset)"
1348 (format ", that is, %d week%s%s"
1350 (if (= week
1) "" "s")
1353 (format " and %d day%s"
1354 day
(if (= day
1) "" "s")))))))))
1356 (defun diary-yahrzeit (death-month death-day death-year
)
1357 "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.
1358 Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed
1359 to be the name of the person. Date of death is on the *civil* calendar;
1360 although the date of death is specified by the civil calendar, the proper
1361 Hebrew calendar yahrzeit is determined. If european-calendar-style is t, the
1362 order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR."
1363 (let* ((h-date (calendar-hebrew-from-absolute
1364 (calendar-absolute-from-gregorian
1365 (if european-calendar-style
1366 (list death-day death-month death-year
)
1367 (list death-month death-day death-year
)))))
1368 (h-month (extract-calendar-month h-date
))
1369 (h-day (extract-calendar-day h-date
))
1370 (h-year (extract-calendar-year h-date
))
1371 (d (calendar-absolute-from-gregorian date
))
1372 (yr (extract-calendar-year (calendar-hebrew-from-absolute d
)))
1373 (diff (- yr h-year
))
1374 (y (hebrew-calendar-yahrzeit h-date yr
)))
1375 (if (and (> diff
0) (or (= y d
) (= y
(1+ d
))))
1376 (format "Yahrzeit of %s%s: %d%s anniversary"
1378 (if (= y d
) "" " (evening)")
1380 (cond ((= (% diff
10) 1) "st")
1381 ((= (% diff
10) 2) "nd")
1382 ((= (% diff
10) 3) "rd")
1385 (defun diary-rosh-hodesh ()
1386 "Rosh Hodesh diary entry--entry applies if date is Rosh Hodesh, the day
1387 before, or the Saturday before."
1388 (let* ((d (calendar-absolute-from-gregorian date
))
1389 (h-date (calendar-hebrew-from-absolute d
))
1390 (h-month (extract-calendar-month h-date
))
1391 (h-day (extract-calendar-day h-date
))
1392 (h-year (extract-calendar-year h-date
))
1393 (leap-year (hebrew-calendar-leap-year-p h-year
))
1394 (last-day (hebrew-calendar-last-day-of-month h-month h-year
))
1397 calendar-hebrew-month-name-array-leap-year
1398 calendar-hebrew-month-name-array-common-year
))
1399 (this-month (aref h-month-names
(1- h-month
)))
1400 (h-yesterday (extract-calendar-day
1401 (calendar-hebrew-from-absolute (1- d
)))))
1402 (if (or (= h-day
30) (and (= h-day
1) (/= h-month
7)))
1408 ;; next month must be in the same year since this
1409 ;; month can't be the last month of the year since
1411 (aref h-month-names h-month
))
1412 (if (= h-yesterday
30)
1413 (format "%s (second day)" this-month
)
1415 (if (= (mod d
7) 6);; Saturday--check for Shabbat Mevarhim
1416 (cond ((and (> h-day
22) (/= h-month
6) (= 29 last-day
))
1417 (format "Mevarhim Rosh Hodesh %s (%s)"
1420 (hebrew-calendar-last-month-of-year
1423 (aref calendar-day-name-array
(- 29 h-day
))))
1424 ((and (< h-day
30) (> h-day
22) (= 30 last-day
))
1425 (format "Mevarhim Rosh Hodesh %s (%s-%s)"
1426 (aref h-month-names h-month
)
1429 (aref calendar-day-name-array
(- 29 h-day
)))
1430 (aref calendar-day-name-array
1431 (mod (- 30 h-day
) 7)))))
1432 (if (and (= h-day
29) (/= h-month
6))
1433 (format "Erev Rosh Hodesh %s"
1436 (hebrew-calendar-last-month-of-year
1440 (defun diary-parasha ()
1441 "Parasha diary entry--entry applies if date is a Saturday."
1442 (let ((d (calendar-absolute-from-gregorian date
)))
1443 (if (= (% d
7) 6);; Saturday
1445 ((h-year (extract-calendar-year
1446 (calendar-hebrew-from-absolute d
)))
1448 (calendar-absolute-from-hebrew (list 7 1 h-year
)))
1450 (calendar-absolute-from-hebrew (list 1 15 h-year
)))
1452 (aref calendar-day-name-array
(% rosh-hashannah
7)))
1454 (aref calendar-day-name-array
(% passover
7)))
1455 (long-h (hebrew-calendar-long-heshvan-p h-year
))
1456 (short-k (hebrew-calendar-short-kislev-p h-year
))
1457 (type (cond ((and long-h
(not short-k
)) "complete")
1458 ((and (not long-h
) short-k
) "incomplete")
1462 (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah
1463 rosh-hashannah-day type passover-day
))))
1464 (first-saturday;; of Hebrew year
1465 (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah
)))
1466 (saturday;; which Saturday of the Hebrew year
1467 (/ (- d first-saturday
) 7))
1468 (parasha (aref year-format saturday
)))
1472 (if (listp parasha
);; Israel differs from diaspora
1474 (format "%s (diaspora), %s (Israel)"
1475 (hebrew-calendar-parasha-name (car parasha
))
1476 (hebrew-calendar-parasha-name (cdr parasha
)))
1477 (format "%s (Israel)"
1478 (hebrew-calendar-parasha-name (cdr parasha
))))
1479 (hebrew-calendar-parasha-name parasha
))))))))
1481 (defun add-to-diary-list (date string
)
1482 "Add the entry (DATE STRING) to the diary-entries-list.
1483 Do nothing if DATE or STRING is nil."
1485 (setq diary-entries-list
1486 (append diary-entries-list
(list (list date string
))))))
1488 (defconst hebrew-calendar-parashiot-names
1489 ["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth"
1490 "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi"
1491 "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim"
1492 "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra"
1493 "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim"
1494 "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha"
1495 "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth"
1496 "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim"
1497 "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"]
1498 "The names of the parashiot in the Torah.")
1500 ;; The seven ordinary year types (keviot)
1502 (defconst hebrew-calendar-year-Saturday-incomplete-Sunday
1503 [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]
1504 23 24 nil
25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1505 43 44 45 46 47 48 49 50]
1506 "The structure of the parashiot in a Hebrew year that starts on Saturday,
1507 is `incomplete' (Heshvan and Kislev each have 29 days), and has Passover
1510 (defconst hebrew-calendar-year-Saturday-complete-Tuesday
1511 [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]
1512 23 24 nil
25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1513 43 44 45 46 47 48 49 [50 51]]
1514 "The structure of the parashiot in a Hebrew year that starts on Saturday,
1515 is `complete' (Heshvan and Kislev each have 30 days), and has Passover
1518 (defconst hebrew-calendar-year-Monday-incomplete-Tuesday
1519 [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]
1520 23 24 nil
25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1521 43 44 45 46 47 48 49 [50 51]]
1522 "The structure of the parashiot in a Hebrew year that starts on Monday,
1523 is `incomplete' (Heshvan and Kislev each have 29 days), and has Passover
1526 (defconst hebrew-calendar-year-Monday-complete-Thursday
1527 [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]
1528 23 24 nil
25 [26 27] [28 29] 30 [31 32] 33 (nil .
34) (34.35
) (35.36
)
1529 (36.37
) (37.38
) ([38 39].39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1530 "The structure of the parashiot in a Hebrew year that starts on Monday,
1531 is `complete' (Heshvan and Kislev each have 30 days), and has Passover
1532 start on Thursday.")
1534 (defconst hebrew-calendar-year-Tuesday-regular-Thursday
1535 [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]
1536 23 24 nil
25 [26 27] [28 29] 30 [31 32] 33 (nil .
34) (34.35
) (35.36
)
1537 (36.37
) (37.38
) ([38 39].39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1538 "The structure of the parashiot in a Hebrew year that starts on Tuesday,
1539 is `regular' (Heshvan has 29 days and Kislev has 30 days), and has Passover
1540 start on Thursday.")
1542 (defconst hebrew-calendar-year-Thursday-regular-Saturday
1543 [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]
1544 23 24 nil
(nil .
25) (25.
[26 27]) ([26 27].
[28 29]) ([28 29].30) (30.31
)
1545 ([31 32].32) 33 34 35 36 37 38 39 40 [41 42]
1546 43 44 45 46 47 48 49 50]
1547 "The structure of the parashiot in a Hebrew year that starts on Thursday,
1548 is `regular' (Heshvan has 29 days and Kislev has 30 days), and has Passover
1549 start on Saturday.")
1551 (defconst hebrew-calendar-year-Thursday-complete-Sunday
1552 [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
1553 23 24 nil
25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
1554 43 44 45 46 47 48 49 50]
1555 "The structure of the parashiot in a Hebrew year that starts on Thursday,
1556 is `complete' (Heshvan and Kislev each have 30 days), and has Passover
1559 ;; The seven leap year types (keviot)
1561 (defconst hebrew-calendar-year-Saturday-incomplete-Tuesday
1562 [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
1563 23 24 25 26 27 nil
28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42]
1564 43 44 45 46 47 48 49 [50 51]]
1565 "The structure of the parashiot in a Hebrew year that starts on Saturday,
1566 is `incomplete' (Heshvan and Kislev each have 29 days), and has Passover
1569 (defconst hebrew-calendar-year-Saturday-complete-Thursday
1570 [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
1571 23 24 25 26 27 nil
28 29 30 31 32 33 (nil .
34) (34.35
) (35.36
) (36.37
)
1572 (37.38
) ([38 39].39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1573 "The structure of the parashiot in a Hebrew year that starts on Saturday,
1574 is `complete' (Heshvan and Kislev each have 30 days), and has Passover
1575 start on Thursday.")
1577 (defconst hebrew-calendar-year-Monday-incomplete-Thursday
1578 [51 52 nil
0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
1579 23 24 25 26 27 nil
28 29 30 31 32 33 (nil .
34) (34.35
) (35.36
) (36.37
)
1580 (37.38
) ([38 39].39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
1581 "The structure of the parashiot in a Hebrew year that starts on Monday,
1582 is `incomplete' (Heshvan and Kislev each have 29 days), and has Passover
1583 start on Thursday.")
1585 (defconst hebrew-calendar-year-Monday-complete-Saturday
1586 [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
1587 23 24 25 26 27 nil
(nil .
28) (28.29
) (29.30
) (30.31
) (31.32
) (32.33
)
1588 (33.34
) (34.35
) (35.36
) (36.37
) (37.38
) (38.39
) (39.40
) (40.41
) ([41 42].42)
1589 43 44 45 46 47 48 49 50]
1590 "The structure of the parashiot in a Hebrew year that starts on Monday,
1591 is `complete' (Heshvan and Kislev each have 30 days), and has Passover
1592 start on Saturday.")
1594 (defconst hebrew-calendar-year-Tuesday-regular-Saturday
1595 [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
1596 23 24 25 26 27 nil
(nil .
28) (28.29
) (29.30
) (30.31
) (31.32
) (32.33
)
1597 (33.34
) (34.35
) (35.36
) (36.37
) (37.38
) (38.39
) (39.40
) (40.41
) ([41 42].42)
1598 43 44 45 46 47 48 49 50]
1599 "The structure of the parashiot in a Hebrew year that starts on Tuesday,
1600 is `regular' (Heshvan has 29 days and Kislev has 30 days), and has Passover
1601 start on Saturday.")
1603 (defconst hebrew-calendar-year-Thursday-incomplete-Sunday
1604 [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
1605 23 24 25 26 27 28 nil
29 30 31 32 33 34 35 36 37 38 39 40 41 42
1606 43 44 45 46 47 48 49 50]
1607 "The structure of the parashiot in a Hebrew year that starts on Thursday,
1608 is `incomplete' (Heshvan and Kislev both have 29 days), and has Passover
1611 (defconst hebrew-calendar-year-Thursday-complete-Tuesday
1612 [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
1613 23 24 25 26 27 28 nil
29 30 31 32 33 34 35 36 37 38 39 40 41 42
1614 43 44 45 46 47 48 49 [50 51]]
1615 "The structure of the parashiot in a Hebrew year that starts on Thursday,
1616 is `complete' (Heshvan and Kislev both have 30 days), and has Passover
1619 (defun hebrew-calendar-parasha-name (p)
1620 "Name(s) corresponding to parasha P."
1621 (if (arrayp p
);; combined parasha
1623 (aref hebrew-calendar-parashiot-names
(aref p
0))
1624 (aref hebrew-calendar-parashiot-names
(aref p
1)))
1625 (aref hebrew-calendar-parashiot-names p
)))
1627 (defun list-islamic-diary-entries ()
1628 "Add any Islamic date entries from the diary-file to diary-entries-list.
1629 Islamic date diary entries must be prefaced by an islamic-diary-entry-symbol
1630 \(normally an `I'\). The same diary-date-forms govern the style of the Islamic
1631 calendar entries, except that the Islamic month names must be spelled in full.
1632 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
1633 Dhu al-Hijjah. If an Islamic date diary entry begins with a
1634 diary-nonmarking-symbol the entry will appear in the diary listing, but will
1635 not be marked in the calendar. This function is provided for use with the
1636 nongregorian-diary-listing-hook."
1638 (let ((buffer-read-only nil
)
1639 (diary-modified (buffer-modified-p))
1640 (gdate original-date
)
1641 (mark (regexp-quote diary-nonmarking-symbol
)))
1642 (calendar-for-loop i from
1 to number do
1643 (let* ((d diary-date-forms
)
1644 (idate (calendar-islamic-from-absolute
1645 (calendar-absolute-from-gregorian gdate
)))
1646 (month (extract-calendar-month idate
))
1647 (day (extract-calendar-day idate
))
1648 (year (extract-calendar-year idate
)))
1651 ((date-form (if (equal (car (car d
)) 'backup
)
1654 (backup (equal (car (car d
)) 'backup
))
1657 (calendar-day-name gdate
) "\\|"
1658 (substring (calendar-day-name gdate
) 0 3) ".?"))
1659 (calendar-month-name-array
1660 calendar-islamic-month-name-array
)
1664 (calendar-month-name month
)))
1665 (month (concat "\\*\\|0*" (int-to-string month
)))
1666 (day (concat "\\*\\|0*" (int-to-string day
)))
1669 "\\*\\|0*" (int-to-string year
)
1670 (if abbreviated-calendar-year
1671 (concat "\\|" (int-to-string (% year
100)))
1675 "\\(\\`\\|\^M\\|\n\\)" mark
"?"
1676 (regexp-quote islamic-diary-entry-symbol
)
1678 (mapconcat 'eval date-form
"\\)\\(")
1680 (case-fold-search t
))
1681 (goto-char (point-min))
1682 (while (re-search-forward regexp nil t
)
1683 (if backup
(re-search-backward "\\<" nil t
))
1684 (if (and (or (char-equal (preceding-char) ?\^M
)
1685 (char-equal (preceding-char) ?
\n))
1686 (not (looking-at " \\|\^I")))
1687 ;; Diary entry that consists only of date.
1689 ;; Found a nonempty diary entry--make it visible and
1690 ;; add it to the list.
1691 (let ((entry-start (point))
1693 (re-search-backward "\^M\\|\n\\|\\`")
1694 (setq date-start
(point))
1695 (re-search-forward "\^M\\|\n" nil t
2)
1696 (while (looking-at " \\|\^I")
1697 (re-search-forward "\^M\\|\n" nil t
))
1699 (subst-char-in-region date-start
(point) ?\^M ?
\n t
)
1701 gdate
(buffer-substring entry-start
(point)))))))
1704 (calendar-gregorian-from-absolute
1705 (1+ (calendar-absolute-from-gregorian gdate
)))))
1706 (set-buffer-modified-p diary-modified
))
1707 (goto-char (point-min))))
1709 (defun mark-islamic-diary-entries ()
1710 "Mark days in the calendar window that have Islamic date diary entries.
1711 Each entry in diary-file (or included files) visible in the calendar window
1712 is marked. Islamic date entries are prefaced by a islamic-diary-entry-symbol
1713 \(normally an `I'\). The same diary-date-forms govern the style of the Islamic
1714 calendar entries, except that the Islamic month names must be spelled in full.
1715 The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
1716 Dhu al-Hijjah. Islamic date diary entries that begin with a
1717 diary-nonmarking-symbol will not be marked in the calendar. This function is
1718 provided for use as part of the nongregorian-diary-marking-hook."
1719 (let ((d diary-date-forms
))
1722 ((date-form (if (equal (car (car d
)) 'backup
)
1724 (car d
)));; ignore 'backup directive
1725 (dayname (diary-name-pattern calendar-day-name-array
))
1728 (diary-name-pattern calendar-islamic-month-name-array t
)
1730 (month "[0-9]+\\|\\*")
1731 (day "[0-9]+\\|\\*")
1732 (year "[0-9]+\\|\\*")
1733 (l (length date-form
))
1734 (d-name-pos (- l
(length (memq 'dayname date-form
))))
1735 (d-name-pos (if (/= l d-name-pos
) (+ 2 d-name-pos
)))
1736 (m-name-pos (- l
(length (memq 'monthname date-form
))))
1737 (m-name-pos (if (/= l m-name-pos
) (+ 2 m-name-pos
)))
1738 (d-pos (- l
(length (memq 'day date-form
))))
1739 (d-pos (if (/= l d-pos
) (+ 2 d-pos
)))
1740 (m-pos (- l
(length (memq 'month date-form
))))
1741 (m-pos (if (/= l m-pos
) (+ 2 m-pos
)))
1742 (y-pos (- l
(length (memq 'year date-form
))))
1743 (y-pos (if (/= l y-pos
) (+ 2 y-pos
)))
1746 "\\(\\`\\|\^M\\|\n\\)"
1747 (regexp-quote islamic-diary-entry-symbol
)
1749 (mapconcat 'eval date-form
"\\)\\(")
1751 (case-fold-search t
))
1752 (goto-char (point-min))
1753 (while (re-search-forward regexp nil t
)
1757 (match-beginning d-name-pos
)
1758 (match-end d-name-pos
))))
1762 (match-beginning m-name-pos
)
1763 (match-end m-name-pos
))))
1767 (match-beginning m-pos
)
1773 (match-beginning d-pos
)
1778 (match-beginning y-pos
)
1779 (match-end y-pos
))))
1782 (if (and (= (length y-str
) 2)
1783 abbreviated-calendar-year
)
1785 (extract-calendar-year
1786 (calendar-islamic-from-absolute
1787 (calendar-absolute-from-gregorian
1788 (calendar-current-date)))))
1789 (y (+ (string-to-int y-str
)
1790 (* 100 (/ current-y
100)))))
1791 (if (> (- y current-y
) 50)
1793 (if (> (- current-y y
) 50)
1796 (string-to-int y-str
)))))
1798 (mark-calendar-days-named
1799 (cdr (assoc (capitalize (substring dd-name
0 3))
1800 (calendar-make-alist
1801 calendar-day-name-array
1803 '(lambda (x) (substring x
0 3))))))
1805 (if (string-equal mm-name
"*")
1809 (capitalize mm-name
)
1810 (calendar-make-alist
1811 calendar-islamic-month-name-array
))))))
1812 (mark-islamic-calendar-date-pattern mm dd yy
)))))
1815 (defun mark-islamic-calendar-date-pattern (month day year
)
1816 "Mark all dates in the calendar window that conform to the Islamic date
1817 MONTH/DAY/YEAR. A value of 0 in any position is a wild-card."
1819 (set-buffer calendar-buffer
)
1820 (if (and (/= 0 month
) (/= 0 day
))
1822 ;; Fully specified Islamic date.
1823 (let ((date (calendar-gregorian-from-absolute
1824 (calendar-absolute-from-islamic
1825 (list month day year
)))))
1826 (if (calendar-date-is-visible-p date
)
1827 (mark-visible-calendar-date date
)))
1828 ;; Month and day in any year--this taken from the holiday stuff.
1829 (let* ((islamic-date (calendar-islamic-from-absolute
1830 (calendar-absolute-from-gregorian
1831 (list displayed-month
15 displayed-year
))))
1832 (m (extract-calendar-month islamic-date
))
1833 (y (extract-calendar-year islamic-date
))
1836 nil
;; Islamic calendar doesn't apply.
1837 (increment-calendar-month m y
(- 10 month
))
1838 (if (> m
7);; Islamic date might be visible
1839 (let ((date (calendar-gregorian-from-absolute
1840 (calendar-absolute-from-islamic
1841 (list month day y
)))))
1842 (if (calendar-date-is-visible-p date
)
1843 (mark-visible-calendar-date date
)))))))
1844 ;; Not one of the simple cases--check all visible dates for match.
1845 ;; Actually, the following code takes care of ALL of the cases, but
1846 ;; it's much too slow to be used for the simple (common) cases.
1847 (let ((m displayed-month
)
1851 (increment-calendar-month m y -
1)
1853 (calendar-absolute-from-gregorian
1855 (increment-calendar-month m y
2)
1857 (calendar-absolute-from-gregorian
1858 (list m
(calendar-last-day-of-month m y
) y
)))
1859 (calendar-for-loop date from first-date to last-date do
1860 (let* ((i-date (calendar-islamic-from-absolute date
))
1861 (i-month (extract-calendar-month i-date
))
1862 (i-day (extract-calendar-day i-date
))
1863 (i-year (extract-calendar-year i-date
)))
1864 (and (or (zerop month
)
1870 (mark-visible-calendar-date
1871 (calendar-gregorian-from-absolute date
)))))))))
1873 (defun make-diary-entry (string &optional nonmarking file
)
1874 "Insert a diary entry STRING which may be NONMARKING in FILE.
1875 If omitted, NONMARKING defaults to nil and FILE defaults to diary-file."
1876 (find-file-other-window
1877 (substitute-in-file-name (if file file diary-file
)))
1878 (goto-char (point-max))
1881 (if nonmarking diary-nonmarking-symbol
"")
1884 (defun insert-diary-entry (arg)
1885 "Insert a diary entry for the date indicated by point.
1886 Prefix arg will make the entry nonmarking."
1888 (let* ((calendar-date-display-form
1889 (if european-calendar-style
1890 '(day " " monthname
" " year
)
1891 '(monthname " " day
", " year
))))
1893 (calendar-date-string
1894 (or (calendar-cursor-to-date)
1895 (error "Cursor is not on a date!"))
1899 (defun insert-weekly-diary-entry (arg)
1900 "Insert a weekly diary entry for the day of the week indicated by point.
1901 Prefix arg will make the entry nonmarking."
1905 (or (calendar-cursor-to-date)
1906 (error "Cursor is not on a date!")))
1909 (defun insert-monthly-diary-entry (arg)
1910 "Insert a monthly diary entry for the day of the month indicated by point.
1911 Prefix arg will make the entry nonmarking."
1913 (let* ((calendar-date-display-form
1914 (if european-calendar-style
1918 (calendar-date-string
1919 (or (calendar-cursor-to-date)
1920 (error "Cursor is not on a date!"))
1924 (defun insert-yearly-diary-entry (arg)
1925 "Insert an annual diary entry for the day of the year indicated by point.
1926 Prefix arg will make the entry nonmarking."
1928 (let* ((calendar-date-display-form
1929 (if european-calendar-style
1930 '(day " " monthname
)
1931 '(monthname " " day
))))
1933 (calendar-date-string
1934 (or (calendar-cursor-to-date)
1935 (error "Cursor is not on a date!"))
1939 (defun insert-anniversary-diary-entry (arg)
1940 "Insert an anniversary diary entry for the date given by point.
1941 Prefix arg will make the entry nonmarking."
1943 (let* ((calendar-date-display-form
1944 (if european-calendar-style
1945 '(day " " month
" " year
)
1946 '(month " " day
" " year
))))
1948 (format "%s(diary-anniversary %s)"
1949 sexp-diary-entry-symbol
1950 (calendar-date-string
1951 (or (calendar-cursor-to-date)
1952 (error "Cursor is not on a date!"))))
1955 (defun insert-block-diary-entry (arg)
1956 "Insert a block diary entry for the days between the point and marked date.
1957 Prefix arg will make the entry nonmarking."
1959 (let* ((calendar-date-display-form
1960 (if european-calendar-style
1961 '(day " " month
" " year
)
1962 '(month " " day
" " year
)))
1963 (cursor (or (calendar-cursor-to-date)
1964 (error "Cursor is not on a date!")))
1965 (mark (or (car calendar-mark-ring
)
1966 (error "No mark set in this buffer")))
1969 (if (< (calendar-absolute-from-gregorian mark
)
1970 (calendar-absolute-from-gregorian cursor
))
1976 (format "%s(diary-block %s %s)"
1977 sexp-diary-entry-symbol
1978 (calendar-date-string start
)
1979 (calendar-date-string end
))
1982 (defun insert-cyclic-diary-entry (arg)
1983 "Insert a cyclic diary entry starting at the date given by point.
1984 Prefix arg will make the entry nonmarking."
1986 (let* ((calendar-date-display-form
1987 (if european-calendar-style
1988 '(day " " month
" " year
)
1989 '(month " " day
" " year
))))
1991 (format "%s(diary-cyclic %d %s)"
1992 sexp-diary-entry-symbol
1993 (calendar-read "Repeat every how many days: "
1994 '(lambda (x) (> x
0)))
1995 (calendar-date-string
1996 (or (calendar-cursor-to-date)
1997 (error "Cursor is not on a date!"))))
2000 (defun insert-hebrew-diary-entry (arg)
2001 "Insert a diary entry for the Hebrew date corresponding to the date
2002 indicated by point. Prefix arg will make the entry nonmarking."
2004 (let* ((calendar-date-display-form
2005 (if european-calendar-style
2006 '(day " " monthname
" " year
)
2007 '(monthname " " day
", " year
)))
2008 (calendar-month-name-array
2009 calendar-hebrew-month-name-array-leap-year
))
2012 hebrew-diary-entry-symbol
2013 (calendar-date-string
2014 (calendar-hebrew-from-absolute
2015 (calendar-absolute-from-gregorian
2016 (or (calendar-cursor-to-date)
2017 (error "Cursor is not on a date!"))))))
2020 (defun insert-monthly-hebrew-diary-entry (arg)
2021 "Insert a monthly diary entry for the day of the Hebrew month corresponding
2022 to the date indicated by point. Prefix arg will make the entry nonmarking."
2024 (let* ((calendar-date-display-form
2025 (if european-calendar-style
'(day " * ") '("* " day
)))
2026 (calendar-month-name-array
2027 calendar-hebrew-month-name-array-leap-year
))
2030 hebrew-diary-entry-symbol
2031 (calendar-date-string
2032 (calendar-hebrew-from-absolute
2033 (calendar-absolute-from-gregorian
2034 (or (calendar-cursor-to-date)
2035 (error "Cursor is not on a date!"))))))
2038 (defun insert-yearly-hebrew-diary-entry (arg)
2039 "Insert an annual diary entry for the day of the Hebrew year corresponding
2040 to the date indicated by point. Prefix arg will make the entry nonmarking."
2042 (let* ((calendar-date-display-form
2043 (if european-calendar-style
2044 '(day " " monthname
)
2045 '(monthname " " day
)))
2046 (calendar-month-name-array
2047 calendar-hebrew-month-name-array-leap-year
))
2050 hebrew-diary-entry-symbol
2051 (calendar-date-string
2052 (calendar-hebrew-from-absolute
2053 (calendar-absolute-from-gregorian
2054 (or (calendar-cursor-to-date)
2055 (error "Cursor is not on a date!"))))))
2058 (defun insert-islamic-diary-entry (arg)
2059 "Insert a diary entry for the Islamic date corresponding to the date
2060 indicated by point. Prefix arg will make the entry nonmarking."
2062 (let* ((calendar-date-display-form
2063 (if european-calendar-style
2064 '(day " " monthname
" " year
)
2065 '(monthname " " day
", " year
)))
2066 (calendar-month-name-array calendar-islamic-month-name-array
))
2069 islamic-diary-entry-symbol
2070 (calendar-date-string
2071 (calendar-islamic-from-absolute
2072 (calendar-absolute-from-gregorian
2073 (or (calendar-cursor-to-date)
2074 (error "Cursor is not on a date!"))))))
2077 (defun insert-monthly-islamic-diary-entry (arg)
2078 "Insert a monthly diary entry for the day of the Islamic month corresponding
2079 to the date indicated by point. Prefix arg will make the entry nonmarking."
2081 (let* ((calendar-date-display-form
2082 (if european-calendar-style
'(day " * ") '("* " day
)))
2083 (calendar-month-name-array calendar-islamic-month-name-array
))
2086 islamic-diary-entry-symbol
2087 (calendar-date-string
2088 (calendar-islamic-from-absolute
2089 (calendar-absolute-from-gregorian
2090 (or (calendar-cursor-to-date)
2091 (error "Cursor is not on a date!"))))))
2094 (defun insert-yearly-islamic-diary-entry (arg)
2095 "Insert an annual diary entry for the day of the Islamic year corresponding
2096 to the date indicated by point. Prefix arg will make the entry nonmarking."
2098 (let* ((calendar-date-display-form
2099 (if european-calendar-style
2100 '(day " " monthname
)
2101 '(monthname " " day
)))
2102 (calendar-month-name-array calendar-islamic-month-name-array
))
2105 islamic-diary-entry-symbol
2106 (calendar-date-string
2107 (calendar-islamic-from-absolute
2108 (calendar-absolute-from-gregorian
2109 (or (calendar-cursor-to-date)
2110 (error "Cursor is not on a date!"))))))
2115 ;;; diary.el ends here