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