|
0
|
1 ;;; calendar.el --- Calendar functions. -*-byte-compile-dynamic: t;-*-
|
|
|
2
|
|
|
3 ;;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994 Free Software
|
|
|
4 ;;; Foundation, Inc.
|
|
|
5
|
|
|
6 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
|
|
|
7 ;; Keywords: calendar
|
|
|
8 ;; Human-Keywords: calendar, Gregorian calendar, Julian calendar,
|
|
|
9 ;; Hebrew calendar, Islamic calendar, ISO calendar, Julian day number,
|
|
|
10 ;; diary, holidays
|
|
|
11
|
|
|
12 ;; This file is part of XEmacs.
|
|
|
13
|
|
|
14 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
15 ;; under the terms of the GNU General Public License as published by
|
|
|
16 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
17 ;; any later version.
|
|
|
18
|
|
|
19 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
20 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
22 ;; General Public License for more details.
|
|
|
23
|
|
|
24 ;; You should have received a copy of the GNU General Public License
|
|
70
|
25 ;; along with XEmacs; see the file COPYING. If not, write to the Free
|
|
|
26 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
0
|
27
|
|
|
28 ;;; Commentary:
|
|
|
29
|
|
|
30 ;; This collection of functions implements a calendar window. It
|
|
|
31 ;; generates a calendar for the current month, together with the previous
|
|
|
32 ;; and coming months, or for any other three-month period. The calendar
|
|
|
33 ;; can be scrolled forward and backward in the window to show months in
|
|
|
34 ;; the past or future; the cursor can move forward and backward by days,
|
|
|
35 ;; weeks, or months, making it possible, for instance, to jump to the
|
|
|
36 ;; date a specified number of days, weeks, or months from the date under
|
|
|
37 ;; the cursor. The user can display a list of holidays and other notable
|
|
|
38 ;; days for the period shown; the notable days can be marked on the
|
|
|
39 ;; calendar, if desired. The user can also specify that dates having
|
|
|
40 ;; corresponding diary entries (in a file that the user specifies) be
|
|
|
41 ;; marked; the diary entries for any date can be viewed in a separate
|
|
|
42 ;; window. The diary and the notable days can be viewed independently of
|
|
|
43 ;; the calendar. Dates can be translated from the (usual) Gregorian
|
|
|
44 ;; calendar to the day of the year/days remaining in year, to the ISO
|
|
|
45 ;; commercial calendar, to the Julian (old style) calendar, to the Hebrew
|
|
|
46 ;; calendar, to the Islamic calendar, to the French Revolutionary calendar,
|
|
|
47 ;; to the Mayan calendar, and to the astronomical (Julian) day number.
|
|
|
48 ;; When floating point is available, times of sunrise/sunset can be displayed,
|
|
|
49 ;; as can the phases of the moon. Appointment notification for diary entries
|
|
|
50 ;; is available.
|
|
|
51
|
|
|
52 ;; The following files are part of the calendar/diary code:
|
|
|
53
|
|
|
54 ;; cal-menu.el Menu support
|
|
|
55 ;; cal-x.el X-windows dedicated frame functions
|
|
|
56 ;; diary-lib.el, diary-ins.el Diary functions
|
|
|
57 ;; holidays.el Holiday functions
|
|
|
58 ;; cal-french.el French Revolutionary calendar
|
|
|
59 ;; cal-mayan.el Mayan calendars
|
|
|
60 ;; cal-dst.el Daylight savings time rules
|
|
|
61 ;; solar.el Sunrise/sunset, equinoxes/solstices
|
|
|
62 ;; lunar.el Phases of the moon
|
|
|
63 ;; appt.el Appointment notification
|
|
|
64
|
|
|
65 ;; Comments, corrections, and improvements should be sent to
|
|
|
66 ;; Edward M. Reingold Department of Computer Science
|
|
|
67 ;; (217) 333-6733 University of Illinois at Urbana-Champaign
|
|
|
68 ;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
|
|
|
69 ;; Urbana, Illinois 61801
|
|
|
70
|
|
|
71 ;; GNU Emacs users too numerous to list pointed out a variety of problems
|
|
|
72 ;; with earlier forms of the `infinite' sliding calendar and suggested some
|
|
|
73 ;; of the features included in this package. Especially significant in this
|
|
|
74 ;; regard was the suggestion of mark-diary-entries and view-diary-entries,
|
|
|
75 ;; together ideas for their implementation, by
|
|
|
76 ;; Michael S. Littman Cognitive Science Research Group
|
|
|
77 ;; (201) 829-5155 Bell Communications Research
|
|
|
78 ;; mlittman@wind.bellcore.com 445 South St. Box 1961 (2L-331)
|
|
|
79 ;; Morristown, NJ 07960
|
|
|
80
|
|
|
81 ;; The algorithms for the Hebrew calendar are those of the Rambam (Rabbi Moses
|
|
|
82 ;; Maimonides), from his Mishneh Torah, as implemented by
|
|
|
83 ;; Nachum Dershowitz Department of Computer Science
|
|
|
84 ;; (217) 333-4219 University of Illinois at Urbana-Champaign
|
|
|
85 ;; nachum@cs.uiuc.edu 1304 West Springfield Avenue
|
|
|
86 ;; Urbana, Illinois 61801
|
|
|
87
|
|
|
88 ;; Technical details of all the calendrical calculations can be found in
|
|
|
89
|
|
|
90 ;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold,
|
|
|
91 ;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990),
|
|
|
92 ;; pages 899-928. ``Calendrical Calculations, Part II: Three Historical
|
|
|
93 ;; Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. Clamen,
|
|
|
94 ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
|
|
|
95 ;; pages 383-404.
|
|
|
96
|
|
|
97 ;; Hard copies of these two papers can be obtained by sending email to
|
|
|
98 ;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and
|
|
|
99 ;; the message BODY containing your mailing address (snail).
|
|
|
100
|
|
|
101 ;;; Code:
|
|
|
102
|
|
134
|
103 (defgroup diary nil
|
|
|
104 "Diary customization"
|
|
|
105 :group 'calendar)
|
|
|
106
|
|
|
107 (defgroup holidays nil
|
|
|
108 "Holidays in calendar"
|
|
|
109 :group 'calendar)
|
|
|
110
|
|
0
|
111 (defun calendar-version ()
|
|
|
112 (interactive)
|
|
|
113 (message "Version 5.3, January 25, 1994"))
|
|
|
114
|
|
134
|
115 (defgroup appt nil
|
|
|
116 "Appointment notification"
|
|
|
117 :tag "Appointments"
|
|
|
118 :group 'calendar)
|
|
|
119
|
|
0
|
120
|
|
|
121 ;;;###autoload
|
|
134
|
122 (defcustom calendar-week-start-day 0
|
|
|
123 "*The day of the week on which a week in the calendar begins.
|
|
|
124 0 means Sunday (default), 1 means Monday, and so on."
|
|
|
125 :type 'integer
|
|
|
126 :group 'calendar)
|
|
|
127
|
|
|
128 ;;;###autoload
|
|
|
129 (defcustom calendar-offset 0
|
|
0
|
130 "*The offset of the principal month from the center of the calendar window.
|
|
|
131 0 means the principal month is in the center (default), -1 means on the left,
|
|
|
132 +1 means on the right. Larger (or smaller) values push the principal month off
|
|
134
|
133 the screen."
|
|
|
134 :type 'integer
|
|
|
135 :group 'calendar)
|
|
0
|
136
|
|
|
137 ;;;###autoload
|
|
134
|
138 (defcustom view-diary-entries-initially nil
|
|
0
|
139 "*Non-nil means display current date's diary entries on entry.
|
|
|
140 The diary is displayed in another window when the calendar is first displayed,
|
|
|
141 if the current date is visible. The number of days of diary entries displayed
|
|
134
|
142 is governed by the variable `number-of-diary-entries'."
|
|
|
143 :type 'boolean
|
|
|
144 :group 'diary)
|
|
0
|
145
|
|
|
146 ;;;###autoload
|
|
134
|
147 (defcustom number-of-diary-entries 1
|
|
0
|
148 "*Specifies how many days of diary entries are to be displayed initially.
|
|
|
149 This variable affects the diary display when the command M-x diary is used,
|
|
|
150 or if the value of the variable `view-diary-entries-initially' is t. For
|
|
|
151 example, if the default value 1 is used, then only the current day's diary
|
|
|
152 entries will be displayed. If the value 2 is used, then both the current
|
|
|
153 day's and the next day's entries will be displayed.
|
|
|
154
|
|
|
155 The value can also be a vector such as [0 2 2 2 2 4 1]; this value
|
|
|
156 says to display no diary entries on Sunday, the display the entries
|
|
|
157 for the current date and the day after on Monday through Thursday,
|
|
|
158 display Friday through Monday's entries on Friday, and display only
|
|
|
159 Saturday's entries on Saturday.
|
|
|
160
|
|
|
161 This variable does not affect the diary display with the `d' command
|
|
|
162 from the calendar; in that case, the prefix argument controls the
|
|
134
|
163 number of days of diary entries displayed."
|
|
|
164 :type 'integer
|
|
|
165 :group 'diary)
|
|
0
|
166
|
|
|
167 ;;;###autoload
|
|
134
|
168 (defcustom mark-diary-entries-in-calendar nil
|
|
0
|
169 "*Non-nil means mark dates with diary entries, in the calendar window.
|
|
134
|
170 The marking symbol is specified by the variable `diary-entry-marker'."
|
|
|
171 :type 'boolean
|
|
|
172 :group 'diary)
|
|
|
173
|
|
|
174 (defcustom diary-entry-marker
|
|
0
|
175 (progn
|
|
|
176 (make-face 'diary-face)
|
|
|
177 (cond ((face-differs-from-default-p 'diary-face) nil)
|
|
|
178 (t (set-face-foreground 'diary-face "red" 'global '(x color))
|
|
|
179 (set-face-highlight-p 'diary-face t 'global 'tty)
|
|
|
180 ;; avoid a weird problem when byte-compiling appt.el
|
|
|
181 ;; in batch mode.
|
|
|
182 (if (and (not noninteractive) (fboundp 'x-make-font-bold))
|
|
|
183 (let ((bfont (x-make-font-bold
|
|
|
184 (face-font-instance 'default)))
|
|
|
185 (mono-tag (list 'x 'mono))
|
|
|
186 (gray-tag (list 'x 'grayscale)))
|
|
|
187 (if bfont
|
|
|
188 (progn
|
|
|
189 (set-face-font 'diary-face bfont 'global mono-tag)
|
|
|
190 (set-face-font 'diary-face bfont 'global
|
|
|
191 gray-tag)))))))
|
|
|
192 'diary-face)
|
|
|
193 "*Used to mark dates that have diary entries.
|
|
134
|
194 Can be either a single-character string or a face."
|
|
|
195 :type '(choice string face)
|
|
|
196 :group 'diary)
|
|
|
197
|
|
|
198 (defcustom calendar-today-marker
|
|
0
|
199 (progn
|
|
|
200 (make-face 'calendar-today-face)
|
|
|
201 (if (not (face-differs-from-default-p 'calendar-today-face))
|
|
|
202 (set-face-underline-p 'calendar-today-face t))
|
|
|
203 'calendar-today-face)
|
|
|
204 "*Used to mark today's date.
|
|
134
|
205 Can be either a single-character string or a face."
|
|
|
206 :type '(choice string face)
|
|
|
207 :group 'calendar)
|
|
|
208
|
|
|
209 (defcustom calendar-holiday-marker
|
|
0
|
210 (progn
|
|
|
211 (make-face 'holiday-face)
|
|
|
212 (cond ((face-differs-from-default-p 'holiday-face) nil)
|
|
|
213 (t (let ((color-tag (list 'x 'color))
|
|
|
214 (mono-tag (list 'x 'mono))
|
|
|
215 (gray-tag (list 'x 'grayscale)))
|
|
|
216 (set-face-background 'holiday-face [default foreground] 'global
|
|
|
217 mono-tag)
|
|
|
218 (set-face-foreground 'holiday-face [default background] 'global
|
|
|
219 mono-tag)
|
|
|
220 (set-face-background 'holiday-face [default foreground] 'global
|
|
|
221 gray-tag)
|
|
|
222 (set-face-foreground 'holiday-face [default background] 'global
|
|
|
223 gray-tag)
|
|
|
224 (set-face-background 'holiday-face "pink" 'global color-tag)
|
|
|
225 (set-face-reverse-p 'holiday-face t 'global 'tty))))
|
|
|
226 'holiday-face)
|
|
|
227 "*Used to mark notable dates in the calendar.
|
|
134
|
228 Can be either a single-character string or a face."
|
|
|
229 :type '(choice string face)
|
|
|
230 :group 'holidays)
|
|
0
|
231
|
|
|
232 ;;;###autoload
|
|
134
|
233 (defcustom view-calendar-holidays-initially nil
|
|
0
|
234 "*Non-nil means display holidays for current three month period on entry.
|
|
|
235 The holidays are displayed in another window when the calendar is first
|
|
134
|
236 displayed."
|
|
|
237 :type 'boolean
|
|
|
238 :group 'holidays)
|
|
0
|
239
|
|
|
240 ;;;###autoload
|
|
134
|
241 (defcustom mark-holidays-in-calendar nil
|
|
0
|
242 "*Non-nil means mark dates of holidays in the calendar window.
|
|
134
|
243 The marking symbol is specified by the variable `calendar-holiday-marker'."
|
|
|
244 :type 'boolean
|
|
|
245 :group 'holidays)
|
|
0
|
246
|
|
|
247 ;;;###autoload
|
|
134
|
248 (defcustom all-hebrew-calendar-holidays nil
|
|
0
|
249 "*If nil, show only major holidays from the Hebrew calendar.
|
|
|
250 This means only those Jewish holidays that appear on secular calendars.
|
|
|
251
|
|
134
|
252 If t, show all the holidays that would appear in a complete Hebrew calendar."
|
|
|
253 :type 'boolean
|
|
|
254 :group 'holidays)
|
|
0
|
255
|
|
|
256 ;;;###autoload
|
|
134
|
257 (defcustom all-christian-calendar-holidays nil
|
|
0
|
258 "*If nil, show only major holidays from the Christian calendar.
|
|
|
259 This means only those Christian holidays that appear on secular calendars.
|
|
|
260
|
|
|
261 If t, show all the holidays that would appear in a complete Christian
|
|
134
|
262 calendar."
|
|
|
263 :type 'boolean
|
|
|
264 :group 'holidays)
|
|
0
|
265
|
|
|
266 ;;;###autoload
|
|
134
|
267 (defcustom all-islamic-calendar-holidays nil
|
|
0
|
268 "*If nil, show only major holidays from the Islamic calendar.
|
|
|
269 This means only those Islamic holidays that appear on secular calendars.
|
|
|
270
|
|
|
271 If t, show all the holidays that would appear in a complete Islamic
|
|
134
|
272 calendar."
|
|
|
273 :type 'boolean
|
|
|
274 :group 'holidays)
|
|
0
|
275
|
|
|
276 ;;;###autoload
|
|
134
|
277 (defcustom calendar-load-hook nil
|
|
0
|
278 "*List of functions to be called after the calendar is first loaded.
|
|
134
|
279 This is the place to add key bindings to `calendar-mode-map'."
|
|
|
280 :type 'hook
|
|
|
281 :group 'calendar)
|
|
0
|
282
|
|
|
283 ;;;###autoload
|
|
134
|
284 (defcustom initial-calendar-window-hook nil
|
|
0
|
285 "*List of functions to be called when the calendar window is first opened.
|
|
|
286 The functions invoked are called after the calendar window is opened, but
|
|
|
287 once opened is never called again. Leaving the calendar with the `q' command
|
|
134
|
288 and reentering it will cause these functions to be called again."
|
|
|
289 :type 'hook
|
|
|
290 :group 'calendar)
|
|
0
|
291
|
|
|
292 ;;;###autoload
|
|
134
|
293 (defcustom today-visible-calendar-hook nil
|
|
0
|
294 "*List of functions called whenever the current date is visible.
|
|
|
295 This can be used, for example, to replace today's date with asterisks; a
|
|
|
296 function `calendar-star-date' is included for this purpose:
|
|
|
297 (setq today-visible-calendar-hook 'calendar-star-date)
|
|
|
298 It can also be used to mark the current date with `calendar-today-marker';
|
|
|
299 a function is also provided for this:
|
|
|
300 (setq today-visible-calendar-hook 'calendar-mark-today)
|
|
|
301
|
|
|
302 The corresponding variable `today-invisible-calendar-hook' is the list of
|
|
|
303 functions called when the calendar function was called when the current
|
|
|
304 date is not visible in the window.
|
|
|
305
|
|
|
306 Other than the use of the provided functions, the changing of any
|
|
|
307 characters in the calendar buffer by the hooks may cause the failure of the
|
|
134
|
308 functions that move by days and weeks."
|
|
|
309 :type 'hook
|
|
|
310 :group 'calendar)
|
|
0
|
311
|
|
|
312 ;;;###autoload
|
|
134
|
313 (defcustom today-invisible-calendar-hook nil
|
|
0
|
314 "*List of functions called whenever the current date is not visible.
|
|
|
315
|
|
|
316 The corresponding variable `today-visible-calendar-hook' is the list of
|
|
|
317 functions called when the calendar function was called when the current
|
|
|
318 date is visible in the window.
|
|
|
319
|
|
|
320 Other than the use of the provided functions, the changing of any
|
|
|
321 characters in the calendar buffer by the hooks may cause the failure of the
|
|
134
|
322 functions that move by days and weeks."
|
|
|
323 :type 'hook
|
|
|
324 :group 'calendar)
|
|
0
|
325
|
|
|
326 ;;;###autoload
|
|
134
|
327 (defcustom diary-file "~/diary"
|
|
0
|
328 "*Name of the file in which one's personal diary of dates is kept.
|
|
|
329
|
|
|
330 The file's entries are lines in any of the forms
|
|
|
331
|
|
|
332 MONTH/DAY
|
|
|
333 MONTH/DAY/YEAR
|
|
|
334 MONTHNAME DAY
|
|
|
335 MONTHNAME DAY, YEAR
|
|
|
336 DAYNAME
|
|
|
337
|
|
|
338 at the beginning of the line; the remainder of the line is the diary entry
|
|
|
339 string for that date. MONTH and DAY are one or two digit numbers, YEAR is
|
|
|
340 a number and may be written in full or abbreviated to the final two digits.
|
|
|
341 If the date does not contain a year, it is generic and applies to any year.
|
|
|
342 DAYNAME entries apply to any date on which is on that day of the week.
|
|
|
343 MONTHNAME and DAYNAME can be spelled in full, abbreviated to three
|
|
|
344 characters (with or without a period), capitalized or not. Any of DAY,
|
|
|
345 MONTH, or MONTHNAME, YEAR can be `*' which matches any day, month, or year,
|
|
|
346 respectively.
|
|
|
347
|
|
|
348 The European style (in which the day precedes the month) can be used
|
|
|
349 instead, if you execute `european-calendar' when in the calendar, or set
|
|
|
350 `european-calendar-style' to t in your .emacs file. The European forms are
|
|
|
351
|
|
|
352 DAY/MONTH
|
|
|
353 DAY/MONTH/YEAR
|
|
|
354 DAY MONTHNAME
|
|
|
355 DAY MONTHNAME YEAR
|
|
|
356 DAYNAME
|
|
|
357
|
|
|
358 To revert to the default American style from the European style, execute
|
|
|
359 `american-calendar' in the calendar.
|
|
|
360
|
|
|
361 A diary entry can be preceded by the character
|
|
|
362 `diary-nonmarking-symbol' (ordinarily `&') to make that entry
|
|
|
363 nonmarking--that is, it will not be marked on dates in the calendar
|
|
|
364 window but will appear in a diary window.
|
|
|
365
|
|
|
366 Multiline diary entries are made by indenting lines after the first with
|
|
|
367 either a TAB or one or more spaces.
|
|
|
368
|
|
|
369 Lines not in one the above formats are ignored. Here are some sample diary
|
|
|
370 entries (in the default American style):
|
|
|
371
|
|
|
372 12/22/1988 Twentieth wedding anniversary!!
|
|
|
373 &1/1. Happy New Year!
|
|
|
374 10/22 Ruth's birthday.
|
|
|
375 21: Payday
|
|
|
376 Tuesday--weekly meeting with grad students at 10am
|
|
|
377 Supowit, Shen, Bitner, and Kapoor to attend.
|
|
|
378 1/13/89 Friday the thirteenth!!
|
|
|
379 &thu 4pm squash game with Lloyd.
|
|
|
380 mar 16 Dad's birthday
|
|
|
381 April 15, 1989 Income tax due.
|
|
|
382 &* 15 time cards due.
|
|
|
383
|
|
|
384 If the first line of a diary entry consists only of the date or day name with
|
|
|
385 no trailing blanks or punctuation, then that line is not displayed in the
|
|
|
386 diary window; only the continuation lines is shown. For example, the
|
|
|
387 single diary entry
|
|
|
388
|
|
|
389 02/11/1989
|
|
|
390 Bill Blattner visits Princeton today
|
|
|
391 2pm Cognitive Studies Committee meeting
|
|
|
392 2:30-5:30 Lizzie at Lawrenceville for `Group Initiative'
|
|
|
393 4:00pm Jamie Tappenden
|
|
|
394 7:30pm Dinner at George and Ed's for Alan Ryan
|
|
|
395 7:30-10:00pm dance at Stewart Country Day School
|
|
|
396
|
|
|
397 will appear in the diary window without the date line at the beginning. This
|
|
|
398 facility allows the diary window to look neater, but can cause confusion if
|
|
|
399 used with more than one day's entries displayed.
|
|
|
400
|
|
|
401 Diary entries can be based on Lisp sexps. For example, the diary entry
|
|
|
402
|
|
|
403 %%(diary-block 11 1 1990 11 10 1990) Vacation
|
|
|
404
|
|
|
405 causes the diary entry \"Vacation\" to appear from November 1 through November
|
|
|
406 10, 1990. Other functions available are `diary-float', `diary-anniversary',
|
|
|
407 `diary-cyclic', `diary-day-of-year', `diary-iso-date', `diary-french-date',
|
|
|
408 `diary-hebrew-date', `diary-islamic-date', `diary-mayan-date',
|
|
|
409 `diary-yahrzeit', `diary-sunrise-sunset', `diary-phases-of-moon',
|
|
|
410 `diary-parasha', `diary-omer', `diary-rosh-hodesh', and
|
|
|
411 `diary-sabbath-candles'. See the documentation for the function
|
|
|
412 `list-sexp-diary-entries' for more details.
|
|
|
413
|
|
|
414 Diary entries based on the Hebrew and/or the Islamic calendar are also
|
|
|
415 possible, but because these are somewhat slow, they are ignored
|
|
|
416 unless you set the `nongregorian-diary-listing-hook' and the
|
|
|
417 `nongregorian-diary-marking-hook' appropriately. See the documentation
|
|
|
418 for these functions for details.
|
|
|
419
|
|
|
420 Diary files can contain directives to include the contents of other files; for
|
|
134
|
421 details, see the documentation for the variable `list-diary-entries-hook'."
|
|
|
422 :type 'file
|
|
|
423 :group 'diary)
|
|
0
|
424
|
|
|
425 ;;;###autoload
|
|
134
|
426 (defcustom diary-nonmarking-symbol "&"
|
|
|
427 "*Symbol indicating that a diary entry is not to be marked in the calendar."
|
|
|
428 :type 'string
|
|
|
429 :group 'diary)
|
|
0
|
430
|
|
|
431 ;;;###autoload
|
|
134
|
432 (defcustom hebrew-diary-entry-symbol "H"
|
|
|
433 "*Symbol indicating a diary entry according to the Hebrew calendar."
|
|
|
434 :type 'string
|
|
|
435 :group 'diary)
|
|
0
|
436
|
|
|
437 ;;;###autoload
|
|
134
|
438 (defcustom islamic-diary-entry-symbol "I"
|
|
|
439 "*Symbol indicating a diary entry according to the Islamic calendar."
|
|
|
440 :type 'string
|
|
|
441 :group 'diary)
|
|
0
|
442
|
|
|
443 ;;;###autoload
|
|
134
|
444 (defcustom diary-include-string "#include"
|
|
0
|
445 "*The string indicating inclusion of another file of diary entries.
|
|
134
|
446 See the documentation for the function `include-other-diary-files'."
|
|
|
447 :type 'string
|
|
|
448 :group 'diary)
|
|
0
|
449
|
|
|
450 ;;;###autoload
|
|
134
|
451 (defcustom sexp-diary-entry-symbol "%%"
|
|
0
|
452 "*The string used to indicate a sexp diary entry in diary-file.
|
|
134
|
453 See the documentation for the function `list-sexp-diary-entries'."
|
|
|
454 :type 'string
|
|
|
455 :group 'diary)
|
|
0
|
456
|
|
|
457 ;;;###autoload
|
|
134
|
458 (defcustom abbreviated-calendar-year t
|
|
0
|
459 "*Interpret a two-digit year DD in a diary entry as either 19DD or 20DD.
|
|
|
460 For the Gregorian calendar; similarly for the Hebrew and Islamic calendars.
|
|
134
|
461 If this variable is nil, years must be written in full."
|
|
|
462 :type 'boolean
|
|
|
463 :group 'diary)
|
|
0
|
464
|
|
|
465 ;;;###autoload
|
|
134
|
466 (defcustom european-calendar-style nil
|
|
0
|
467 "*Use the European style of dates in the diary and in any displays.
|
|
|
468 If this variable is t, a date 1/2/1990 would be interpreted as February 1,
|
|
|
469 1990. The accepted European date styles are
|
|
|
470
|
|
|
471 DAY/MONTH
|
|
|
472 DAY/MONTH/YEAR
|
|
|
473 DAY MONTHNAME
|
|
|
474 DAY MONTHNAME YEAR
|
|
|
475 DAYNAME
|
|
|
476
|
|
|
477 Names can be capitalized or not, written in full, or abbreviated to three
|
|
134
|
478 characters with or without a period."
|
|
|
479 :type 'boolean
|
|
|
480 :group 'diary)
|
|
0
|
481
|
|
|
482 ;;;###autoload
|
|
134
|
483 (defcustom american-date-diary-pattern
|
|
0
|
484 '((month "/" day "[^/0-9]")
|
|
|
485 (month "/" day "/" year "[^0-9]")
|
|
|
486 (monthname " *" day "[^,0-9]")
|
|
|
487 (monthname " *" day ", *" year "[^0-9]")
|
|
|
488 (dayname "\\W"))
|
|
|
489 "*List of pseudo-patterns describing the American patterns of date used.
|
|
134
|
490 See the documentation of `diary-date-forms' for an explanation."
|
|
|
491 :type '(repeat (choice (cons :tag "Backup"
|
|
|
492 (const backup)
|
|
|
493 (repeat (list :inline t :format "%v"
|
|
|
494 (symbol :tag "Keyword")
|
|
|
495 (choice symbol regexp))))
|
|
|
496 (repeat (list :inline t :format "%v"
|
|
|
497 (symbol :tag "Keyword")
|
|
|
498 (choice symbol regexp)))))
|
|
|
499 :group 'diary)
|
|
0
|
500
|
|
|
501 ;;;###autoload
|
|
134
|
502 (defcustom european-date-diary-pattern
|
|
0
|
503 '((day "/" month "[^/0-9]")
|
|
|
504 (day "/" month "/" year "[^0-9]")
|
|
|
505 (backup day " *" monthname "\\W+\\<[^*0-9]")
|
|
|
506 (day " *" monthname " *" year "[^0-9]")
|
|
|
507 (dayname "\\W"))
|
|
|
508 "*List of pseudo-patterns describing the European patterns of date used.
|
|
134
|
509 See the documentation of `diary-date-forms' for an explanation."
|
|
|
510 :type '(repeat (choice (cons :tag "Backup"
|
|
|
511 (const backup)
|
|
|
512 (repeat (list :inline t :format "%v"
|
|
|
513 (symbol :tag "Keyword")
|
|
|
514 (choice symbol regexp))))
|
|
|
515 (repeat (list :inline t :format "%v"
|
|
|
516 (symbol :tag "Keyword")
|
|
|
517 (choice symbol regexp)))))
|
|
|
518 :group 'diary)
|
|
|
519
|
|
|
520 (defcustom diary-date-forms
|
|
0
|
521 (if european-calendar-style
|
|
|
522 european-date-diary-pattern
|
|
|
523 american-date-diary-pattern)
|
|
|
524 "*List of pseudo-patterns describing the forms of date used in the diary.
|
|
|
525 The patterns on the list must be MUTUALLY EXCLUSIVE and must should not match
|
|
|
526 any portion of the diary entry itself, just the date component.
|
|
|
527
|
|
|
528 A pseudo-pattern is a list of regular expressions and the keywords `month',
|
|
|
529 `day', `year', `monthname', and `dayname'. The keyword `monthname' will
|
|
|
530 match the name of the month, capitalized or not, or its three-letter
|
|
|
531 abbreviation, followed by a period or not; it will also match `*'.
|
|
|
532 Similarly, `dayname' will match the name of the day, capitalized or not, or
|
|
|
533 its three-letter abbreviation, followed by a period or not. The keywords
|
|
|
534 `month', `day', and `year' will match those numerical values, preceded by
|
|
|
535 arbitrarily many zeros; they will also match `*'.
|
|
|
536
|
|
|
537 The matching of the diary entries with the date forms is done with the
|
|
|
538 standard syntax table from Fundamental mode, but with the `*' changed so
|
|
|
539 that it is a word constituent.
|
|
|
540
|
|
|
541 If, to be mutually exclusive, a pseudo-pattern must match a portion of the
|
|
|
542 diary entry itself, the first element of the pattern MUST be `backup'. This
|
|
|
543 directive causes the date recognizer to back up to the beginning of the
|
|
|
544 current word of the diary entry, so in no case can the pattern match more than
|
|
134
|
545 a portion of the first word of the diary entry."
|
|
|
546 :type '(repeat (choice (cons :tag "Backup"
|
|
|
547 (const backup)
|
|
|
548 (repeat (list :inline t :format "%v"
|
|
|
549 (symbol :tag "Keyword")
|
|
|
550 (choice symbol regexp))))
|
|
|
551 (repeat (list :inline t :format "%v"
|
|
|
552 (symbol :tag "Keyword")
|
|
|
553 (choice symbol regexp)))))
|
|
|
554 :group 'diary)
|
|
0
|
555
|
|
|
556 ;;;###autoload
|
|
134
|
557 (defcustom european-calendar-display-form
|
|
0
|
558 '((if dayname (concat dayname ", ")) day " " monthname " " year)
|
|
|
559 "*Pseudo-pattern governing the way a date appears in the European style.
|
|
134
|
560 See the documentation of calendar-date-display-form for an explanation."
|
|
|
561 :type 'sexp
|
|
|
562 :group 'calendar)
|
|
0
|
563
|
|
|
564 ;;;###autoload
|
|
134
|
565 (defcustom american-calendar-display-form
|
|
0
|
566 '((if dayname (concat dayname ", ")) monthname " " day ", " year)
|
|
|
567 "*Pseudo-pattern governing the way a date appears in the American style.
|
|
134
|
568 See the documentation of `calendar-date-display-form' for an explanation."
|
|
|
569 :type 'sexp
|
|
|
570 :group 'calendar)
|
|
|
571
|
|
|
572 (defcustom calendar-date-display-form
|
|
0
|
573 (if european-calendar-style
|
|
|
574 european-calendar-display-form
|
|
|
575 american-calendar-display-form)
|
|
|
576 "*Pseudo-pattern governing the way a date appears.
|
|
|
577
|
|
|
578 Used by the function `calendar-date-string', a pseudo-pattern is a list of
|
|
|
579 expressions that can involve the keywords `month', `day', and `year', all
|
|
|
580 numbers in string form, and `monthname' and `dayname', both alphabetic
|
|
|
581 strings. For example, the ISO standard would use the pseudo- pattern
|
|
|
582
|
|
|
583 '(year \"-\" month \"-\" day)
|
|
|
584
|
|
|
585 while a typical American form would be
|
|
|
586
|
|
|
587 '(month \"/\" day \"/\" (substring year -2))
|
|
|
588
|
|
|
589 and
|
|
|
590
|
|
|
591 '((format \"%9s, %9s %2s, %4s\" dayname monthname day year))
|
|
|
592
|
|
|
593 would give the usual American style in fixed-length fields.
|
|
|
594
|
|
134
|
595 See the documentation of the function `calendar-date-string'."
|
|
|
596 :type 'sexp
|
|
|
597 :group 'calendar)
|
|
0
|
598
|
|
|
599 (defun european-calendar ()
|
|
|
600 "Set the interpretation and display of dates to the European style."
|
|
|
601 (interactive)
|
|
|
602 (setq european-calendar-style t)
|
|
|
603 (setq calendar-date-display-form european-calendar-display-form)
|
|
|
604 (setq diary-date-forms european-date-diary-pattern)
|
|
|
605 (update-calendar-mode-line))
|
|
|
606
|
|
|
607 (defun american-calendar ()
|
|
|
608 "Set the interpretation and display of dates to the American style."
|
|
|
609 (interactive)
|
|
|
610 (setq european-calendar-style nil)
|
|
|
611 (setq calendar-date-display-form american-calendar-display-form)
|
|
|
612 (setq diary-date-forms american-date-diary-pattern)
|
|
|
613 (update-calendar-mode-line))
|
|
|
614
|
|
|
615 ;;;###autoload
|
|
134
|
616 (defcustom print-diary-entries-hook 'lpr-buffer
|
|
0
|
617 "*List of functions called after a temporary diary buffer is prepared.
|
|
|
618 The buffer shows only the diary entries currently visible in the diary
|
|
|
619 buffer. The default just does the printing. Other uses might include, for
|
|
|
620 example, rearranging the lines into order by day and time, saving the buffer
|
|
134
|
621 instead of deleting it, or changing the function used to do the printing."
|
|
|
622 :type 'hook
|
|
|
623 :group 'diary)
|
|
0
|
624
|
|
|
625 ;;;###autoload
|
|
134
|
626 (defcustom list-diary-entries-hook nil
|
|
0
|
627 "*List of functions called after diary file is culled for relevant entries.
|
|
|
628 It is to be used for diary entries that are not found in the diary file.
|
|
|
629
|
|
|
630 A function `include-other-diary-files' is provided for use as the value of
|
|
|
631 this hook. This function enables you to use shared diary files together
|
|
|
632 with your own. The files included are specified in the diary file by lines
|
|
|
633 of the form
|
|
|
634
|
|
|
635 #include \"filename\"
|
|
|
636
|
|
|
637 This is recursive; that is, #include directives in files thus included are
|
|
|
638 obeyed. You can change the \"#include\" to some other string by changing
|
|
|
639 the variable `diary-include-string'. When you use `include-other-diary-files'
|
|
|
640 as part of the list-diary-entries-hook, you will probably also want to use the
|
|
|
641 function `mark-included-diary-files' as part of `mark-diary-entries-hook'.
|
|
|
642
|
|
|
643 For example, you could use
|
|
|
644
|
|
|
645 (setq list-diary-entries-hook
|
|
|
646 '(include-other-diary-files sort-diary-entries))
|
|
|
647 (setq diary-display-hook 'fancy-diary-display)
|
|
|
648
|
|
|
649 in your `.emacs' file to cause the fancy diary buffer to be displayed with
|
|
|
650 diary entries from various included files, each day's entries sorted into
|
|
134
|
651 lexicographic order."
|
|
|
652 :type 'hook
|
|
|
653 :group 'diary)
|
|
0
|
654
|
|
|
655 ;;;###autoload
|
|
134
|
656 (defcustom diary-hook nil
|
|
0
|
657 "*List of functions called after the display of the diary.
|
|
134
|
658 Can be used for appointment notification."
|
|
|
659 :type 'hook
|
|
|
660 :group 'diary)
|
|
0
|
661
|
|
|
662 ;;;###autoload
|
|
134
|
663 (defcustom diary-display-hook nil
|
|
0
|
664 "*List of functions that handle the display of the diary.
|
|
|
665 If nil (the default), `simple-diary-display' is used. Use `ignore' for no
|
|
|
666 diary display.
|
|
|
667
|
|
|
668 Ordinarily, this just displays the diary buffer (with holidays indicated in
|
|
|
669 the mode line), if there are any relevant entries. At the time these
|
|
|
670 functions are called, the variable `diary-entries-list' is a list, in order
|
|
|
671 by date, of all relevant diary entries in the form of ((MONTH DAY YEAR)
|
|
|
672 STRING), where string is the diary entry for the given date. This can be
|
|
|
673 used, for example, a different buffer for display (perhaps combined with
|
|
|
674 holidays), or produce hard copy output.
|
|
|
675
|
|
|
676 A function `fancy-diary-display' is provided as an alternative
|
|
|
677 choice for this hook; this function prepares a special noneditable diary
|
|
|
678 buffer with the relevant diary entries that has neat day-by-day arrangement
|
|
|
679 with headings. The fancy diary buffer will show the holidays unless the
|
|
|
680 variable `holidays-in-diary-buffer' is set to nil. Ordinarily, the fancy
|
|
|
681 diary buffer will not show days for which there are no diary entries, even
|
|
|
682 if that day is a holiday; if you want such days to be shown in the fancy
|
|
134
|
683 diary buffer, set the variable `diary-list-include-blanks' to t."
|
|
|
684 :type 'hook
|
|
|
685 :group 'diary)
|
|
0
|
686
|
|
|
687 ;;;###autoload
|
|
134
|
688 (defcustom nongregorian-diary-listing-hook nil
|
|
0
|
689 "*List of functions called for listing diary file and included files.
|
|
|
690 As the files are processed for diary entries, these functions are used to cull
|
|
|
691 relevant entries. You can use either or both of `list-hebrew-diary-entries'
|
|
|
692 and `list-islamic-diary-entries'. The documentation for these functions
|
|
134
|
693 describes the style of such diary entries."
|
|
|
694 :type 'hook
|
|
|
695 :group 'diary)
|
|
0
|
696
|
|
|
697 ;;;###autoload
|
|
134
|
698 (defcustom mark-diary-entries-hook nil
|
|
0
|
699 "*List of functions called after marking diary entries in the calendar.
|
|
|
700
|
|
|
701 A function `mark-included-diary-files' is also provided for use as the
|
|
|
702 mark-diary-entries-hook; it enables you to use shared diary files together
|
|
|
703 with your own. The files included are specified in the diary file by lines
|
|
|
704 of the form
|
|
|
705 #include \"filename\"
|
|
|
706 This is recursive; that is, #include directives in files thus included are
|
|
|
707 obeyed. You can change the \"#include\" to some other string by changing the
|
|
|
708 variable `diary-include-string'. When you use `mark-included-diary-files' as
|
|
|
709 part of the mark-diary-entries-hook, you will probably also want to use the
|
|
134
|
710 function `include-other-diary-files' as part of `list-diary-entries-hook'."
|
|
|
711 :type 'hook
|
|
|
712 :group 'diary)
|
|
0
|
713
|
|
|
714 ;;;###autoload
|
|
134
|
715 (defcustom nongregorian-diary-marking-hook nil
|
|
0
|
716 "*List of functions called for marking diary file and included files.
|
|
|
717 As the files are processed for diary entries, these functions are used to cull
|
|
|
718 relevant entries. You can use either or both of `mark-hebrew-diary-entries'
|
|
|
719 and `mark-islamic-diary-entries'. The documentation for these functions
|
|
134
|
720 describes the style of such diary entries."
|
|
|
721 :type 'hook
|
|
|
722 :group 'diary)
|
|
0
|
723
|
|
|
724 ;;;###autoload
|
|
134
|
725 (defcustom diary-list-include-blanks nil
|
|
0
|
726 "*If nil, do not include days with no diary entry in the list of diary entries.
|
|
2
|
727 Such days will then not be shown in the fancy diary buffer, even if they
|
|
134
|
728 are holidays."
|
|
|
729 :type 'boolean
|
|
|
730 :group 'diary)
|
|
0
|
731
|
|
|
732 ;;;###autoload
|
|
134
|
733 (defcustom holidays-in-diary-buffer t
|
|
0
|
734 "*Non-nil means include holidays in the diary display.
|
|
|
735 The holidays appear in the mode line of the diary buffer, or in the
|
|
|
736 fancy diary buffer next to the date. This slows down the diary functions
|
|
134
|
737 somewhat; setting it to nil makes the diary display faster."
|
|
|
738 :type 'boolean
|
|
|
739 :group 'diary)
|
|
0
|
740
|
|
|
741 (defvar calendar-mark-ring nil)
|
|
|
742
|
|
|
743 ;;;###autoload
|
|
134
|
744 (defcustom general-holidays
|
|
0
|
745 '((holiday-fixed 1 1 "New Year's Day")
|
|
|
746 (holiday-float 1 1 3 "Martin Luther King Day")
|
|
|
747 (holiday-fixed 2 2 "Ground Hog Day")
|
|
|
748 (holiday-fixed 2 14 "Valentine's Day")
|
|
|
749 (holiday-float 2 1 3 "President's Day")
|
|
|
750 (holiday-fixed 3 17 "St. Patrick's Day")
|
|
|
751 (holiday-fixed 4 1 "April Fool's Day")
|
|
|
752 (holiday-float 5 0 2 "Mother's Day")
|
|
|
753 (holiday-float 5 1 -1 "Memorial Day")
|
|
|
754 (holiday-fixed 6 14 "Flag Day")
|
|
|
755 (holiday-float 6 0 3 "Father's Day")
|
|
|
756 (holiday-fixed 7 4 "Independence Day")
|
|
|
757 (holiday-float 9 1 1 "Labor Day")
|
|
|
758 (holiday-float 10 1 2 "Columbus Day")
|
|
|
759 (holiday-fixed 10 31 "Halloween")
|
|
|
760 (holiday-fixed 11 11 "Veteran's Day")
|
|
|
761 (holiday-float 11 4 4 "Thanksgiving"))
|
|
|
762 "*General holidays. Default value is for the United States.
|
|
134
|
763 See the documentation for `calendar-holidays' for details."
|
|
|
764 :type 'sexp
|
|
|
765 :group 'holidays)
|
|
0
|
766
|
|
|
767 ;;;###autoload
|
|
74
|
768 (put 'general-holidays 'risky-local-variable t)
|
|
|
769
|
|
0
|
770 ;;;###autoload
|
|
134
|
771 (defcustom local-holidays nil
|
|
0
|
772 "*Local holidays.
|
|
134
|
773 See the documentation for `calendar-holidays' for details."
|
|
|
774 :type 'sexp
|
|
|
775 :group 'holidays
|
|
|
776 :group 'local)
|
|
0
|
777
|
|
|
778 ;;;###autoload
|
|
74
|
779 (put 'local-holidays 'risky-local-variable t)
|
|
0
|
780 ;;;###autoload
|
|
134
|
781 (defcustom other-holidays nil
|
|
0
|
782 "*User defined holidays.
|
|
134
|
783 See the documentation for `calendar-holidays' for details."
|
|
|
784 :type 'sexp
|
|
|
785 :group 'holidays)
|
|
0
|
786
|
|
|
787 ;;;###autoload
|
|
74
|
788 (put 'other-holidays 'risky-local-variable t)
|
|
|
789
|
|
0
|
790 ;;;###autoload
|
|
|
791 (defvar hebrew-holidays-1
|
|
|
792 '((holiday-rosh-hashanah-etc)
|
|
|
793 (if all-hebrew-calendar-holidays
|
|
|
794 (holiday-julian
|
|
|
795 11
|
|
|
796 (let* ((m displayed-month)
|
|
|
797 (y displayed-year)
|
|
|
798 (year))
|
|
|
799 (increment-calendar-month m y -1)
|
|
|
800 (let ((year (extract-calendar-year
|
|
|
801 (calendar-julian-from-absolute
|
|
|
802 (calendar-absolute-from-gregorian
|
|
|
803 (list m 1 y))))))
|
|
|
804 (if (zerop (% (1+ year) 4))
|
|
|
805 22
|
|
|
806 21))) "\"Tal Umatar\" (evening)"))))
|
|
|
807
|
|
|
808 ;;;###autoload
|
|
74
|
809 (put 'hebrew-holidays-1 'risky-local-variable t)
|
|
|
810
|
|
0
|
811 ;;;###autoload
|
|
|
812 (defvar hebrew-holidays-2
|
|
|
813 '((if all-hebrew-calendar-holidays
|
|
|
814 (holiday-hanukkah)
|
|
|
815 (holiday-hebrew 9 25 "Hanukkah"))
|
|
|
816 (if all-hebrew-calendar-holidays
|
|
|
817 (holiday-hebrew
|
|
|
818 10
|
|
|
819 (let ((h-year (extract-calendar-year
|
|
|
820 (calendar-hebrew-from-absolute
|
|
|
821 (calendar-absolute-from-gregorian
|
|
|
822 (list displayed-month 28 displayed-year))))))
|
|
|
823 (if (= (% (calendar-absolute-from-hebrew (list 10 10 h-year))
|
|
|
824 7)
|
|
|
825 6)
|
|
|
826 11 10))
|
|
|
827 "Tzom Teveth"))
|
|
|
828 (if all-hebrew-calendar-holidays
|
|
|
829 (holiday-hebrew 11 15 "Tu B'Shevat"))))
|
|
|
830
|
|
|
831 ;;;###autoload
|
|
74
|
832 (put 'hebrew-holidays-2 'risky-local-variable t)
|
|
|
833
|
|
0
|
834 ;;;###autoload
|
|
|
835 (defvar hebrew-holidays-3
|
|
|
836 '((if all-hebrew-calendar-holidays
|
|
|
837 (holiday-hebrew
|
|
|
838 11
|
|
|
839 (let ((m displayed-month)
|
|
|
840 (y displayed-year))
|
|
|
841 (increment-calendar-month m y 1)
|
|
|
842 (let* ((h-year (extract-calendar-year
|
|
|
843 (calendar-hebrew-from-absolute
|
|
|
844 (calendar-absolute-from-gregorian
|
|
|
845 (list m
|
|
|
846 (calendar-last-day-of-month m y)
|
|
|
847 y)))))
|
|
|
848 (s-s
|
|
|
849 (calendar-hebrew-from-absolute
|
|
|
850 (if (=
|
|
|
851 (% (calendar-absolute-from-hebrew
|
|
|
852 (list 7 1 h-year))
|
|
|
853 7)
|
|
|
854 6)
|
|
|
855 (calendar-dayname-on-or-before
|
|
|
856 6 (calendar-absolute-from-hebrew
|
|
|
857 (list 11 17 h-year)))
|
|
|
858 (calendar-dayname-on-or-before
|
|
|
859 6 (calendar-absolute-from-hebrew
|
|
|
860 (list 11 16 h-year))))))
|
|
|
861 (day (extract-calendar-day s-s)))
|
|
|
862 day))
|
|
|
863 "Shabbat Shirah"))))
|
|
74
|
864 ;;;###autoload
|
|
|
865 (put 'hebrew-holidays-3 'risky-local-variable t)
|
|
0
|
866
|
|
|
867 ;;;###autoload
|
|
|
868 (defvar hebrew-holidays-4
|
|
|
869 '((holiday-passover-etc)
|
|
|
870 (if (and all-hebrew-calendar-holidays
|
|
|
871 (let* ((m displayed-month)
|
|
|
872 (y displayed-year)
|
|
|
873 (year))
|
|
|
874 (increment-calendar-month m y -1)
|
|
|
875 (let ((year (extract-calendar-year
|
|
|
876 (calendar-julian-from-absolute
|
|
|
877 (calendar-absolute-from-gregorian
|
|
|
878 (list m 1 y))))))
|
|
|
879 (= 21 (% year 28)))))
|
|
|
880 (holiday-julian 3 26 "Kiddush HaHamah"))
|
|
|
881 (if all-hebrew-calendar-holidays
|
|
|
882 (holiday-tisha-b-av-etc))))
|
|
74
|
883 ;;;###autoload
|
|
|
884 (put 'hebrew-holidays-4 'risky-local-variable t)
|
|
0
|
885
|
|
|
886 ;;;###autoload
|
|
|
887 (defvar hebrew-holidays (append hebrew-holidays-1 hebrew-holidays-2
|
|
|
888 hebrew-holidays-3 hebrew-holidays-4)
|
|
|
889 "*Jewish holidays.
|
|
|
890 See the documentation for `calendar-holidays' for details.")
|
|
|
891
|
|
|
892 ;;;###autoload
|
|
74
|
893 (put 'hebrew-holidays 'risky-local-variable t)
|
|
|
894
|
|
0
|
895 ;;;###autoload
|
|
|
896 (defvar christian-holidays
|
|
|
897 '((if all-christian-calendar-holidays
|
|
|
898 (holiday-fixed 1 6 "Epiphany"))
|
|
|
899 (holiday-easter-etc)
|
|
|
900 (if all-christian-calendar-holidays
|
|
|
901 (holiday-greek-orthodox-easter))
|
|
|
902 (if all-christian-calendar-holidays
|
|
|
903 (holiday-fixed 8 15 "Assumption"))
|
|
|
904 (if all-christian-calendar-holidays
|
|
|
905 (holiday-advent))
|
|
|
906 (holiday-fixed 12 25 "Christmas")
|
|
|
907 (if all-christian-calendar-holidays
|
|
|
908 (holiday-julian 12 25 "Eastern Orthodox Christmas")))
|
|
|
909 "*Christian holidays.
|
|
|
910 See the documentation for `calendar-holidays' for details.")
|
|
|
911
|
|
|
912 ;;;###autoload
|
|
74
|
913 (put 'christian-holidays 'risky-local-variable t)
|
|
|
914
|
|
0
|
915 ;;;###autoload
|
|
|
916 (defvar islamic-holidays
|
|
|
917 '((holiday-islamic
|
|
|
918 1 1
|
|
|
919 (format "Islamic New Year %d"
|
|
|
920 (let ((m displayed-month)
|
|
|
921 (y displayed-year))
|
|
|
922 (increment-calendar-month m y 1)
|
|
|
923 (extract-calendar-year
|
|
|
924 (calendar-islamic-from-absolute
|
|
|
925 (calendar-absolute-from-gregorian
|
|
|
926 (list
|
|
|
927 m (calendar-last-day-of-month m y) y)))))))
|
|
|
928 (if all-islamic-calendar-holidays
|
|
|
929 (holiday-islamic 1 10 "Ashura"))
|
|
|
930 (if all-islamic-calendar-holidays
|
|
|
931 (holiday-islamic 3 12 "Mulad-al-Nabi"))
|
|
|
932 (if all-islamic-calendar-holidays
|
|
|
933 (holiday-islamic 7 26 "Shab-e-Mi'raj"))
|
|
|
934 (if all-islamic-calendar-holidays
|
|
|
935 (holiday-islamic 8 15 "Shab-e-Bara't"))
|
|
|
936 (holiday-islamic 9 1 "Ramadan Begins")
|
|
|
937 (if all-islamic-calendar-holidays
|
|
|
938 (holiday-islamic 9 27 "Shab-e Qadr"))
|
|
|
939 (if all-islamic-calendar-holidays
|
|
|
940 (holiday-islamic 10 1 "Id-al-Fitr"))
|
|
|
941 (if all-islamic-calendar-holidays
|
|
|
942 (holiday-islamic 12 10 "Id-al-Adha")))
|
|
|
943 "*Islamic holidays.
|
|
|
944 See the documentation for `calendar-holidays' for details.")
|
|
|
945
|
|
|
946 ;;;###autoload
|
|
74
|
947 (put 'islamic-holidays 'risky-local-variable t)
|
|
|
948
|
|
0
|
949 ;;;###autoload
|
|
|
950 (defvar solar-holidays
|
|
|
951 '((if (fboundp 'atan)
|
|
|
952 (solar-equinoxes-solstices))
|
|
|
953 (if (progn
|
|
|
954 (require 'cal-dst)
|
|
|
955 t)
|
|
|
956 (funcall
|
|
|
957 'holiday-sexp
|
|
|
958 calendar-daylight-savings-starts
|
|
|
959 '(format "Daylight Savings Time Begins %s"
|
|
|
960 (if (fboundp 'atan)
|
|
|
961 (solar-time-string
|
|
|
962 (/ calendar-daylight-savings-starts-time (float 60))
|
|
|
963 calendar-standard-time-zone-name)
|
|
|
964 ""))))
|
|
|
965 (funcall
|
|
|
966 'holiday-sexp
|
|
|
967 calendar-daylight-savings-ends
|
|
|
968 '(format "Daylight Savings Time Ends %s"
|
|
|
969 (if (fboundp 'atan)
|
|
|
970 (solar-time-string
|
|
|
971 (/ calendar-daylight-savings-ends-time (float 60))
|
|
|
972 calendar-daylight-time-zone-name)
|
|
|
973 ""))))
|
|
|
974 "*Sun-related holidays.
|
|
|
975 See the documentation for `calendar-holidays' for details.")
|
|
|
976
|
|
|
977 ;;;###autoload
|
|
74
|
978 (put 'solar-holidays 'risky-local-variable t)
|
|
|
979
|
|
|
980 ;;;###autoload
|
|
0
|
981 (defvar calendar-holidays
|
|
|
982 (append general-holidays local-holidays other-holidays
|
|
|
983 christian-holidays hebrew-holidays islamic-holidays
|
|
|
984 solar-holidays)
|
|
|
985 "*List of notable days for the command M-x holidays.
|
|
|
986
|
|
|
987 Additional holidays are easy to add to the list, just put them in the list
|
|
|
988 `other-holidays' in your .emacs file. Similarly, by setting any of
|
|
|
989 `general-holidays', `local-holidays' `christian-holidays', `hebrew-holidays',
|
|
|
990 `islamic-holidays', or `solar-holidays' to nil in your .emacs file, you can
|
|
|
991 eliminate unwanted categories of holidays. The intention is that (in the US)
|
|
|
992 `local-holidays' be set in site-init.el and `other-holidays' be set by the
|
|
|
993 user.
|
|
|
994
|
|
|
995 Entries on the list are expressions that return (possibly empty) lists of
|
|
|
996 items of the form ((month day year) string) of a holiday in the in the
|
|
|
997 three-month period centered around `displayed-month' of `displayed-year'.
|
|
|
998 Several basic functions are provided for this purpose:
|
|
|
999
|
|
|
1000 (holiday-fixed MONTH DAY STRING) is a fixed date on the Gregorian calendar
|
|
|
1001 (holiday-float MONTH DAYNAME K STRING &optional day) is the Kth DAYNAME in
|
|
|
1002 MONTH on the Gregorian calendar (0 for Sunday,
|
|
|
1003 etc.); K<0 means count back from the end of the
|
|
|
1004 month. An optional parameter DAY means the Kth
|
|
|
1005 DAYNAME after/before MONTH DAY.
|
|
|
1006 (holiday-hebrew MONTH DAY STRING) a fixed date on the Hebrew calendar
|
|
|
1007 (holiday-islamic MONTH DAY STRING) a fixed date on the Islamic calendar
|
|
|
1008 (holiday-julian MONTH DAY STRING) a fixed date on the Julian calendar
|
|
|
1009 (holiday-sexp SEXP STRING) SEXP is a Gregorian-date-valued expression
|
|
|
1010 in the variable `year'; if it evaluates to
|
|
|
1011 a visible date, that's the holiday; if it
|
|
|
1012 evaluates to nil, there's no holiday. STRING
|
|
|
1013 is an expression in the variable `date'.
|
|
|
1014
|
|
|
1015 For example, to add Bastille Day, celebrated in France on July 14, add
|
|
|
1016
|
|
|
1017 (holiday-fixed 7 14 \"Bastille Day\")
|
|
|
1018
|
|
|
1019 to the list. To add Hurricane Supplication Day, celebrated in the Virgin
|
|
|
1020 Islands on the fourth Monday in August, add
|
|
|
1021
|
|
|
1022 (holiday-float 8 1 4 \"Hurricane Supplication Day\")
|
|
|
1023
|
|
|
1024 to the list (the last Monday would be specified with `-1' instead of `4').
|
|
|
1025 To add the last day of Hanukkah to the list, use
|
|
|
1026
|
|
|
1027 (holiday-hebrew 10 2 \"Last day of Hanukkah\")
|
|
|
1028
|
|
|
1029 since the Hebrew months are numbered with 1 starting from Nisan, while to
|
|
|
1030 add the Islamic feast celebrating Mohammed's birthday use
|
|
|
1031
|
|
|
1032 (holiday-islamic 3 12 \"Mohammed's Birthday\")
|
|
|
1033
|
|
|
1034 since the Islamic months are numbered from 1 starting with Muharram. To
|
|
|
1035 add Thomas Jefferson's birthday, April 2, 1743 (Julian), use
|
|
|
1036
|
|
|
1037 (holiday-julian 4 2 \"Jefferson's Birthday\")
|
|
|
1038
|
|
|
1039 To include a holiday conditionally, use the sexp form or a conditional. For
|
|
|
1040 example, to include American presidential elections, which occur on the first
|
|
|
1041 Tuesday after the first Monday in November of years divisible by 4, add
|
|
|
1042
|
|
|
1043 (holiday-sexp
|
|
|
1044 (if (zerop (% year 4))
|
|
|
1045 (calendar-gregorian-from-absolute
|
|
|
1046 (1+ (calendar-dayname-on-or-before
|
|
|
1047 1 (+ 6 (calendar-absolute-from-gregorian
|
|
|
1048 (list 11 1 year)))))))
|
|
|
1049 \"US Presidential Election\")
|
|
|
1050
|
|
|
1051 or
|
|
|
1052
|
|
|
1053 (if (zerop (% displayed-year 4))
|
|
|
1054 (holiday-fixed 11
|
|
|
1055 (extract-calendar-day
|
|
|
1056 (calendar-gregorian-from-absolute
|
|
|
1057 (1+ (calendar-dayname-on-or-before
|
|
|
1058 1 (+ 6 (calendar-absolute-from-gregorian
|
|
|
1059 (list 11 1 displayed-year)))))))
|
|
|
1060 \"US Presidential Election\"))
|
|
|
1061
|
|
|
1062 to the list. To include the phases of the moon, add
|
|
|
1063
|
|
|
1064 (lunar-phases)
|
|
|
1065
|
|
|
1066 to the holiday list, where `lunar-phases' is an Emacs-Lisp function that
|
|
|
1067 you've written to return a (possibly empty) list of the relevant VISIBLE dates
|
|
|
1068 with descriptive strings such as
|
|
|
1069
|
|
|
1070 (((2 6 1989) \"New Moon\") ((2 12 1989) \"First Quarter Moon\") ... ).")
|
|
|
1071
|
|
74
|
1072 ;;;###autoload
|
|
|
1073 (put 'calendar-holidays 'risky-local-variable t)
|
|
|
1074
|
|
0
|
1075 (defconst calendar-buffer "*Calendar*"
|
|
|
1076 "Name of the buffer used for the calendar.")
|
|
|
1077
|
|
|
1078 (defconst holiday-buffer "*Holidays*"
|
|
|
1079 "Name of the buffer used for the displaying the holidays.")
|
|
|
1080
|
|
|
1081 (defconst fancy-diary-buffer "*Fancy Diary Entries*"
|
|
|
1082 "Name of the buffer used for the optional fancy display of the diary.")
|
|
|
1083
|
|
|
1084 (defconst lunar-phases-buffer "*Phases of Moon*"
|
|
|
1085 "Name of the buffer used for the lunar phases.")
|
|
|
1086
|
|
|
1087 (defmacro increment-calendar-month (mon yr n)
|
|
|
1088 "Move the variables MON and YR to the month and year by N months.
|
|
|
1089 Forward if N is positive or backward if N is negative."
|
|
|
1090 (` (let (( macro-y (+ (* (, yr) 12) (, mon) -1 (, n) )))
|
|
|
1091 (setq (, mon) (1+ (% macro-y 12) ))
|
|
|
1092 (setq (, yr) (/ macro-y 12)))))
|
|
|
1093
|
|
|
1094 (defmacro calendar-for-loop (var from init to final do &rest body)
|
|
|
1095 "Execute a for loop."
|
|
|
1096 (` (let (( (, var) (1- (, init)) ))
|
|
|
1097 (while (>= (, final) (setq (, var) (1+ (, var))))
|
|
|
1098 (,@ body)))))
|
|
|
1099
|
|
|
1100 (defmacro calendar-sum (index initial condition expression)
|
|
|
1101 "For INDEX = INITIAL et seq, as long as CONDITION holds, sum EXPRESSION."
|
|
|
1102 (` (let (( (, index) (, initial))
|
|
|
1103 (sum 0))
|
|
|
1104 (while (, condition)
|
|
|
1105 (setq sum (+ sum (, expression) ))
|
|
|
1106 (setq (, index) (1+ (, index))))
|
|
|
1107 sum)))
|
|
|
1108
|
|
|
1109 ;; The following are in-line for speed; they can be called thousands of times
|
|
|
1110 ;; when looking up holidays or processing the diary. Here, for example, are
|
|
|
1111 ;; the numbers of calls to calendar/diary/holiday functions in preparing the
|
|
|
1112 ;; fancy diary display, for a moderately complex diary file, with functions
|
|
|
1113 ;; used instead of macros. There were a total of 10000 such calls:
|
|
|
1114 ;;
|
|
|
1115 ;; 1934 extract-calendar-month
|
|
|
1116 ;; 1852 extract-calendar-year
|
|
|
1117 ;; 1819 extract-calendar-day
|
|
|
1118 ;; 845 calendar-leap-year-p
|
|
|
1119 ;; 837 calendar-day-number
|
|
|
1120 ;; 775 calendar-absolute-from-gregorian
|
|
|
1121 ;; 346 calendar-last-day-of-month
|
|
|
1122 ;; 286 hebrew-calendar-last-day-of-month
|
|
|
1123 ;; 188 hebrew-calendar-leap-year-p
|
|
|
1124 ;; 180 hebrew-calendar-elapsed-days
|
|
|
1125 ;; 163 hebrew-calendar-last-month-of-year
|
|
|
1126 ;; 66 calendar-date-compare
|
|
|
1127 ;; 65 hebrew-calendar-days-in-year
|
|
|
1128 ;; 60 calendar-absolute-from-julian
|
|
|
1129 ;; 50 calendar-absolute-from-hebrew
|
|
|
1130 ;; 43 calendar-date-equal
|
|
|
1131 ;; 38 calendar-gregorian-from-absolute
|
|
|
1132 ;; .
|
|
|
1133 ;; .
|
|
|
1134 ;; .
|
|
|
1135 ;;
|
|
|
1136 ;; The use of these seven macros eliminates the overhead of 92% of the function
|
|
|
1137 ;; calls; it's faster this way.
|
|
|
1138
|
|
|
1139 (defsubst extract-calendar-month (date)
|
|
|
1140 "Extract the month part of DATE which has the form (month day year)."
|
|
|
1141 (car date))
|
|
|
1142
|
|
|
1143 (defsubst extract-calendar-day (date)
|
|
|
1144 "Extract the day part of DATE which has the form (month day year)."
|
|
|
1145 (car (cdr date)))
|
|
|
1146
|
|
|
1147 (defsubst extract-calendar-year (date)
|
|
|
1148 "Extract the year part of DATE which has the form (month day year)."
|
|
|
1149 (car (cdr (cdr date))))
|
|
|
1150
|
|
|
1151 (defsubst calendar-leap-year-p (year)
|
|
|
1152 "Returns t if YEAR is a Gregorian leap year."
|
|
|
1153 (and (zerop (% year 4))
|
|
|
1154 (or (not (zerop (% year 100)))
|
|
|
1155 (zerop (% year 400)))))
|
|
|
1156
|
|
|
1157 ;; The foregoing is a bit faster, but not as clear as the following:
|
|
|
1158 ;;
|
|
|
1159 ;;(defsubst calendar-leap-year-p (year)
|
|
|
1160 ;; "Returns t if YEAR is a Gregorian leap year."
|
|
|
1161 ;; (or
|
|
|
1162 ;; (and (= (% year 4) 0)
|
|
|
1163 ;; (/= (% year 100) 0))
|
|
|
1164 ;; (= (% year 400) 0)))
|
|
|
1165
|
|
|
1166 (defsubst calendar-last-day-of-month (month year)
|
|
|
1167 "The last day in MONTH during YEAR."
|
|
|
1168 (if (and (= month 2) (calendar-leap-year-p year))
|
|
|
1169 29
|
|
|
1170 (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
|
|
|
1171
|
|
|
1172 ;; An explanation of the calculation can be found in PascAlgorithms by
|
|
|
1173 ;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988.
|
|
|
1174
|
|
|
1175 (defsubst calendar-day-number (date)
|
|
|
1176 "Return the day number within the year of the date DATE.
|
|
|
1177 For example, (calendar-day-number '(1 1 1987)) returns the value 1,
|
|
|
1178 while (calendar-day-number '(12 31 1980)) returns 366."
|
|
|
1179 (let* ((month (extract-calendar-month date))
|
|
|
1180 (day (extract-calendar-day date))
|
|
|
1181 (year (extract-calendar-year date))
|
|
|
1182 (day-of-year (+ day (* 31 (1- month)))))
|
|
|
1183 (if (> month 2)
|
|
|
1184 (progn
|
|
|
1185 (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
|
|
|
1186 (if (calendar-leap-year-p year)
|
|
|
1187 (setq day-of-year (1+ day-of-year)))))
|
|
|
1188 day-of-year))
|
|
|
1189
|
|
|
1190 (defsubst calendar-absolute-from-gregorian (date)
|
|
|
1191 "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
|
|
|
1192 The Gregorian date Sunday, December 31, 1 BC is imaginary."
|
|
|
1193 (let ((prior-years (1- (extract-calendar-year date))))
|
|
|
1194 (+ (calendar-day-number date);; Days this year
|
|
|
1195 (* 365 prior-years);; + Days in prior years
|
|
|
1196 (/ prior-years 4);; + Julian leap years
|
|
|
1197 (- (/ prior-years 100));; - century years
|
|
|
1198 (/ prior-years 400))));; + Gregorian leap years
|
|
|
1199
|
|
|
1200 ;;;###autoload
|
|
|
1201 (defun calendar (&optional arg)
|
|
|
1202 "Display a three-month calendar in another window.
|
|
|
1203 The three months appear side by side, with the current month in the middle
|
|
|
1204 surrounded by the previous and next months. The cursor is put on today's date.
|
|
|
1205
|
|
|
1206 If called with an optional prefix argument, prompts for month and year.
|
|
|
1207
|
|
|
1208 This function is suitable for execution in a .emacs file; appropriate setting
|
|
|
1209 of the variable `view-diary-entries-initially' will cause the diary entries for
|
|
|
1210 the current date to be displayed in another window. The value of the variable
|
|
|
1211 `number-of-diary-entries' controls the number of days of diary entries
|
|
|
1212 displayed upon initial display of the calendar.
|
|
|
1213
|
|
|
1214 An optional prefix argument ARG causes the calendar displayed to be ARG
|
|
|
1215 months in the future if ARG is positive or in the past if ARG is negative;
|
|
|
1216 in this case the cursor goes on the first day of the month.
|
|
|
1217
|
|
|
1218 Once in the calendar window, future or past months can be moved into view.
|
|
|
1219 Arbitrary months can be displayed, or the calendar can be scrolled forward
|
|
|
1220 or backward.
|
|
|
1221
|
|
|
1222 The cursor can be moved forward or backward by one day, one week, one month,
|
|
|
1223 or one year. All of these commands take prefix arguments which, when negative,
|
|
|
1224 cause movement in the opposite direction. For convenience, the digit keys
|
|
|
1225 and the minus sign are automatically prefixes. The window is replotted as
|
|
|
1226 necessary to display the desired date.
|
|
|
1227
|
|
|
1228 Diary entries can be marked on the calendar or displayed in another window.
|
|
|
1229
|
|
|
1230 Use M-x describe-mode for details of the key bindings in the calendar window.
|
|
|
1231
|
|
|
1232 The Gregorian calendar is assumed.
|
|
|
1233
|
|
|
1234 After loading the calendar, the hooks given by the variable
|
|
|
1235 `calendar-load-hook' are run. This is the place to add key bindings to the
|
|
|
1236 calendar-mode-map.
|
|
|
1237
|
|
|
1238 After preparing the calendar window initially, the hooks given by the variable
|
|
|
1239 `initial-calendar-window-hook' are run.
|
|
|
1240
|
|
|
1241 The hooks given by the variable `today-visible-calendar-hook' are run
|
|
|
1242 everytime the calendar window gets scrolled, if the current date is visible
|
|
|
1243 in the window. If it is not visible, the hooks given by the variable
|
|
|
1244 `today-invisible-calendar-hook' are run. Thus, for example, setting
|
|
|
1245 `today-visible-calendar-hook' to 'calendar-star-date will cause today's date
|
|
|
1246 to be replaced by asterisks to highlight it whenever it is in the window."
|
|
|
1247 (interactive "P")
|
|
|
1248 (set-buffer (get-buffer-create calendar-buffer))
|
|
|
1249 (calendar-mode)
|
|
|
1250 (let* ((pop-up-windows t)
|
|
|
1251 (split-height-threshold 1000)
|
|
|
1252 (date (if arg
|
|
|
1253 (calendar-read-date t)
|
|
|
1254 (calendar-current-date)))
|
|
|
1255 (month (extract-calendar-month date))
|
|
|
1256 (year (extract-calendar-year date)))
|
|
|
1257 (pop-to-buffer calendar-buffer)
|
|
|
1258 (increment-calendar-month month year (- calendar-offset))
|
|
|
1259 (generate-calendar-window month year)
|
|
|
1260 (if (and view-diary-entries-initially (calendar-date-is-visible-p date))
|
|
|
1261 (view-diary-entries
|
|
|
1262 (if (vectorp number-of-diary-entries)
|
|
|
1263 (aref number-of-diary-entries (calendar-day-of-week date))
|
|
|
1264 number-of-diary-entries))))
|
|
|
1265 (let* ((diary-buffer (get-file-buffer diary-file))
|
|
|
1266 (diary-window (if diary-buffer (get-buffer-window diary-buffer)))
|
|
|
1267 (split-height-threshold (if diary-window 2 1000)))
|
|
|
1268 (if view-calendar-holidays-initially
|
|
|
1269 (list-calendar-holidays)))
|
|
|
1270 (run-hooks 'initial-calendar-window-hook))
|
|
|
1271
|
|
|
1272 (autoload 'view-diary-entries "diary-lib"
|
|
|
1273 "Prepare and display a buffer with diary entries.
|
|
|
1274 Searches your diary file for entries that match ARG days starting with
|
|
|
1275 the date indicated by the cursor position in the displayed three-month
|
|
|
1276 calendar."
|
|
|
1277 t)
|
|
|
1278
|
|
|
1279 (autoload 'calendar-sunrise-sunset "solar"
|
|
|
1280 "Local time of sunrise and sunset for date under cursor."
|
|
|
1281 t)
|
|
|
1282
|
|
|
1283 (autoload 'calendar-phases-of-moon "lunar"
|
|
|
1284 "Create a buffer of the phases of the moon for the current calendar window."
|
|
|
1285 t)
|
|
|
1286
|
|
|
1287 (autoload 'calendar-print-french-date "cal-french"
|
|
|
1288 "Show the French Revolutionary calendar equivalent of the date under the cursor."
|
|
|
1289 t)
|
|
|
1290
|
|
|
1291 (autoload 'calendar-goto-french-date "cal-french"
|
|
|
1292 "Move cursor to French Revolutionary date."
|
|
|
1293 t)
|
|
|
1294
|
|
|
1295 (autoload 'calendar-french-date-string "cal-french"
|
|
|
1296 "String of French Revolutionary date of Gregorian DATE."
|
|
|
1297 t)
|
|
|
1298
|
|
|
1299 (autoload 'calendar-mayan-date-string "cal-mayan"
|
|
|
1300 "String of Mayan date of Gregorian DATE."
|
|
|
1301 t)
|
|
|
1302
|
|
|
1303 (autoload 'calendar-print-mayan-date "cal-mayan"
|
|
|
1304 "Show the Mayan long count, Tzolkin, and Haab equivalents of the date under the cursor."
|
|
|
1305 t)
|
|
|
1306
|
|
|
1307 (autoload 'calendar-goto-mayan-long-count-date "cal-mayan"
|
|
|
1308 "Move cursor to Mayan long count date."
|
|
|
1309 t)
|
|
|
1310
|
|
|
1311 (autoload 'calendar-next-haab-date "cal-mayan"
|
|
|
1312 "Move cursor to next instance of Mayan Haab date."
|
|
|
1313 t)
|
|
|
1314
|
|
|
1315 (autoload 'calendar-previous-haab-date "cal-mayan"
|
|
|
1316 "Move cursor to previous instance of Mayan Haab date."
|
|
|
1317 t)
|
|
|
1318
|
|
|
1319 (autoload 'calendar-next-tzolkin-date "cal-mayan"
|
|
|
1320 "Move cursor to next instance of Mayan Tzolkin date."
|
|
|
1321 t)
|
|
|
1322
|
|
|
1323 (autoload 'calendar-previous-tzolkin-date "cal-mayan"
|
|
|
1324 "Move cursor to previous instance of Mayan Tzolkin date."
|
|
|
1325 t)
|
|
|
1326
|
|
|
1327 (autoload 'calendar-next-calendar-round-date "cal-mayan"
|
|
|
1328 "Move cursor to next instance of Mayan Haab/Tzoklin combination."
|
|
|
1329 t)
|
|
|
1330
|
|
|
1331 (autoload 'calendar-previous-calendar-round-date "cal-mayan"
|
|
|
1332 "Move cursor to previous instance of Mayan Haab/Tzoklin combination."
|
|
|
1333 t)
|
|
|
1334
|
|
|
1335 (autoload 'show-all-diary-entries "diary-lib"
|
|
|
1336 "Show all of the diary entries in the diary file.
|
|
|
1337 This function gets rid of the selective display of the diary file so that
|
|
|
1338 all entries, not just some, are visible. If there is no diary buffer, one
|
|
|
1339 is created."
|
|
|
1340 t)
|
|
|
1341
|
|
|
1342 (autoload 'mark-diary-entries "diary-lib"
|
|
|
1343 "Mark days in the calendar window that have diary entries.
|
|
|
1344 Each entry in diary file visible in the calendar window is marked."
|
|
|
1345 t)
|
|
|
1346
|
|
|
1347 (autoload 'insert-diary-entry "diary-ins"
|
|
|
1348 "Insert a diary entry for the date indicated by point."
|
|
|
1349 t)
|
|
|
1350
|
|
|
1351 (autoload 'insert-weekly-diary-entry "diary-ins"
|
|
|
1352 "Insert a weekly diary entry for the day of the week indicated by point."
|
|
|
1353 t)
|
|
|
1354
|
|
|
1355
|
|
|
1356 (autoload 'insert-monthly-diary-entry "diary-ins"
|
|
|
1357 "Insert a monthly diary entry for the day of the month indicated by point."
|
|
|
1358 t)
|
|
|
1359
|
|
|
1360 (autoload 'insert-yearly-diary-entry "diary-ins"
|
|
|
1361 "Insert an annual diary entry for the day of the year indicated by point."
|
|
|
1362 t)
|
|
|
1363
|
|
|
1364 (autoload 'insert-anniversary-diary-entry "diary-ins"
|
|
|
1365 "Insert an anniversary diary entry for the date indicated by point."
|
|
|
1366 t)
|
|
|
1367
|
|
|
1368 (autoload 'insert-block-diary-entry "diary-ins"
|
|
|
1369 "Insert a block diary entry for the dates indicated by point and mark."
|
|
|
1370 t)
|
|
|
1371
|
|
|
1372 (autoload 'insert-cyclic-diary-entry "diary-ins"
|
|
|
1373 "Insert a cyclic diary entry starting at the date indicated by point."
|
|
|
1374 t)
|
|
|
1375
|
|
|
1376 (autoload 'insert-hebrew-diary-entry "diary-ins"
|
|
|
1377 "Insert a diary entry for the Hebrew date corresponding to the date
|
|
|
1378 indicated by point."
|
|
|
1379 t)
|
|
|
1380
|
|
|
1381 (autoload 'insert-monthly-hebrew-diary-entry "diary-ins"
|
|
|
1382 "Insert a monthly diary entry for the day of the Hebrew month corresponding
|
|
|
1383 to the date indicated by point."
|
|
|
1384 t)
|
|
|
1385
|
|
|
1386 (autoload 'insert-yearly-hebrew-diary-entry "diary-ins"
|
|
|
1387 "Insert an annual diary entry for the day of the Hebrew year corresponding
|
|
|
1388 to the date indicated by point."
|
|
|
1389 t)
|
|
|
1390
|
|
|
1391 (autoload 'insert-islamic-diary-entry "diary-ins"
|
|
|
1392 "Insert a diary entry for the Islamic date corresponding to the date
|
|
|
1393 indicated by point."
|
|
|
1394 t)
|
|
|
1395
|
|
|
1396 (autoload 'insert-monthly-islamic-diary-entry "diary-ins"
|
|
|
1397 "Insert a monthly diary entry for the day of the Islamic month corresponding
|
|
|
1398 to the date indicated by point."
|
|
|
1399 t)
|
|
|
1400
|
|
|
1401 (autoload 'insert-yearly-islamic-diary-entry "diary-ins"
|
|
|
1402 "Insert an annual diary entry for the day of the Islamic year corresponding
|
|
|
1403 to the date indicated by point."
|
|
|
1404 t)
|
|
|
1405
|
|
|
1406 (autoload 'list-calendar-holidays "holidays"
|
|
|
1407 "Create a buffer containing the holidays for the current calendar window.
|
|
|
1408 The holidays are those in the list `calendar-notable-days'. Returns t if any
|
|
|
1409 holidays are found, nil if not."
|
|
|
1410 t)
|
|
|
1411
|
|
|
1412 (autoload 'mark-calendar-holidays "holidays"
|
|
|
1413 "Mark notable days in the calendar window."
|
|
|
1414 t)
|
|
|
1415
|
|
|
1416 (autoload 'calendar-cursor-holidays "holidays"
|
|
|
1417 "Find holidays for the date specified by the cursor in the calendar window."
|
|
|
1418 t)
|
|
|
1419
|
|
|
1420 (defun generate-calendar-window (&optional mon yr)
|
|
|
1421 "Generate the calendar window for the current date.
|
|
|
1422 Or, for optional MON, YR."
|
|
|
1423 (let* ((buffer-read-only nil)
|
|
|
1424 (today (calendar-current-date))
|
|
|
1425 (month (extract-calendar-month today))
|
|
|
1426 (day (extract-calendar-day today))
|
|
|
1427 (year (extract-calendar-year today))
|
|
|
1428 (today-visible
|
|
|
1429 (or (not mon)
|
|
|
1430 (let ((offset (calendar-interval mon yr month year)))
|
|
|
1431 (and (<= offset 1) (>= offset -1)))))
|
|
|
1432 (day-in-week (calendar-day-of-week today)))
|
|
|
1433 (update-calendar-mode-line)
|
|
|
1434 (if mon
|
|
|
1435 (generate-calendar mon yr)
|
|
|
1436 (generate-calendar month year))
|
|
|
1437 (calendar-cursor-to-visible-date
|
|
|
1438 (if today-visible today (list displayed-month 1 displayed-year)))
|
|
|
1439 (set-buffer-modified-p nil)
|
|
|
1440 (or (one-window-p t)
|
|
|
1441 (/= (frame-width) (window-width))
|
|
|
1442 (shrink-window (- (window-height) 9)))
|
|
|
1443 (sit-for 0)
|
|
|
1444 (and mark-holidays-in-calendar
|
|
|
1445 (mark-calendar-holidays)
|
|
|
1446 (sit-for 0))
|
|
|
1447 (unwind-protect
|
|
|
1448 (if mark-diary-entries-in-calendar (mark-diary-entries))
|
|
|
1449 (if today-visible
|
|
|
1450 (run-hooks 'today-visible-calendar-hook)
|
|
|
1451 (run-hooks 'today-invisible-calendar-hook)))))
|
|
|
1452
|
|
|
1453 (defun generate-calendar (month year)
|
|
|
1454 "Generate a three-month Gregorian calendar centered around MONTH, YEAR."
|
|
|
1455 (if (< (+ month (* 12 (1- year))) 2)
|
|
|
1456 (error "Months before February, 1 AD are not available."))
|
|
|
1457 (setq displayed-month month)
|
|
|
1458 (setq displayed-year year)
|
|
|
1459 (erase-buffer)
|
|
|
1460 (increment-calendar-month month year -1)
|
|
|
1461 (calendar-for-loop i from 0 to 2 do
|
|
|
1462 (generate-calendar-month month year (+ 5 (* 25 i)))
|
|
|
1463 (increment-calendar-month month year 1)))
|
|
|
1464
|
|
|
1465 (defun generate-calendar-month (month year indent)
|
|
|
1466 "Produce a calendar for MONTH, YEAR on the Gregorian calendar.
|
|
|
1467 The calendar is inserted in the buffer starting at the line on which point
|
|
|
1468 is currently located, but indented INDENT spaces. The indentation is done
|
|
|
1469 from the first character on the line and does not disturb the first INDENT
|
|
|
1470 characters on the line."
|
|
|
1471 (let* ((blank-days;; at start of month
|
|
|
1472 (mod
|
|
|
1473 (- (calendar-day-of-week (list month 1 year))
|
|
|
1474 calendar-week-start-day)
|
|
|
1475 7))
|
|
|
1476 (last (calendar-last-day-of-month month year)))
|
|
|
1477 (goto-char (point-min))
|
|
|
1478 (calendar-insert-indented
|
|
|
1479 (calendar-string-spread
|
|
|
1480 (list "" (format "%s %d" (calendar-month-name month) year) "") ? 20)
|
|
|
1481 indent t)
|
|
|
1482 (calendar-insert-indented "" indent);; Go to proper spot
|
|
|
1483 (calendar-for-loop i from 0 to 6 do
|
|
|
1484 (insert (substring (aref calendar-day-name-array
|
|
|
1485 (mod (+ calendar-week-start-day i) 7))
|
|
|
1486 0 2))
|
|
|
1487 (insert " "))
|
|
|
1488 (calendar-insert-indented "" 0 t);; Force onto following line
|
|
|
1489 (calendar-insert-indented "" indent);; Go to proper spot
|
|
|
1490 ;; Add blank days before the first of the month
|
|
|
1491 (calendar-for-loop i from 1 to blank-days do (insert " "))
|
|
|
1492 ;; Put in the days of the month
|
|
|
1493 (calendar-for-loop i from 1 to last do
|
|
|
1494 (insert (format "%2d " i))
|
|
|
1495 (put-text-property (- (point) (if (< i 10) 2 3)) (1- (point))
|
|
|
1496 'highlight t)
|
|
|
1497 (and (zerop (mod (+ i blank-days) 7))
|
|
|
1498 (/= i last)
|
|
|
1499 (calendar-insert-indented "" 0 t) ;; Force onto following line
|
|
|
1500 (calendar-insert-indented "" indent)))));; Go to proper spot
|
|
|
1501
|
|
|
1502 (defun calendar-insert-indented (string indent &optional newline)
|
|
|
1503 "Insert STRING at column INDENT.
|
|
|
1504 If the optional parameter NEWLINE is t, leave point at start of next line,
|
|
|
1505 inserting a newline if there was no next line; otherwise, leave point after
|
|
|
1506 the inserted text. Value is always t."
|
|
|
1507 ;; Try to move to that column.
|
|
|
1508 (move-to-column indent)
|
|
|
1509 ;; If line is too short, indent out to that column.
|
|
|
1510 (if (< (current-column) indent)
|
|
|
1511 (indent-to indent))
|
|
|
1512 (insert string)
|
|
|
1513 ;; Advance to next line, if requested.
|
|
|
1514 (if newline
|
|
|
1515 (progn
|
|
|
1516 (end-of-line)
|
|
|
1517 (if (eobp)
|
|
|
1518 (newline)
|
|
|
1519 (forward-line 1))))
|
|
|
1520 t)
|
|
|
1521
|
|
|
1522 (defun redraw-calendar ()
|
|
|
1523 "Redraw the calendar display."
|
|
|
1524 (interactive)
|
|
|
1525 (let ((cursor-date (calendar-cursor-to-date)))
|
|
|
1526 (generate-calendar-window displayed-month displayed-year)
|
|
|
1527 (calendar-cursor-to-visible-date cursor-date)))
|
|
|
1528
|
|
|
1529 (defvar calendar-debug-sexp nil
|
|
|
1530 "*Turn debugging on when evaluating a sexp in the diary or holiday list.")
|
|
|
1531
|
|
|
1532 (defvar calendar-mode-map nil)
|
|
|
1533 (if calendar-mode-map
|
|
|
1534 nil
|
|
|
1535 (setq calendar-mode-map (make-sparse-keymap))
|
|
|
1536 (calendar-for-loop i from 0 to 9 do
|
|
|
1537 (define-key calendar-mode-map (int-to-string i) 'digit-argument))
|
|
|
1538 (let ((l (list 'narrow-to-region 'mark-word 'mark-sexp 'mark-paragraph
|
|
|
1539 'mark-defun 'mark-whole-buffer 'mark-page
|
|
|
1540 'downcase-region 'upcase-region 'kill-region
|
|
|
1541 'copy-region-as-kill 'capitalize-region 'write-region)))
|
|
|
1542 (while l
|
|
|
1543 (substitute-key-definition (car l) 'calendar-not-implemented
|
|
|
1544 calendar-mode-map)
|
|
|
1545 (setq l (cdr l))))
|
|
|
1546 (define-key calendar-mode-map "-" 'negative-argument)
|
|
|
1547 (define-key calendar-mode-map "\C-x>" 'scroll-calendar-right)
|
|
|
1548 (define-key calendar-mode-map '[prior] 'scroll-calendar-right-three-months)
|
|
|
1549 (define-key calendar-mode-map "\M-v" 'scroll-calendar-right-three-months)
|
|
|
1550 (define-key calendar-mode-map "\C-x<" 'scroll-calendar-left)
|
|
|
1551 (define-key calendar-mode-map '[next] 'scroll-calendar-left-three-months)
|
|
|
1552 (define-key calendar-mode-map "\C-v" 'scroll-calendar-left-three-months)
|
|
|
1553 (define-key calendar-mode-map "\C-b" 'calendar-backward-day)
|
|
|
1554 (define-key calendar-mode-map "\C-p" 'calendar-backward-week)
|
|
|
1555 (define-key calendar-mode-map "\M-{" 'calendar-backward-month)
|
|
|
1556 (define-key calendar-mode-map "\C-x[" 'calendar-backward-year)
|
|
|
1557 (define-key calendar-mode-map "\C-f" 'calendar-forward-day)
|
|
|
1558 (define-key calendar-mode-map "\C-n" 'calendar-forward-week)
|
|
|
1559 (define-key calendar-mode-map '[left] 'calendar-backward-day)
|
|
|
1560 (define-key calendar-mode-map '[up] 'calendar-backward-week)
|
|
|
1561 (define-key calendar-mode-map '[right] 'calendar-forward-day)
|
|
|
1562 (define-key calendar-mode-map '[down] 'calendar-forward-week)
|
|
|
1563 (define-key calendar-mode-map "\M-}" 'calendar-forward-month)
|
|
|
1564 (define-key calendar-mode-map "\C-x]" 'calendar-forward-year)
|
|
|
1565 (define-key calendar-mode-map "\C-a" 'calendar-beginning-of-week)
|
|
|
1566 (define-key calendar-mode-map "\C-e" 'calendar-end-of-week)
|
|
|
1567 (define-key calendar-mode-map "\M-a" 'calendar-beginning-of-month)
|
|
|
1568 (define-key calendar-mode-map "\M-e" 'calendar-end-of-month)
|
|
|
1569 (define-key calendar-mode-map "\M-<" 'calendar-beginning-of-year)
|
|
|
1570 (define-key calendar-mode-map "\M->" 'calendar-end-of-year)
|
|
|
1571 (define-key calendar-mode-map "\C-@" 'calendar-set-mark)
|
|
|
1572 ;; Many people are used to typing C-SPC and getting C-@.
|
|
|
1573 (define-key calendar-mode-map "\C- " 'calendar-set-mark)
|
|
|
1574 (define-key calendar-mode-map "\C-x\C-x" 'calendar-exchange-point-and-mark)
|
|
|
1575 (define-key calendar-mode-map "\M-=" 'calendar-count-days-region)
|
|
|
1576 (define-key calendar-mode-map "gd" 'calendar-goto-date)
|
|
|
1577 (define-key calendar-mode-map "gj" 'calendar-goto-julian-date)
|
|
|
1578 (define-key calendar-mode-map "ga" 'calendar-goto-astro-day-number)
|
|
|
1579 (define-key calendar-mode-map "gh" 'calendar-goto-hebrew-date)
|
|
|
1580 (define-key calendar-mode-map "gi" 'calendar-goto-islamic-date)
|
|
|
1581 (define-key calendar-mode-map "gc" 'calendar-goto-iso-date)
|
|
|
1582 (define-key calendar-mode-map "gf" 'calendar-goto-french-date)
|
|
|
1583 (define-key calendar-mode-map "gml" 'calendar-goto-mayan-long-count-date)
|
|
|
1584 (define-key calendar-mode-map "gmpc" 'calendar-previous-calendar-round-date)
|
|
|
1585 (define-key calendar-mode-map "gmnc" 'calendar-next-calendar-round-date)
|
|
|
1586 (define-key calendar-mode-map "gmph" 'calendar-previous-haab-date)
|
|
|
1587 (define-key calendar-mode-map "gmnh" 'calendar-next-haab-date)
|
|
|
1588 (define-key calendar-mode-map "gmpt" 'calendar-previous-tzolkin-date)
|
|
|
1589 (define-key calendar-mode-map "gmnt" 'calendar-next-tzolkin-date)
|
|
|
1590 (define-key calendar-mode-map "S" 'calendar-sunrise-sunset)
|
|
|
1591 (define-key calendar-mode-map "M" 'calendar-phases-of-moon)
|
|
|
1592 (define-key calendar-mode-map " " 'scroll-other-window)
|
|
|
1593 (define-key calendar-mode-map "\C-c\C-l" 'redraw-calendar)
|
|
|
1594 (define-key calendar-mode-map "." 'calendar-goto-today)
|
|
|
1595 (define-key calendar-mode-map "o" 'calendar-other-month)
|
|
|
1596 (define-key calendar-mode-map "q" 'exit-calendar)
|
|
|
1597 (define-key calendar-mode-map "a" 'list-calendar-holidays)
|
|
|
1598 (define-key calendar-mode-map "h" 'calendar-cursor-holidays)
|
|
|
1599 (define-key calendar-mode-map "x" 'mark-calendar-holidays)
|
|
|
1600 (define-key calendar-mode-map "u" 'calendar-unmark)
|
|
|
1601 (define-key calendar-mode-map "m" 'mark-diary-entries)
|
|
|
1602 (define-key calendar-mode-map "d" 'view-diary-entries)
|
|
|
1603 (define-key calendar-mode-map "D" 'view-other-diary-entries)
|
|
|
1604 (define-key calendar-mode-map "s" 'show-all-diary-entries)
|
|
|
1605 (define-key calendar-mode-map "pd" 'calendar-print-day-of-year)
|
|
|
1606 (define-key calendar-mode-map "pc" 'calendar-print-iso-date)
|
|
|
1607 (define-key calendar-mode-map "pj" 'calendar-print-julian-date)
|
|
|
1608 (define-key calendar-mode-map "pa" 'calendar-print-astro-day-number)
|
|
|
1609 (define-key calendar-mode-map "ph" 'calendar-print-hebrew-date)
|
|
|
1610 (define-key calendar-mode-map "pi" 'calendar-print-islamic-date)
|
|
|
1611 (define-key calendar-mode-map "pf" 'calendar-print-french-date)
|
|
|
1612 (define-key calendar-mode-map "pm" 'calendar-print-mayan-date)
|
|
|
1613 (define-key calendar-mode-map "id" 'insert-diary-entry)
|
|
|
1614 (define-key calendar-mode-map "iw" 'insert-weekly-diary-entry)
|
|
|
1615 (define-key calendar-mode-map "im" 'insert-monthly-diary-entry)
|
|
|
1616 (define-key calendar-mode-map "iy" 'insert-yearly-diary-entry)
|
|
|
1617 (define-key calendar-mode-map "ia" 'insert-anniversary-diary-entry)
|
|
|
1618 (define-key calendar-mode-map "ib" 'insert-block-diary-entry)
|
|
|
1619 (define-key calendar-mode-map "ic" 'insert-cyclic-diary-entry)
|
|
|
1620 (define-key calendar-mode-map "ihd" 'insert-hebrew-diary-entry)
|
|
|
1621 (define-key calendar-mode-map "ihm" 'insert-monthly-hebrew-diary-entry)
|
|
|
1622 (define-key calendar-mode-map "ihy" 'insert-yearly-hebrew-diary-entry)
|
|
|
1623 (define-key calendar-mode-map "iid" 'insert-islamic-diary-entry)
|
|
|
1624 (define-key calendar-mode-map "iim" 'insert-monthly-islamic-diary-entry)
|
|
|
1625 (define-key calendar-mode-map "iiy" 'insert-yearly-islamic-diary-entry)
|
|
|
1626 (define-key calendar-mode-map "?" 'calendar-goto-info-node))
|
|
|
1627
|
|
|
1628 (defun describe-calendar-mode ()
|
|
|
1629 "Create a help buffer with a brief description of the calendar-mode."
|
|
|
1630 (interactive)
|
|
|
1631 (with-output-to-temp-buffer "*Help*"
|
|
|
1632 (princ
|
|
|
1633 (format
|
|
|
1634 "Calendar Mode:\nFor a complete description, type %s\n%s\n"
|
|
|
1635 (substitute-command-keys
|
|
|
1636 "\\<calendar-mode-map>\\[describe-mode] from within the calendar")
|
|
|
1637 (substitute-command-keys "\\{calendar-mode-map}")))
|
|
|
1638 (save-excursion
|
|
|
1639 (set-buffer standard-output)
|
|
|
1640 (help-mode))
|
|
|
1641 (print-help-return-message)))
|
|
|
1642
|
|
|
1643 ;; Calendar mode is suitable only for specially formatted data.
|
|
|
1644 (put 'calendar-mode 'mode-class 'special)
|
|
|
1645
|
|
|
1646 (defvar calendar-mode-line-format
|
|
|
1647 (list
|
|
|
1648 (substitute-command-keys "\\<calendar-mode-map>\\[scroll-calendar-left]")
|
|
|
1649 "Calendar"
|
|
|
1650 (substitute-command-keys "\\<calendar-mode-map>\\[calendar-goto-info-node] info/\\[calendar-other-month] other/\\[calendar-goto-today] today")
|
|
|
1651 '(calendar-date-string (calendar-current-date) t)
|
|
|
1652 (substitute-command-keys "\\<calendar-mode-map>\\[scroll-calendar-right]"))
|
|
|
1653 "The mode line of the calendar buffer.")
|
|
|
1654
|
|
|
1655 (defun calendar-goto-info-node ()
|
|
|
1656 "Go to the info node for the calendar."
|
|
|
1657 (interactive)
|
|
|
1658 (require 'info)
|
|
|
1659 (let ((where (Info-find-emacs-command-nodes 'calendar)))
|
|
|
1660 (if (not where)
|
|
|
1661 (error "Couldn't find documentation for the calendar.")
|
|
|
1662 (save-window-excursion (info))
|
|
|
1663 (pop-to-buffer "*info*")
|
|
|
1664 (Info-find-node (car (car where)) (car (cdr (car where)))))))
|
|
|
1665
|
|
|
1666 (defun calendar-mode ()
|
|
|
1667 "A major mode for the calendar window.
|
|
|
1668
|
|
|
1669 For a complete description, type \
|
|
|
1670 \\<calendar-mode-map>\\[calendar-goto-info-node] from within the calendar.
|
|
|
1671
|
|
|
1672 \\<calendar-mode-map>\\{calendar-mode-map}"
|
|
|
1673
|
|
|
1674 (kill-all-local-variables)
|
|
|
1675 (setq major-mode 'calendar-mode)
|
|
|
1676 (setq mode-name "Calendar")
|
|
|
1677 (use-local-map calendar-mode-map)
|
|
|
1678 (setq buffer-read-only t)
|
|
|
1679 (setq indent-tabs-mode nil)
|
|
|
1680 (update-calendar-mode-line)
|
|
|
1681 (if (and (string-match "XEmacs" emacs-version) current-menubar)
|
|
|
1682 (progn
|
|
|
1683 (require 'cal-xemacs)
|
|
|
1684 (calendar-add-menus)
|
|
|
1685 (make-variable-buffer-local 'scroll-on-clipped-lines)
|
|
|
1686 (setq scroll-on-clipped-lines nil)))
|
|
|
1687 (make-local-variable 'calendar-mark-ring)
|
|
|
1688 (make-local-variable 'displayed-month);; Month in middle of window.
|
|
|
1689 (make-local-variable 'displayed-year));; Year in middle of window.
|
|
|
1690
|
|
|
1691 (defun calendar-string-spread (strings char length)
|
|
|
1692 "Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH
|
|
|
1693 There must be at least 2 strings. The effect is like mapconcat but the
|
|
|
1694 separating pieces are as balanced as possible. Each item of STRINGS is
|
|
|
1695 evaluated before concatenation so it can actually be an expression that
|
|
|
1696 evaluates to a string. If LENGTH is too short, the STRINGS are just
|
|
|
1697 concatenated and the result truncated."
|
|
|
1698 ;; The algorithm is based on equation (3.25) on page 85 of Concrete
|
|
|
1699 ;; Mathematics by Ronald L. Graham, Donald E. Knuth, and Oren Patashnik,
|
|
|
1700 ;; Addison-Wesley, Reading, MA, 1989
|
|
|
1701 (let* ((strings (mapcar 'eval strings))
|
|
|
1702 (n (- length (length (apply 'concat strings))))
|
|
|
1703 (m (1- (length strings)))
|
|
|
1704 (s (car strings))
|
|
|
1705 (strings (cdr strings))
|
|
|
1706 (i 0))
|
|
|
1707 (while strings
|
|
|
1708 (setq s (concat s
|
|
|
1709 (make-string (max 0 (/ (+ n i) m)) char)
|
|
|
1710 (car strings)))
|
|
|
1711 (setq i (1+ i))
|
|
|
1712 (setq strings (cdr strings)))
|
|
|
1713 (substring s 0 length)))
|
|
|
1714
|
|
|
1715 (defun update-calendar-mode-line ()
|
|
|
1716 "Update the calendar mode line with the current date and date style."
|
|
|
1717 (if (bufferp (get-buffer calendar-buffer))
|
|
|
1718 (save-excursion
|
|
|
1719 (set-buffer calendar-buffer)
|
|
|
1720 (setq mode-line-format
|
|
|
1721 (calendar-string-spread
|
|
|
1722 calendar-mode-line-format ? (frame-width))))))
|
|
|
1723
|
|
|
1724 (defun calendar-window-list ()
|
|
|
1725 "List of all calendar-related windows."
|
|
|
1726 (let ((calendar-buffers (calendar-buffer-list))
|
|
|
1727 list)
|
|
|
1728 (walk-windows '(lambda (w)
|
|
|
1729 (if (memq (window-buffer w) calendar-buffers)
|
|
|
1730 (setq list (cons w list))))
|
|
|
1731 nil t)
|
|
|
1732 list))
|
|
|
1733
|
|
|
1734 (defun calendar-buffer-list ()
|
|
|
1735 "List of all calendar-related buffers."
|
|
|
1736 (let* ((diary-buffer (get-file-buffer diary-file))
|
|
|
1737 (buffers (list "*Yahrzeits*" lunar-phases-buffer holiday-buffer
|
|
|
1738 fancy-diary-buffer diary-buffer calendar-buffer))
|
|
|
1739 (buffer-list nil)
|
|
|
1740 b)
|
|
|
1741 (while buffers
|
|
|
1742 (setq b (car buffers))
|
|
|
1743 (setq b (cond ((stringp b) (get-buffer b))
|
|
|
1744 ((bufferp b) b)
|
|
|
1745 (t nil)))
|
|
|
1746 (if b (setq buffer-list (cons b buffer-list)))
|
|
|
1747 (setq buffers (cdr buffers)))
|
|
|
1748 buffer-list))
|
|
|
1749
|
|
|
1750 (defun exit-calendar ()
|
|
|
1751 "Get out of the calendar window and hide it and related buffers."
|
|
|
1752 (interactive)
|
|
|
1753 (let* ((diary-buffer (get-file-buffer diary-file)))
|
|
|
1754 (if (and diary-buffer (buffer-modified-p diary-buffer)
|
|
|
1755 (not
|
|
|
1756 (yes-or-no-p
|
|
|
1757 "Diary modified; do you really want to exit the calendar? ")))
|
|
|
1758 (error)
|
|
|
1759 ;; Need to do this multiple times because one time can replace some
|
|
|
1760 ;; calendar-related buffers with other calendar-related buffers
|
|
|
1761 (mapcar (lambda (x)
|
|
|
1762 (mapcar 'calendar-hide-window (calendar-window-list)))
|
|
|
1763 (calendar-window-list)))))
|
|
|
1764
|
|
|
1765 (defun calendar-hide-window (window)
|
|
|
1766 "Hide WINDOW if it is calendar-related."
|
|
|
1767 (let ((buffer (if (window-live-p window) (window-buffer window))))
|
|
|
1768 (if (memq buffer (calendar-buffer-list))
|
|
|
1769 (cond
|
|
|
1770 ((and window-system
|
|
|
1771 (eq 'icon (cdr (assoc 'visibility
|
|
|
1772 (frame-parameters
|
|
|
1773 (window-frame window))))))
|
|
|
1774 nil)
|
|
|
1775 ((and window-system (window-dedicated-p window))
|
|
|
1776 (iconify-frame (window-frame window)))
|
|
|
1777 ((not (and (select-window window) (one-window-p window)))
|
|
|
1778 (delete-window window))
|
|
|
1779 (t (set-buffer buffer)
|
|
|
1780 (bury-buffer))))))
|
|
|
1781
|
|
|
1782 (defun calendar-goto-today ()
|
|
|
1783 "Reposition the calendar window so the current date is visible."
|
|
|
1784 (interactive)
|
|
|
1785 (let ((today (calendar-current-date)));; The date might have changed.
|
|
|
1786 (if (not (calendar-date-is-visible-p today))
|
|
|
1787 (generate-calendar-window)
|
|
|
1788 (update-calendar-mode-line)
|
|
|
1789 (calendar-cursor-to-visible-date today))))
|
|
|
1790
|
|
|
1791 (defun calendar-forward-month (arg)
|
|
|
1792 "Move the cursor forward ARG months.
|
|
|
1793 Movement is backward if ARG is negative."
|
|
|
1794 (interactive "p")
|
|
|
1795 (calendar-cursor-to-nearest-date)
|
|
|
1796 (let* ((cursor-date (calendar-cursor-to-date t))
|
|
|
1797 (month (extract-calendar-month cursor-date))
|
|
|
1798 (day (extract-calendar-day cursor-date))
|
|
|
1799 (year (extract-calendar-year cursor-date)))
|
|
|
1800 (increment-calendar-month month year arg)
|
|
|
1801 (let ((last (calendar-last-day-of-month month year)))
|
|
|
1802 (if (< last day)
|
|
|
1803 (setq day last)))
|
|
|
1804 ;; Put the new month on the screen, if needed, and go to the new date.
|
|
|
1805 (let ((new-cursor-date (list month day year)))
|
|
|
1806 (if (not (calendar-date-is-visible-p new-cursor-date))
|
|
|
1807 (calendar-other-month month year))
|
|
|
1808 (calendar-cursor-to-visible-date new-cursor-date))))
|
|
|
1809
|
|
|
1810 (defun calendar-forward-year (arg)
|
|
|
1811 "Move the cursor forward by ARG years.
|
|
|
1812 Movement is backward if ARG is negative."
|
|
|
1813 (interactive "p")
|
|
|
1814 (calendar-forward-month (* 12 arg)))
|
|
|
1815
|
|
|
1816 (defun calendar-backward-month (arg)
|
|
|
1817 "Move the cursor backward by ARG months.
|
|
|
1818 Movement is forward if ARG is negative."
|
|
|
1819 (interactive "p")
|
|
|
1820 (calendar-forward-month (- arg)))
|
|
|
1821
|
|
|
1822 (defun calendar-backward-year (arg)
|
|
|
1823 "Move the cursor backward ARG years.
|
|
|
1824 Movement is forward is ARG is negative."
|
|
|
1825 (interactive "p")
|
|
|
1826 (calendar-forward-month (* -12 arg)))
|
|
|
1827
|
|
|
1828 (defun scroll-calendar-left (arg)
|
|
|
1829 "Scroll the displayed calendar left by ARG months.
|
|
|
1830 If ARG is negative the calendar is scrolled right. Maintains the relative
|
|
|
1831 position of the cursor with respect to the calendar as well as possible."
|
|
|
1832 (interactive "p")
|
|
|
1833 (calendar-cursor-to-nearest-date)
|
|
|
1834 (let ((old-date (calendar-cursor-to-date))
|
|
|
1835 (today (calendar-current-date)))
|
|
|
1836 (if (/= arg 0)
|
|
|
1837 (progn
|
|
|
1838 (increment-calendar-month displayed-month displayed-year arg)
|
|
|
1839 (generate-calendar-window displayed-month displayed-year)
|
|
|
1840 (calendar-cursor-to-visible-date
|
|
|
1841 (cond
|
|
|
1842 ((calendar-date-is-visible-p old-date) old-date)
|
|
|
1843 ((calendar-date-is-visible-p today) today)
|
|
|
1844 (t (list displayed-month 1 displayed-year))))))))
|
|
|
1845
|
|
|
1846 (defun scroll-calendar-right (arg)
|
|
|
1847 "Scroll the displayed calendar window right by ARG months.
|
|
|
1848 If ARG is negative the calendar is scrolled left. Maintains the relative
|
|
|
1849 position of the cursor with respect to the calendar as well as possible."
|
|
|
1850 (interactive "p")
|
|
|
1851 (scroll-calendar-left (- arg)))
|
|
|
1852
|
|
|
1853 (defun scroll-calendar-left-three-months (arg)
|
|
|
1854 "Scroll the displayed calendar window left by 3*ARG months.
|
|
|
1855 If ARG is negative the calendar is scrolled right. Maintains the relative
|
|
|
1856 position of the cursor with respect to the calendar as well as possible."
|
|
|
1857 (interactive "p")
|
|
|
1858 (scroll-calendar-left (* 3 arg)))
|
|
|
1859
|
|
|
1860 (defun scroll-calendar-right-three-months (arg)
|
|
|
1861 "Scroll the displayed calendar window right by 3*ARG months.
|
|
|
1862 If ARG is negative the calendar is scrolled left. Maintains the relative
|
|
|
1863 position of the cursor with respect to the calendar as well as possible."
|
|
|
1864 (interactive "p")
|
|
|
1865 (scroll-calendar-left (* -3 arg)))
|
|
|
1866
|
|
|
1867 (defun calendar-current-date ()
|
|
|
1868 "Returns the current date in a list (month day year)."
|
|
|
1869 (let ((s (current-time-string)))
|
|
|
1870 (list (length (member (substring s 4 7)
|
|
|
1871 '("Dec" "Nov" "Oct" "Sep" "Aug" "Jul"
|
|
|
1872 "Jun" "May" "Apr" "Mar" "Feb" "Jan")))
|
|
|
1873 (string-to-number (substring s 8 10))
|
|
|
1874 (string-to-number (substring s 20 24)))))
|
|
|
1875
|
|
|
1876 (defun calendar-cursor-to-date (&optional error)
|
|
|
1877 "Returns a list (month day year) of current cursor position.
|
|
|
1878 If cursor is not on a specific date, signals an error if optional parameter
|
|
|
1879 ERROR is t, otherwise just returns nil."
|
|
|
1880 ;; #### This check is to avoid a race condition created by
|
|
|
1881 ;; pop-to-buffer's call to other-window interacting with the 19.13
|
|
|
1882 ;; changes allowing that to be in another frame.
|
|
|
1883 (if (not (number-or-marker-p displayed-month))
|
|
|
1884 nil
|
|
|
1885 (let* ((segment (/ (current-column) 25))
|
|
|
1886 (month (% (+ displayed-month segment -1) 12))
|
|
|
1887 (month (if (= 0 month) 12 month))
|
|
|
1888 (year
|
|
|
1889 (cond
|
|
|
1890 ((and (= 12 month) (= segment 0)) (1- displayed-year))
|
|
|
1891 ((and (= 1 month) (= segment 2)) (1+ displayed-year))
|
|
|
1892 (t displayed-year))))
|
|
|
1893 (if (and (looking-at "[0-9]")
|
|
|
1894 (< 2 (count-lines (point-min) (point))))
|
|
|
1895 (save-excursion
|
|
|
1896 (re-search-backward "[^0-9]")
|
|
|
1897 (list month
|
|
|
1898 (string-to-int (buffer-substring (1+ (point)) (+ 4 (point))))
|
|
|
1899 year))
|
|
|
1900 (if (looking-at "\\*")
|
|
|
1901 (save-excursion
|
|
|
1902 (re-search-backward "[^*]")
|
|
|
1903 (if (looking-at ".\\*\\*")
|
|
|
1904 (list month calendar-starred-day year)
|
|
|
1905 (if error (error "Not on a date!"))))
|
|
|
1906 (if error (error "Not on a date!")))))))
|
|
|
1907
|
|
|
1908 (defun calendar-cursor-to-nearest-date ()
|
|
|
1909 "Move the cursor to the closest date.
|
|
|
1910 The position of the cursor is unchanged if it is already on a date.
|
|
|
1911 Returns the list (month day year) giving the cursor position."
|
|
|
1912 (let ((date (calendar-cursor-to-date))
|
|
|
1913 (column (current-column)))
|
|
|
1914 (if date
|
|
|
1915 date
|
|
|
1916 (if (> 3 (count-lines (point-min) (point)))
|
|
|
1917 (progn
|
|
|
1918 (goto-line 3)
|
|
|
1919 (move-to-column column)))
|
|
|
1920 (if (not (looking-at "[0-9]"))
|
|
|
1921 (if (and (not (looking-at " *$"))
|
|
|
1922 (or (< column 25)
|
|
|
1923 (and (> column 27)
|
|
|
1924 (< column 50))
|
|
|
1925 (and (> column 52)
|
|
|
1926 (< column 75))))
|
|
|
1927 (progn
|
|
|
1928 (re-search-forward "[0-9]" nil t)
|
|
|
1929 (backward-char 1))
|
|
|
1930 (re-search-backward "[0-9]" nil t)))
|
|
|
1931 (calendar-cursor-to-date))))
|
|
|
1932
|
|
|
1933 (defun calendar-forward-day (arg)
|
|
|
1934 "Move the cursor forward ARG days.
|
|
|
1935 Moves backward if ARG is negative."
|
|
|
1936 (interactive "p")
|
|
|
1937 (if (/= 0 arg)
|
|
|
1938 (let*
|
|
|
1939 ((cursor-date (calendar-cursor-to-date))
|
|
|
1940 (cursor-date (if cursor-date
|
|
|
1941 cursor-date
|
|
|
1942 (if (> arg 0) (setq arg (1- arg)))
|
|
|
1943 (calendar-cursor-to-nearest-date)))
|
|
|
1944 (new-cursor-date
|
|
|
1945 (calendar-gregorian-from-absolute
|
|
|
1946 (+ (calendar-absolute-from-gregorian cursor-date) arg)))
|
|
|
1947 (new-display-month (extract-calendar-month new-cursor-date))
|
|
|
1948 (new-display-year (extract-calendar-year new-cursor-date)))
|
|
|
1949 ;; Put the new month on the screen, if needed, and go to the new date.
|
|
|
1950 (if (not (calendar-date-is-visible-p new-cursor-date))
|
|
|
1951 (calendar-other-month new-display-month new-display-year))
|
|
|
1952 (calendar-cursor-to-visible-date new-cursor-date))))
|
|
|
1953
|
|
|
1954 (defun calendar-backward-day (arg)
|
|
|
1955 "Move the cursor back ARG days.
|
|
|
1956 Moves forward if ARG is negative."
|
|
|
1957 (interactive "p")
|
|
|
1958 (calendar-forward-day (- arg)))
|
|
|
1959
|
|
|
1960 (defun calendar-forward-week (arg)
|
|
|
1961 "Move the cursor forward ARG weeks.
|
|
|
1962 Moves backward if ARG is negative."
|
|
|
1963 (interactive "p")
|
|
|
1964 (calendar-forward-day (* arg 7)))
|
|
|
1965
|
|
|
1966 (defun calendar-backward-week (arg)
|
|
|
1967 "Move the cursor back ARG weeks.
|
|
|
1968 Moves forward if ARG is negative."
|
|
|
1969 (interactive "p")
|
|
|
1970 (calendar-forward-day (* arg -7)))
|
|
|
1971
|
|
|
1972 (defun calendar-beginning-of-week (arg)
|
|
|
1973 "Move the cursor back ARG calendar-week-start-day's."
|
|
|
1974 (interactive "p")
|
|
|
1975 (calendar-cursor-to-nearest-date)
|
|
|
1976 (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
|
|
|
1977 (calendar-backward-day
|
|
|
1978 (if (= day calendar-week-start-day)
|
|
|
1979 (* 7 arg)
|
|
|
1980 (+ (mod (- day calendar-week-start-day) 7)
|
|
|
1981 (* 7 (1- arg)))))))
|
|
|
1982
|
|
|
1983 (defun calendar-end-of-week (arg)
|
|
|
1984 "Move the cursor forward ARG calendar-week-start-day+6's."
|
|
|
1985 (interactive "p")
|
|
|
1986 (calendar-cursor-to-nearest-date)
|
|
|
1987 (let ((day (calendar-day-of-week (calendar-cursor-to-date))))
|
|
|
1988 (calendar-forward-day
|
|
|
1989 (if (= day (mod (1- calendar-week-start-day) 7))
|
|
|
1990 (* 7 arg)
|
|
|
1991 (+ (- 6 (mod (- day calendar-week-start-day) 7))
|
|
|
1992 (* 7 (1- arg)))))))
|
|
|
1993
|
|
|
1994 (defun calendar-beginning-of-month (arg)
|
|
|
1995 "Move the cursor backward ARG month beginnings."
|
|
|
1996 (interactive "p")
|
|
|
1997 (calendar-cursor-to-nearest-date)
|
|
|
1998 (let* ((date (calendar-cursor-to-date))
|
|
|
1999 (month (extract-calendar-month date))
|
|
|
2000 (day (extract-calendar-day date))
|
|
|
2001 (year (extract-calendar-year date)))
|
|
|
2002 (if (= day 1)
|
|
|
2003 (calendar-backward-month arg)
|
|
|
2004 (calendar-cursor-to-visible-date (list month 1 year))
|
|
|
2005 (calendar-backward-month (1- arg)))))
|
|
|
2006
|
|
|
2007 (defun calendar-end-of-month (arg)
|
|
|
2008 "Move the cursor forward ARG month ends."
|
|
|
2009 (interactive "p")
|
|
|
2010 (calendar-cursor-to-nearest-date)
|
|
|
2011 (let* ((date (calendar-cursor-to-date))
|
|
|
2012 (month (extract-calendar-month date))
|
|
|
2013 (day (extract-calendar-day date))
|
|
|
2014 (year (extract-calendar-year date))
|
|
|
2015 (last-day (calendar-last-day-of-month month year)))
|
|
|
2016 (if (/= day last-day)
|
|
|
2017 (progn
|
|
|
2018 (calendar-cursor-to-visible-date (list month last-day year))
|
|
|
2019 (setq arg (1- arg))))
|
|
|
2020 (increment-calendar-month month year arg)
|
|
|
2021 (let ((last-day (list
|
|
|
2022 month
|
|
|
2023 (calendar-last-day-of-month month year)
|
|
|
2024 year)))
|
|
|
2025 (if (not (calendar-date-is-visible-p last-day))
|
|
|
2026 (calendar-other-month month year)
|
|
|
2027 (calendar-cursor-to-visible-date last-day)))))
|
|
|
2028
|
|
|
2029 (defun calendar-beginning-of-year (arg)
|
|
|
2030 "Move the cursor backward ARG year beginnings."
|
|
|
2031 (interactive "p")
|
|
|
2032 (calendar-cursor-to-nearest-date)
|
|
|
2033 (let* ((date (calendar-cursor-to-date))
|
|
|
2034 (month (extract-calendar-month date))
|
|
|
2035 (day (extract-calendar-day date))
|
|
|
2036 (year (extract-calendar-year date))
|
|
|
2037 (jan-first (list 1 1 year)))
|
|
|
2038 (if (and (= day 1) (= 1 month))
|
|
|
2039 (calendar-backward-month (* 12 arg))
|
|
|
2040 (if (and (= arg 1)
|
|
|
2041 (calendar-date-is-visible-p jan-first))
|
|
|
2042 (calendar-cursor-to-visible-date jan-first)
|
|
|
2043 (calendar-other-month 1 (- year (1- arg)))))))
|
|
|
2044
|
|
|
2045 (defun calendar-end-of-year (arg)
|
|
|
2046 "Move the cursor forward ARG year beginnings."
|
|
|
2047 (interactive "p")
|
|
|
2048 (calendar-cursor-to-nearest-date)
|
|
|
2049 (let* ((date (calendar-cursor-to-date))
|
|
|
2050 (month (extract-calendar-month date))
|
|
|
2051 (day (extract-calendar-day date))
|
|
|
2052 (year (extract-calendar-year date))
|
|
|
2053 (dec-31 (list 12 31 year)))
|
|
|
2054 (if (and (= day 31) (= 12 month))
|
|
|
2055 (calendar-forward-month (* 12 arg))
|
|
|
2056 (if (and (= arg 1)
|
|
|
2057 (calendar-date-is-visible-p dec-31))
|
|
|
2058 (calendar-cursor-to-visible-date dec-31)
|
|
|
2059 (calendar-other-month 12 (- year (1- arg)))
|
|
|
2060 (calendar-cursor-to-visible-date (list 12 31 displayed-year))))))
|
|
|
2061
|
|
|
2062 ;; The following version of calendar-gregorian-from-absolute is preferred for
|
|
|
2063 ;; reasons of clarity, BUT it's much slower than the version that follows it.
|
|
|
2064
|
|
|
2065 ;;(defun calendar-gregorian-from-absolute (date)
|
|
|
2066 ;; "Compute the list (month day year) corresponding to the absolute DATE.
|
|
|
2067 ;;The absolute date is the number of days elapsed since the (imaginary)
|
|
|
2068 ;;Gregorian date Sunday, December 31, 1 BC."
|
|
|
2069 ;; (let* ((approx (/ date 366));; Approximation from below.
|
|
|
2070 ;; (year ;; Search forward from the approximation.
|
|
|
2071 ;; (+ approx
|
|
|
2072 ;; (calendar-sum y approx
|
|
|
2073 ;; (>= date (calendar-absolute-from-gregorian (list 1 1 (1+ y))))
|
|
|
2074 ;; 1)))
|
|
|
2075 ;; (month ;; Search forward from January.
|
|
|
2076 ;; (1+ (calendar-sum m 1
|
|
|
2077 ;; (> date
|
|
|
2078 ;; (calendar-absolute-from-gregorian
|
|
|
2079 ;; (list m (calendar-last-day-of-month m year) year)))
|
|
|
2080 ;; 1)))
|
|
|
2081 ;; (day ;; Calculate the day by subtraction.
|
|
|
2082 ;; (- date
|
|
|
2083 ;; (1- (calendar-absolute-from-gregorian (list month 1 year))))))
|
|
|
2084 ;; (list month day year)))
|
|
|
2085
|
|
|
2086 (defun calendar-gregorian-from-absolute (date)
|
|
|
2087 "Compute the list (month day year) corresponding to the absolute DATE.
|
|
|
2088 The absolute date is the number of days elapsed since the (imaginary)
|
|
|
2089 Gregorian date Sunday, December 31, 1 BC."
|
|
|
2090 ;; See the footnote on page 384 of ``Calendrical Calculations, Part II:
|
|
|
2091 ;; Three Historical Calendars'' by E. M. Reingold, N. Dershowitz, and S. M.
|
|
|
2092 ;; Clamen, Software--Practice and Experience, Volume 23, Number 4
|
|
|
2093 ;; (April, 1993), pages 383-404 for an explanation.
|
|
|
2094 (let* ((d0 (1- date))
|
|
|
2095 (n400 (/ d0 146097))
|
|
|
2096 (d1 (% d0 146097))
|
|
|
2097 (n100 (/ d1 36524))
|
|
|
2098 (d2 (% d1 36524))
|
|
|
2099 (n4 (/ d2 1461))
|
|
|
2100 (d3 (% d2 1461))
|
|
|
2101 (n1 (/ d3 365))
|
|
|
2102 (day (1+ (% d3 365)))
|
|
|
2103 (year (+ (* 400 n400) (* 100 n100) (* n4 4) n1)))
|
|
|
2104 (if (or (= n100 4) (= n1 4))
|
|
|
2105 (list 12 31 year)
|
|
|
2106 (let ((year (1+ year))
|
|
|
2107 (month 1))
|
|
|
2108 (while (let ((mdays (calendar-last-day-of-month month year)))
|
|
|
2109 (and (< mdays day)
|
|
|
2110 (setq day (- day mdays))))
|
|
|
2111 (setq month (1+ month)))
|
|
|
2112 (list month day year)))))
|
|
|
2113
|
|
|
2114 (defun calendar-cursor-to-visible-date (date)
|
|
|
2115 "Move the cursor to DATE that is on the screen."
|
|
|
2116 (let* ((month (extract-calendar-month date))
|
|
|
2117 (day (extract-calendar-day date))
|
|
|
2118 (year (extract-calendar-year date))
|
|
|
2119 (first-of-month-weekday (calendar-day-of-week (list month 1 year))))
|
|
|
2120 (goto-line (+ 3
|
|
|
2121 (/ (+ day -1
|
|
|
2122 (mod
|
|
|
2123 (- (calendar-day-of-week (list month 1 year))
|
|
|
2124 calendar-week-start-day)
|
|
|
2125 7))
|
|
|
2126 7)))
|
|
|
2127 (move-to-column (+ 6
|
|
|
2128 (* 25
|
|
|
2129 (1+ (calendar-interval
|
|
|
2130 displayed-month displayed-year month year)))
|
|
|
2131 (* 3 (mod
|
|
|
2132 (- (calendar-day-of-week date)
|
|
|
2133 calendar-week-start-day)
|
|
|
2134 7))))))
|
|
|
2135
|
|
|
2136 (defun calendar-other-month (month year)
|
|
|
2137 "Display a three-month calendar centered around MONTH and YEAR."
|
|
|
2138 (interactive (calendar-read-date 'noday))
|
|
|
2139 (if (and (= month displayed-month)
|
|
|
2140 (= year displayed-year))
|
|
|
2141 nil
|
|
|
2142 (let ((old-date (calendar-cursor-to-date))
|
|
|
2143 (today (calendar-current-date)))
|
|
|
2144 (generate-calendar-window month year)
|
|
|
2145 (calendar-cursor-to-visible-date
|
|
|
2146 (cond
|
|
|
2147 ((calendar-date-is-visible-p old-date) old-date)
|
|
|
2148 ((calendar-date-is-visible-p today) today)
|
|
|
2149 (t (list month 1 year)))))))
|
|
|
2150
|
|
|
2151 (defun calendar-set-mark (arg)
|
|
|
2152 "Mark the date under the cursor, or jump to marked date.
|
|
|
2153 With no prefix argument, push current date onto marked date ring.
|
|
|
2154 With argument, jump to mark, pop it, and put point at end of ring."
|
|
|
2155 (interactive "P")
|
|
|
2156 (let ((date (calendar-cursor-to-date t)))
|
|
|
2157 (if (null arg)
|
|
|
2158 (progn
|
|
|
2159 (setq calendar-mark-ring (cons date calendar-mark-ring))
|
|
|
2160 ;; Since the top of the mark ring is the marked date in the
|
|
|
2161 ;; calendar, the mark ring in the calendar is one longer than
|
|
|
2162 ;; in other buffers to get the same effect.
|
|
|
2163 (if (> (length calendar-mark-ring) (1+ mark-ring-max))
|
|
|
2164 (setcdr (nthcdr mark-ring-max calendar-mark-ring) nil))
|
|
|
2165 (message "Mark set"))
|
|
|
2166 (if (null calendar-mark-ring)
|
|
|
2167 (error "No mark set in this buffer")
|
|
|
2168 (calendar-goto-date (car calendar-mark-ring))
|
|
|
2169 (setq calendar-mark-ring
|
|
|
2170 (cdr (nconc calendar-mark-ring (list date))))))))
|
|
|
2171
|
|
|
2172 (defun calendar-exchange-point-and-mark ()
|
|
|
2173 "Exchange the current cursor position with the marked date."
|
|
|
2174 (interactive)
|
|
|
2175 (let ((mark (car calendar-mark-ring))
|
|
|
2176 (date (calendar-cursor-to-date t)))
|
|
|
2177 (if (null mark)
|
|
|
2178 (error "No mark set in this buffer")
|
|
|
2179 (setq calendar-mark-ring (cons date (cdr calendar-mark-ring)))
|
|
|
2180 (calendar-goto-date mark))))
|
|
|
2181
|
|
|
2182 (defun calendar-count-days-region ()
|
|
|
2183 "Count the number of days (inclusive) between point and the mark."
|
|
|
2184 (interactive)
|
|
|
2185 (let* ((days (- (calendar-absolute-from-gregorian
|
|
|
2186 (calendar-cursor-to-date t))
|
|
|
2187 (calendar-absolute-from-gregorian
|
|
|
2188 (or (car calendar-mark-ring)
|
|
|
2189 (error "No mark set in this buffer")))))
|
|
|
2190 (days (1+ (if (> days 0) days (- days)))))
|
|
|
2191 (message "Region has %d day%s (inclusive)"
|
|
|
2192 days (if (> days 1) "s" ""))))
|
|
|
2193
|
|
|
2194 (defun calendar-not-implemented ()
|
|
|
2195 "Not implemented."
|
|
|
2196 (interactive)
|
|
|
2197 (error "%s not available in the calendar"
|
|
|
2198 (global-key-binding (this-command-keys))))
|
|
|
2199
|
|
|
2200 (defun calendar-read (prompt acceptable &optional initial-contents)
|
|
|
2201 "Return an object read from the minibuffer.
|
|
|
2202 Prompt with the string PROMPT and use the function ACCEPTABLE to decide if
|
|
|
2203 entered item is acceptable. If non-nil, optional third arg INITIAL-CONTENTS
|
|
|
2204 is a string to insert in the minibuffer before reading."
|
|
|
2205 (let ((value (read-minibuffer prompt initial-contents)))
|
|
|
2206 (while (not (funcall acceptable value))
|
|
|
2207 (setq value (read-minibuffer prompt initial-contents)))
|
|
|
2208 value))
|
|
|
2209
|
|
|
2210 (defun calendar-read-date (&optional noday)
|
|
|
2211 "Prompt for Gregorian date. Returns a list (month day year).
|
|
|
2212 If optional NODAY is t, does not ask for day, but just returns
|
|
|
2213 (month nil year); if NODAY is any other non-nil value the value returned is
|
|
|
2214 (month year) "
|
|
|
2215 (let* ((year (calendar-read
|
|
|
2216 "Year (>0): "
|
|
|
2217 '(lambda (x) (> x 0))
|
|
|
2218 (int-to-string (extract-calendar-year
|
|
|
2219 (calendar-current-date)))))
|
|
|
2220 (month-array calendar-month-name-array)
|
|
|
2221 (completion-ignore-case t)
|
|
|
2222 (month (cdr (assoc
|
|
|
2223 (capitalize
|
|
|
2224 (completing-read
|
|
|
2225 "Month name: "
|
|
|
2226 (mapcar 'list (append month-array nil))
|
|
|
2227 nil t))
|
|
|
2228 (calendar-make-alist month-array 1 'capitalize))))
|
|
|
2229 (last (calendar-last-day-of-month month year)))
|
|
|
2230 (if noday
|
|
|
2231 (if (eq noday t)
|
|
|
2232 (list month nil year)
|
|
|
2233 (list month year))
|
|
|
2234 (list month
|
|
|
2235 (calendar-read (format "Day (1-%d): " last)
|
|
|
2236 '(lambda (x) (and (< 0 x) (<= x last))))
|
|
|
2237 year))))
|
|
|
2238
|
|
|
2239 (defun calendar-goto-date (date)
|
|
|
2240 "Move cursor to DATE."
|
|
|
2241 (interactive (list (calendar-read-date)))
|
|
|
2242 (let ((month (extract-calendar-month date))
|
|
|
2243 (year (extract-calendar-year date)))
|
|
|
2244 (if (not (calendar-date-is-visible-p date))
|
|
|
2245 (calendar-other-month
|
|
|
2246 (if (and (= month 1) (= year 1))
|
|
|
2247 2
|
|
|
2248 month)
|
|
|
2249 year)))
|
|
|
2250 (calendar-cursor-to-visible-date date))
|
|
|
2251
|
|
|
2252 (defun calendar-goto-julian-date (date &optional noecho)
|
|
|
2253 "Move cursor to Julian DATE; echo Julian date unless NOECHO is t."
|
|
|
2254 (interactive
|
|
|
2255 (let* ((today (calendar-current-date))
|
|
|
2256 (year (calendar-read
|
|
|
2257 "Julian calendar year (>0): "
|
|
|
2258 '(lambda (x) (> x 0))
|
|
|
2259 (int-to-string
|
|
|
2260 (extract-calendar-year
|
|
|
2261 (calendar-julian-from-absolute
|
|
|
2262 (calendar-absolute-from-gregorian
|
|
|
2263 today))))))
|
|
|
2264 (month-array calendar-month-name-array)
|
|
|
2265 (completion-ignore-case t)
|
|
|
2266 (month (cdr (assoc
|
|
|
2267 (capitalize
|
|
|
2268 (completing-read
|
|
|
2269 "Julian calendar month name: "
|
|
|
2270 (mapcar 'list (append month-array nil))
|
|
|
2271 nil t))
|
|
|
2272 (calendar-make-alist month-array 1 'capitalize))))
|
|
|
2273 (last
|
|
|
2274 (if (and (zerop (% year 4)) (= month 2))
|
|
|
2275 29
|
|
|
2276 (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
|
|
|
2277 (day (calendar-read
|
|
|
2278 (format "Julian calendar day (%d-%d): "
|
|
|
2279 (if (and (= year 1) (= month 1)) 3 1) last)
|
|
|
2280 '(lambda (x)
|
|
|
2281 (and (< (if (and (= year 1) (= month 1)) 2 0) x)
|
|
|
2282 (<= x last))))))
|
|
|
2283 (list (list month day year))))
|
|
|
2284 (calendar-goto-date (calendar-gregorian-from-absolute
|
|
|
2285 (calendar-absolute-from-julian date)))
|
|
|
2286 (or noecho (calendar-print-julian-date)))
|
|
|
2287
|
|
|
2288 (defun calendar-goto-hebrew-date (date &optional noecho)
|
|
|
2289 "Move cursor to Hebrew DATE; echo Hebrew date unless NOECHO is t."
|
|
|
2290 (interactive
|
|
|
2291 (let* ((today (calendar-current-date))
|
|
|
2292 (year (calendar-read
|
|
|
2293 "Hebrew calendar year (>3760): "
|
|
|
2294 '(lambda (x) (> x 3760))
|
|
|
2295 (int-to-string
|
|
|
2296 (extract-calendar-year
|
|
|
2297 (calendar-hebrew-from-absolute
|
|
|
2298 (calendar-absolute-from-gregorian today))))))
|
|
|
2299 (month-array (if (hebrew-calendar-leap-year-p year)
|
|
|
2300 calendar-hebrew-month-name-array-leap-year
|
|
|
2301 calendar-hebrew-month-name-array-common-year))
|
|
|
2302 (completion-ignore-case t)
|
|
|
2303 (month (cdr (assoc
|
|
|
2304 (capitalize
|
|
|
2305 (completing-read
|
|
|
2306 "Hebrew calendar month name: "
|
|
|
2307 (mapcar 'list (append month-array nil))
|
|
|
2308 (if (= year 3761)
|
|
|
2309 '(lambda (x)
|
|
|
2310 (let ((m (cdr
|
|
|
2311 (assoc
|
|
|
2312 (car x)
|
|
|
2313 (calendar-make-alist
|
|
|
2314 month-array)))))
|
|
|
2315 (< 0
|
|
|
2316 (calendar-absolute-from-hebrew
|
|
|
2317 (list m
|
|
|
2318 (hebrew-calendar-last-day-of-month
|
|
|
2319 m year)
|
|
|
2320 year))))))
|
|
|
2321
|
|
|
2322 t))
|
|
|
2323 (calendar-make-alist month-array 1 'capitalize))))
|
|
|
2324 (last (hebrew-calendar-last-day-of-month month year))
|
|
|
2325 (first (if (and (= year 3761) (= month 10))
|
|
|
2326 18 1))
|
|
|
2327 (day (calendar-read
|
|
|
2328 (format "Hebrew calendar day (%d-%d): "
|
|
|
2329 first last)
|
|
|
2330 '(lambda (x) (and (<= first x) (<= x last))))))
|
|
|
2331 (list (list month day year))))
|
|
|
2332 (calendar-goto-date (calendar-gregorian-from-absolute
|
|
|
2333 (calendar-absolute-from-hebrew date)))
|
|
|
2334 (or noecho (calendar-print-hebrew-date)))
|
|
|
2335
|
|
|
2336 (defun calendar-goto-islamic-date (date &optional noecho)
|
|
|
2337 "Move cursor to Islamic DATE; echo Islamic date unless NOECHO is t."
|
|
|
2338 (interactive
|
|
|
2339 (let* ((today (calendar-current-date))
|
|
|
2340 (year (calendar-read
|
|
|
2341 "Islamic calendar year (>0): "
|
|
|
2342 '(lambda (x) (> x 0))
|
|
|
2343 (int-to-string
|
|
|
2344 (extract-calendar-year
|
|
|
2345 (calendar-islamic-from-absolute
|
|
|
2346 (calendar-absolute-from-gregorian today))))))
|
|
|
2347 (month-array calendar-islamic-month-name-array)
|
|
|
2348 (completion-ignore-case t)
|
|
|
2349 (month (cdr (assoc
|
|
|
2350 (capitalize
|
|
|
2351 (completing-read
|
|
|
2352 "Islamic calendar month name: "
|
|
|
2353 (mapcar 'list (append month-array nil))
|
|
|
2354 nil t))
|
|
|
2355 (calendar-make-alist month-array 1 'capitalize))))
|
|
|
2356 (last (islamic-calendar-last-day-of-month month year))
|
|
|
2357 (day (calendar-read
|
|
|
2358 (format "Islamic calendar day (1-%d): " last)
|
|
|
2359 '(lambda (x) (and (< 0 x) (<= x last))))))
|
|
|
2360 (list (list month day year))))
|
|
|
2361 (calendar-goto-date (calendar-gregorian-from-absolute
|
|
|
2362 (calendar-absolute-from-islamic date)))
|
|
|
2363 (or noecho (calendar-print-islamic-date)))
|
|
|
2364
|
|
|
2365 (defun calendar-goto-iso-date (date &optional noecho)
|
|
|
2366 "Move cursor to ISO DATE; echo ISO date unless NOECHO is t."
|
|
|
2367 (interactive
|
|
|
2368 (let* ((today (calendar-current-date))
|
|
|
2369 (year (calendar-read
|
|
|
2370 "ISO calendar year (>0): "
|
|
|
2371 '(lambda (x) (> x 0))
|
|
|
2372 (int-to-string (extract-calendar-year today))))
|
|
|
2373 (no-weeks (extract-calendar-month
|
|
|
2374 (calendar-iso-from-absolute
|
|
|
2375 (1-
|
|
|
2376 (calendar-dayname-on-or-before
|
|
|
2377 1 (calendar-absolute-from-gregorian
|
|
|
2378 (list 1 4 (1+ year))))))))
|
|
|
2379 (week (calendar-read
|
|
|
2380 (format "ISO calendar week (1-%d): " no-weeks)
|
|
|
2381 '(lambda (x) (and (> x 0) (<= x no-weeks)))))
|
|
|
2382 (day (calendar-read
|
|
|
2383 "ISO day (1-7): "
|
|
|
2384 '(lambda (x) (and (<= 1 x) (<= x 7))))))
|
|
|
2385 (list (list week day year))))
|
|
|
2386 (calendar-goto-date (calendar-gregorian-from-absolute
|
|
|
2387 (calendar-absolute-from-iso date)))
|
|
|
2388 (or noecho (calendar-print-iso-date)))
|
|
|
2389
|
|
|
2390 (defun calendar-interval (mon1 yr1 mon2 yr2)
|
|
|
2391 "The number of months difference between MON1, YR1 and MON2, YR2."
|
|
|
2392 (+ (* 12 (- yr2 yr1))
|
|
|
2393 (- mon2 mon1)))
|
|
|
2394
|
|
|
2395 (defun calendar-day-name (date)
|
|
|
2396 "Returns a string with the name of the day of the week of DATE."
|
|
|
2397 (aref calendar-day-name-array (calendar-day-of-week date)))
|
|
|
2398
|
|
|
2399 (defvar calendar-day-name-array
|
|
|
2400 ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"])
|
|
|
2401
|
|
|
2402 (defvar calendar-month-name-array
|
|
|
2403 ["January" "February" "March" "April" "May" "June"
|
|
|
2404 "July" "August" "September" "October" "November" "December"])
|
|
|
2405
|
|
|
2406 (defun calendar-make-alist (sequence &optional start-index filter)
|
|
|
2407 "Make an assoc list corresponding to SEQUENCE.
|
|
|
2408 Start at index 1, unless optional START-INDEX is provided.
|
|
|
2409 If FILTER is provided, apply it to each item in the list."
|
|
|
2410 (let ((index (if start-index (1- start-index) 0)))
|
|
|
2411 (mapcar
|
|
|
2412 '(lambda (x)
|
|
|
2413 (setq index (1+ index))
|
|
|
2414 (cons (if filter (funcall filter x) x)
|
|
|
2415 index))
|
|
|
2416 (append sequence nil))))
|
|
|
2417
|
|
|
2418 (defun calendar-month-name (month)
|
|
|
2419 "The name of MONTH."
|
|
|
2420 (aref calendar-month-name-array (1- month)))
|
|
|
2421
|
|
|
2422 (defun calendar-day-of-week (date)
|
|
|
2423 "Returns the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc."
|
|
|
2424 (% (calendar-absolute-from-gregorian date) 7))
|
|
|
2425
|
|
|
2426 (defun calendar-unmark ()
|
|
|
2427 "Delete all diary/holiday marks/highlighting from the calendar."
|
|
|
2428 (interactive)
|
|
|
2429 (setq mark-holidays-in-calendar nil)
|
|
|
2430 (setq mark-diary-entries-in-calendar nil)
|
|
|
2431 (redraw-calendar))
|
|
|
2432
|
|
|
2433 (defun calendar-date-is-visible-p (date)
|
|
|
2434 "Returns t if DATE is legal and is visible in the calendar window."
|
|
|
2435 (let ((gap (calendar-interval
|
|
|
2436 displayed-month displayed-year
|
|
|
2437 (extract-calendar-month date) (extract-calendar-year date))))
|
|
|
2438 (and (calendar-date-is-legal-p date) (> 2 gap) (< -2 gap))))
|
|
|
2439
|
|
|
2440 (defun calendar-date-is-legal-p (date)
|
|
|
2441 "Returns t if DATE is a legal date."
|
|
|
2442 (let ((month (extract-calendar-month date))
|
|
|
2443 (day (extract-calendar-day date))
|
|
|
2444 (year (extract-calendar-year date)))
|
|
|
2445 (and (<= 1 month) (<= month 12)
|
|
|
2446 (<= 1 day) (<= day (calendar-last-day-of-month month year))
|
|
|
2447 (<= 1 year))))
|
|
|
2448
|
|
|
2449 (defun calendar-date-equal (date1 date2)
|
|
|
2450 "Returns t if the DATE1 and DATE2 are the same."
|
|
|
2451 (and
|
|
|
2452 (= (extract-calendar-month date1) (extract-calendar-month date2))
|
|
|
2453 (= (extract-calendar-day date1) (extract-calendar-day date2))
|
|
|
2454 (= (extract-calendar-year date1) (extract-calendar-year date2))))
|
|
|
2455
|
|
|
2456 (defun mark-visible-calendar-date (date &optional mark)
|
|
|
2457 "Mark DATE in the calendar window with MARK.
|
|
|
2458 MARK is either a single-character string or a face.
|
|
|
2459 MARK defaults to diary-entry-marker."
|
|
|
2460 (if (calendar-date-is-legal-p date)
|
|
|
2461 (save-excursion
|
|
|
2462 (set-buffer calendar-buffer)
|
|
|
2463 (calendar-cursor-to-visible-date date)
|
|
|
2464 (let ((mark (or mark diary-entry-marker)))
|
|
|
2465 (if (stringp mark)
|
|
|
2466 (let ((buffer-read-only nil))
|
|
|
2467 (forward-char 1)
|
|
|
2468 (delete-char 1)
|
|
|
2469 (insert mark)
|
|
|
2470 (forward-char -2))
|
|
|
2471
|
|
|
2472 (set-extent-property (make-extent (1- (point)) (1+ (point)))
|
|
|
2473 'face mark))))))
|
|
|
2474
|
|
|
2475 (defun calendar-star-date ()
|
|
|
2476 "Replace the date under the cursor in the calendar window with asterisks.
|
|
|
2477 This function can be used with the today-visible-calendar-hook run after the
|
|
|
2478 calendar window has been prepared."
|
|
|
2479 (let ((buffer-read-only nil))
|
|
|
2480 (make-variable-buffer-local 'calendar-starred-day)
|
|
|
2481 (forward-char 1)
|
|
|
2482 (setq calendar-starred-day
|
|
|
2483 (string-to-int
|
|
|
2484 (buffer-substring (point) (- (point) 2))))
|
|
|
2485 (delete-char -2)
|
|
|
2486 (insert "**")
|
|
|
2487 (backward-char 1)
|
|
|
2488 (set-buffer-modified-p nil)))
|
|
|
2489
|
|
|
2490 (defun calendar-mark-today ()
|
|
|
2491 "Mark the date under the cursor in the calendar window.
|
|
|
2492 The date is marked with calendar-today-marker. This function can be used with
|
|
|
2493 the today-visible-calendar-hook run after the calendar window has been
|
|
|
2494 prepared."
|
|
|
2495 (mark-visible-calendar-date
|
|
|
2496 (calendar-cursor-to-date)
|
|
|
2497 calendar-today-marker))
|
|
|
2498
|
|
|
2499 (defun calendar-date-compare (date1 date2)
|
|
|
2500 "Returns t if DATE1 is before DATE2, nil otherwise.
|
|
|
2501 The actual dates are in the car of DATE1 and DATE2."
|
|
|
2502 (< (calendar-absolute-from-gregorian (car date1))
|
|
|
2503 (calendar-absolute-from-gregorian (car date2))))
|
|
|
2504
|
|
|
2505 (defun calendar-date-string (date &optional abbreviate nodayname)
|
|
|
2506 "A string form of DATE, driven by the variable `calendar-date-display-form'.
|
|
|
2507 An optional parameter ABBREVIATE, when t, causes the month and day names to be
|
|
|
2508 abbreviated to three characters. An optional parameter NODAYNAME, when t,
|
|
|
2509 omits the name of the day of the week."
|
|
|
2510 (let* ((dayname
|
|
|
2511 (if nodayname
|
|
|
2512 nil
|
|
|
2513 (if abbreviate
|
|
|
2514 (substring (calendar-day-name date) 0 3)
|
|
|
2515 (calendar-day-name date))))
|
|
|
2516 (month (extract-calendar-month date))
|
|
|
2517 (monthname
|
|
|
2518 (if abbreviate
|
|
|
2519 (substring
|
|
|
2520 (calendar-month-name month) 0 3)
|
|
|
2521 (calendar-month-name month)))
|
|
|
2522 (day (int-to-string (extract-calendar-day date)))
|
|
|
2523 (month (int-to-string month))
|
|
|
2524 (year (int-to-string (extract-calendar-year date))))
|
|
|
2525 (mapconcat 'eval calendar-date-display-form "")))
|
|
|
2526
|
|
|
2527 (defun calendar-dayname-on-or-before (dayname date)
|
|
|
2528 "Returns the absolute date of the DAYNAME on or before absolute DATE.
|
|
|
2529 DAYNAME=0 means Sunday, DAYNAME=1 means Monday, and so on.
|
|
|
2530
|
|
|
2531 Note: Applying this function to d+6 gives us the DAYNAME on or after an
|
|
|
2532 absolute day d. Similarly, applying it to d+3 gives the DAYNAME nearest to
|
|
|
2533 absolute date d, applying it to d-1 gives the DAYNAME previous to absolute
|
|
|
2534 date d, and applying it to d+7 gives the DAYNAME following absolute date d."
|
|
|
2535 (- date (% (- date dayname) 7)))
|
|
|
2536
|
|
|
2537 (defun calendar-nth-named-absday (n dayname month year &optional day)
|
|
|
2538 "The absolute date of Nth DAYNAME in MONTH, YEAR before/after optional DAY.
|
|
|
2539 A DAYNAME of 0 means Sunday, 1 means Monday, and so on. If N<0,
|
|
|
2540 return the Nth DAYNAME before MONTH DAY, YEAR (inclusive).
|
|
|
2541 If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive).
|
|
|
2542
|
|
|
2543 If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise."
|
|
|
2544 (if (> n 0)
|
|
|
2545 (+ (* 7 (1- n))
|
|
|
2546 (calendar-dayname-on-or-before
|
|
|
2547 dayname
|
|
|
2548 (+ 6 (calendar-absolute-from-gregorian
|
|
|
2549 (list month (or day 1) year)))))
|
|
|
2550 (+ (* 7 (1+ n))
|
|
|
2551 (calendar-dayname-on-or-before
|
|
|
2552 dayname
|
|
|
2553 (calendar-absolute-from-gregorian
|
|
|
2554 (list month
|
|
|
2555 (or day (calendar-last-day-of-month month year))
|
|
|
2556 year))))))
|
|
|
2557
|
|
|
2558 (defun calendar-nth-named-day (n dayname month year &optional day)
|
|
|
2559 "The date of Nth DAYNAME in MONTH, YEAR before/after optional DAY.
|
|
|
2560 A DAYNAME of 0 means Sunday, 1 means Monday, and so on. If N<0,
|
|
|
2561 return the Nth DAYNAME before MONTH DAY, YEAR (inclusive).
|
|
|
2562 If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive).
|
|
|
2563
|
|
|
2564 If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise."
|
|
|
2565 (calendar-gregorian-from-absolute
|
|
|
2566 (calendar-nth-named-absday n dayname month year day)))
|
|
|
2567
|
|
|
2568 (defun calendar-day-of-year-string (&optional date)
|
|
|
2569 "String of day number of year of Gregorian DATE.
|
|
|
2570 Defaults to today's date if DATE is not given."
|
|
|
2571 (let* ((d (or date (calendar-current-date)))
|
|
|
2572 (year (extract-calendar-year d))
|
|
|
2573 (day (calendar-day-number d))
|
|
|
2574 (days-remaining (- (calendar-day-number (list 12 31 year)) day)))
|
|
|
2575 (format "Day %d of %d; %d day%s remaining in the year"
|
|
|
2576 day year days-remaining (if (= days-remaining 1) "" "s"))))
|
|
|
2577
|
|
|
2578 (defun calendar-print-day-of-year ()
|
|
|
2579 "Show day number in year/days remaining in year for date under the cursor."
|
|
|
2580 (interactive)
|
|
|
2581 (message (calendar-day-of-year-string (calendar-cursor-to-date t))))
|
|
|
2582
|
|
|
2583 (defun calendar-absolute-from-iso (date)
|
|
|
2584 "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
|
|
|
2585 The `ISO year' corresponds approximately to the Gregorian year, but
|
|
|
2586 weeks start on Monday and end on Sunday. The first week of the ISO year is
|
|
|
2587 the first such week in which at least 4 days are in a year. The ISO
|
|
|
2588 commercial DATE has the form (week day year) in which week is in the range
|
|
|
2589 1..52 and day is in the range 0..6 (1 = Monday, 2 = Tuesday, ..., 0 =
|
|
|
2590 Sunday). The Gregorian date Sunday, December 31, 1 BC is imaginary."
|
|
|
2591 (let* ((week (extract-calendar-month date))
|
|
|
2592 (day (extract-calendar-day date))
|
|
|
2593 (year (extract-calendar-year date)))
|
|
|
2594 (+ (calendar-dayname-on-or-before
|
|
|
2595 1 (+ 3 (calendar-absolute-from-gregorian (list 1 1 year))))
|
|
|
2596 (* 7 (1- week))
|
|
|
2597 (if (= day 0) 6 (1- day)))))
|
|
|
2598
|
|
|
2599 (defun calendar-iso-from-absolute (date)
|
|
|
2600 "Compute the `ISO commercial date' corresponding to the absolute DATE.
|
|
|
2601 The ISO year corresponds approximately to the Gregorian year, but weeks
|
|
|
2602 start on Monday and end on Sunday. The first week of the ISO year is the
|
|
|
2603 first such week in which at least 4 days are in a year. The ISO commercial
|
|
|
2604 date has the form (week day year) in which week is in the range 1..52 and
|
|
|
2605 day is in the range 0..6 (1 = Monday, 2 = Tuesday, ..., 0 = Sunday). The
|
|
|
2606 absolute date is the number of days elapsed since the (imaginary) Gregorian
|
|
|
2607 date Sunday, December 31, 1 BC."
|
|
|
2608 (let* ((approx (extract-calendar-year
|
|
|
2609 (calendar-gregorian-from-absolute (- date 3))))
|
|
|
2610 (year (+ approx
|
|
|
2611 (calendar-sum y approx
|
|
|
2612 (>= date (calendar-absolute-from-iso (list 1 1 (1+ y))))
|
|
|
2613 1))))
|
|
|
2614 (list
|
|
|
2615 (1+ (/ (- date (calendar-absolute-from-iso (list 1 1 year))) 7))
|
|
|
2616 (% date 7)
|
|
|
2617 year)))
|
|
|
2618
|
|
|
2619 (defun calendar-iso-date-string (&optional date)
|
|
|
2620 "String of ISO date of Gregorian DATE.
|
|
|
2621 Defaults to today's date if DATE is not given."
|
|
|
2622 (let* ((d (calendar-absolute-from-gregorian
|
|
|
2623 (or date (calendar-current-date))))
|
|
|
2624 (day (% d 7))
|
|
|
2625 (iso-date (calendar-iso-from-absolute d)))
|
|
|
2626 (format "Day %s of week %d of %d"
|
|
|
2627 (if (zerop day) 7 day)
|
|
|
2628 (extract-calendar-month iso-date)
|
|
|
2629 (extract-calendar-year iso-date))))
|
|
|
2630
|
|
|
2631 (defun calendar-print-iso-date ()
|
|
|
2632 "Show equivalent ISO date for the date under the cursor."
|
|
|
2633 (interactive)
|
|
|
2634 (message "ISO date: %s"
|
|
|
2635 (calendar-iso-date-string (calendar-cursor-to-date t))))
|
|
|
2636
|
|
|
2637 (defun calendar-julian-from-absolute (date)
|
|
|
2638 "Compute the Julian (month day year) corresponding to the absolute DATE.
|
|
|
2639 The absolute date is the number of days elapsed since the (imaginary)
|
|
|
2640 Gregorian date Sunday, December 31, 1 BC."
|
|
|
2641 (let* ((approx (/ (+ date 2) 366));; Approximation from below.
|
|
|
2642 (year ;; Search forward from the approximation.
|
|
|
2643 (+ approx
|
|
|
2644 (calendar-sum y approx
|
|
|
2645 (>= date (calendar-absolute-from-julian (list 1 1 (1+ y))))
|
|
|
2646 1)))
|
|
|
2647 (month ;; Search forward from January.
|
|
|
2648 (1+ (calendar-sum m 1
|
|
|
2649 (> date
|
|
|
2650 (calendar-absolute-from-julian
|
|
|
2651 (list m
|
|
|
2652 (if (and (= m 2) (= (% year 4) 0))
|
|
|
2653 29
|
|
|
2654 (aref [31 28 31 30 31 30 31 31 30 31 30 31]
|
|
|
2655 (1- m)))
|
|
|
2656 year)))
|
|
|
2657 1)))
|
|
|
2658 (day ;; Calculate the day by subtraction.
|
|
|
2659 (- date (1- (calendar-absolute-from-julian (list month 1 year))))))
|
|
|
2660 (list month day year)))
|
|
|
2661
|
|
|
2662 (defun calendar-absolute-from-julian (date)
|
|
|
2663 "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
|
|
|
2664 The Gregorian date Sunday, December 31, 1 BC is imaginary."
|
|
|
2665 (let ((month (extract-calendar-month date))
|
|
|
2666 (day (extract-calendar-day date))
|
|
|
2667 (year (extract-calendar-year date)))
|
|
|
2668 (+ (calendar-day-number date)
|
|
|
2669 (if (and (= (% year 100) 0)
|
|
|
2670 (/= (% year 400) 0)
|
|
|
2671 (> month 2))
|
|
|
2672 1 0);; Correct for Julian but not Gregorian leap year.
|
|
|
2673 (* 365 (1- year))
|
|
|
2674 (/ (1- year) 4)
|
|
|
2675 -2)))
|
|
|
2676
|
|
|
2677 (defun calendar-julian-date-string (&optional date)
|
|
|
2678 "String of Julian date of Gregorian DATE.
|
|
|
2679 Defaults to today's date if DATE is not given.
|
|
|
2680 Driven by the variable `calendar-date-display-form'."
|
|
|
2681 (calendar-date-string
|
|
|
2682 (calendar-julian-from-absolute
|
|
|
2683 (calendar-absolute-from-gregorian
|
|
|
2684 (or date (calendar-current-date))))
|
|
|
2685 nil t))
|
|
|
2686
|
|
|
2687 (defun calendar-print-julian-date ()
|
|
|
2688 "Show the Julian calendar equivalent of the date under the cursor."
|
|
|
2689 (interactive)
|
|
|
2690 (message "Julian date: %s"
|
|
|
2691 (calendar-julian-date-string (calendar-cursor-to-date t))))
|
|
|
2692
|
|
|
2693 (defun islamic-calendar-leap-year-p (year)
|
|
|
2694 "Returns t if YEAR is a leap year on the Islamic calendar."
|
|
|
2695 (memq (% year 30)
|
|
|
2696 (list 2 5 7 10 13 16 18 21 24 26 29)))
|
|
|
2697
|
|
|
2698 (defun islamic-calendar-last-day-of-month (month year)
|
|
|
2699 "The last day in MONTH during YEAR on the Islamic calendar."
|
|
|
2700 (cond
|
|
|
2701 ((memq month (list 1 3 5 7 9 11)) 30)
|
|
|
2702 ((memq month (list 2 4 6 8 10)) 29)
|
|
|
2703 (t (if (islamic-calendar-leap-year-p year) 30 29))))
|
|
|
2704
|
|
|
2705 (defun islamic-calendar-day-number (date)
|
|
|
2706 "Return the day number within the year of the Islamic date DATE."
|
|
|
2707 (let* ((month (extract-calendar-month date))
|
|
|
2708 (day (extract-calendar-day date)))
|
|
|
2709 (+ (* 30 (/ month 2))
|
|
|
2710 (* 29 (/ (1- month) 2))
|
|
|
2711 day)))
|
|
|
2712
|
|
|
2713 (defun calendar-absolute-from-islamic (date)
|
|
|
2714 "Absolute date of Islamic DATE.
|
|
|
2715 The absolute date is the number of days elapsed since the (imaginary)
|
|
|
2716 Gregorian date Sunday, December 31, 1 BC."
|
|
|
2717 (let* ((month (extract-calendar-month date))
|
|
|
2718 (day (extract-calendar-day date))
|
|
|
2719 (year (extract-calendar-year date))
|
|
|
2720 (y (% year 30))
|
|
|
2721 (leap-years-in-cycle
|
|
|
2722 (cond
|
|
|
2723 ((< y 3) 0) ((< y 6) 1) ((< y 8) 2) ((< y 11) 3) ((< y 14) 4)
|
|
|
2724 ((< y 17) 5) ((< y 19) 6) ((< y 22) 7) ((< y 25) 8) ((< y 27) 9)
|
|
|
2725 (t 10))))
|
|
|
2726 (+ (islamic-calendar-day-number date);; days so far this year
|
|
|
2727 (* (1- year) 354) ;; days in all non-leap years
|
|
|
2728 (* 11 (/ year 30)) ;; leap days in complete cycles
|
|
|
2729 leap-years-in-cycle ;; leap days this cycle
|
|
|
2730 227014))) ;; days before start of calendar
|
|
|
2731
|
|
|
2732 (defun calendar-islamic-from-absolute (date)
|
|
|
2733 "Compute the Islamic date (month day year) corresponding to absolute DATE.
|
|
|
2734 The absolute date is the number of days elapsed since the (imaginary)
|
|
|
2735 Gregorian date Sunday, December 31, 1 BC."
|
|
|
2736 (if (< date 227015)
|
|
|
2737 (list 0 0 0);; pre-Islamic date
|
|
|
2738 (let* ((approx (/ (- date 227014) 355));; Approximation from below.
|
|
|
2739 (year ;; Search forward from the approximation.
|
|
|
2740 (+ approx
|
|
|
2741 (calendar-sum y approx
|
|
|
2742 (>= date (calendar-absolute-from-islamic
|
|
|
2743 (list 1 1 (1+ y))))
|
|
|
2744 1)))
|
|
|
2745 (month ;; Search forward from Muharram.
|
|
|
2746 (1+ (calendar-sum m 1
|
|
|
2747 (> date
|
|
|
2748 (calendar-absolute-from-islamic
|
|
|
2749 (list m
|
|
|
2750 (islamic-calendar-last-day-of-month
|
|
|
2751 m year)
|
|
|
2752 year)))
|
|
|
2753 1)))
|
|
|
2754 (day ;; Calculate the day by subtraction.
|
|
|
2755 (- date
|
|
|
2756 (1- (calendar-absolute-from-islamic (list month 1 year))))))
|
|
|
2757 (list month day year))))
|
|
|
2758
|
|
|
2759 (defvar calendar-islamic-month-name-array
|
|
|
2760 ["Muharram" "Safar" "Rabi I" "Rabi II" "Jumada I" "Jumada II"
|
|
|
2761 "Rajab" "Sha'ban" "Ramadan" "Shawwal" "Dhu al-Qada" "Dhu al-Hijjah"])
|
|
|
2762
|
|
|
2763 (defun calendar-islamic-date-string (&optional date)
|
|
|
2764 "String of Islamic date before sunset of Gregorian DATE.
|
|
|
2765 Returns the empty string if DATE is pre-Islamic.
|
|
|
2766 Defaults to today's date if DATE is not given.
|
|
|
2767 Driven by the variable `calendar-date-display-form'."
|
|
|
2768 (let ((calendar-month-name-array calendar-islamic-month-name-array)
|
|
|
2769 (islamic-date (calendar-islamic-from-absolute
|
|
|
2770 (calendar-absolute-from-gregorian
|
|
|
2771 (or date (calendar-current-date))))))
|
|
|
2772 (if (< (extract-calendar-year islamic-date) 1)
|
|
|
2773 ""
|
|
|
2774 (calendar-date-string islamic-date nil t))))
|
|
|
2775
|
|
|
2776 (defun calendar-print-islamic-date ()
|
|
|
2777 "Show the Islamic calendar equivalent of the date under the cursor."
|
|
|
2778 (interactive)
|
|
|
2779 (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t))))
|
|
|
2780 (if (string-equal i "")
|
|
|
2781 (message "Date is pre-Islamic")
|
|
|
2782 (message "Islamic date (until sunset): %s" i))))
|
|
|
2783
|
|
|
2784 (defun calendar-hebrew-from-absolute (date)
|
|
|
2785 "Compute the Hebrew date (month day year) corresponding to absolute DATE.
|
|
|
2786 The absolute date is the number of days elapsed since the (imaginary)
|
|
|
2787 Gregorian date Sunday, December 31, 1 BC."
|
|
|
2788 (let* ((greg-date (calendar-gregorian-from-absolute date))
|
|
|
2789 (month (aref [9 10 11 12 1 2 3 4 7 7 7 8]
|
|
|
2790 (1- (extract-calendar-month greg-date))))
|
|
|
2791 (day)
|
|
|
2792 (year (+ 3760 (extract-calendar-year greg-date))))
|
|
|
2793 (while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year))))
|
|
|
2794 (setq year (1+ year)))
|
|
|
2795 (let ((length (hebrew-calendar-last-month-of-year year)))
|
|
|
2796 (while (> date
|
|
|
2797 (calendar-absolute-from-hebrew
|
|
|
2798 (list month
|
|
|
2799 (hebrew-calendar-last-day-of-month month year)
|
|
|
2800 year)))
|
|
|
2801 (setq month (1+ (% month length)))))
|
|
|
2802 (setq day (1+
|
|
|
2803 (- date (calendar-absolute-from-hebrew (list month 1 year)))))
|
|
|
2804 (list month day year)))
|
|
|
2805
|
|
|
2806 (defun hebrew-calendar-leap-year-p (year)
|
|
|
2807 "t if YEAR is a Hebrew calendar leap year."
|
|
|
2808 (< (% (1+ (* 7 year)) 19) 7))
|
|
|
2809
|
|
|
2810 (defun hebrew-calendar-last-month-of-year (year)
|
|
|
2811 "The last month of the Hebrew calendar YEAR."
|
|
|
2812 (if (hebrew-calendar-leap-year-p year)
|
|
|
2813 13
|
|
|
2814 12))
|
|
|
2815
|
|
|
2816 (defun hebrew-calendar-last-day-of-month (month year)
|
|
|
2817 "The last day of MONTH in YEAR."
|
|
|
2818 (if (or (memq month (list 2 4 6 10 13))
|
|
|
2819 (and (= month 12) (not (hebrew-calendar-leap-year-p year)))
|
|
|
2820 (and (= month 8) (not (hebrew-calendar-long-heshvan-p year)))
|
|
|
2821 (and (= month 9) (hebrew-calendar-short-kislev-p year)))
|
|
|
2822 29
|
|
|
2823 30))
|
|
|
2824
|
|
|
2825 (defun hebrew-calendar-elapsed-days (year)
|
|
|
2826 "Days from Sun. prior to start of Hebrew calendar to mean conjunction of Tishri of Hebrew YEAR."
|
|
|
2827 (let* ((months-elapsed
|
|
|
2828 (+ (* 235 (/ (1- year) 19));; Months in complete cycles so far.
|
|
|
2829 (* 12 (% (1- year) 19)) ;; Regular months in this cycle
|
|
|
2830 (/ (1+ (* 7 (% (1- year) 19))) 19)));; Leap months this cycle
|
|
|
2831 (parts-elapsed (+ 204 (* 793 (% months-elapsed 1080))))
|
|
|
2832 (hours-elapsed (+ 5
|
|
|
2833 (* 12 months-elapsed)
|
|
|
2834 (* 793 (/ months-elapsed 1080))
|
|
|
2835 (/ parts-elapsed 1080)))
|
|
|
2836 (parts ;; Conjunction parts
|
|
|
2837 (+ (* 1080 (% hours-elapsed 24)) (% parts-elapsed 1080)))
|
|
|
2838 (day ;; Conjunction day
|
|
|
2839 (+ 1 (* 29 months-elapsed) (/ hours-elapsed 24)))
|
|
|
2840 (alternative-day
|
|
|
2841 (if (or (>= parts 19440) ;; If the new moon is at or after midday,
|
|
|
2842 (and (= (% day 7) 2);; ...or is on a Tuesday...
|
|
|
2843 (>= parts 9924) ;; at 9 hours, 204 parts or later...
|
|
|
2844 (not (hebrew-calendar-leap-year-p year)));; of a
|
|
|
2845 ;; common year,
|
|
|
2846 (and (= (% day 7) 1);; ...or is on a Monday...
|
|
|
2847 (>= parts 16789) ;; at 15 hours, 589 parts or later...
|
|
|
2848 (hebrew-calendar-leap-year-p (1- year))));; at the end
|
|
|
2849 ;; of a leap year
|
|
|
2850 ;; Then postpone Rosh HaShanah one day
|
|
|
2851 (1+ day)
|
|
|
2852 ;; Else
|
|
|
2853 day)))
|
|
|
2854 (if ;; If Rosh HaShanah would occur on Sunday, Wednesday, or Friday
|
|
|
2855 (memq (% alternative-day 7) (list 0 3 5))
|
|
|
2856 ;; Then postpone it one (more) day and return
|
|
|
2857 (1+ alternative-day)
|
|
|
2858 ;; Else return
|
|
|
2859 alternative-day)))
|
|
|
2860
|
|
|
2861 (defun hebrew-calendar-days-in-year (year)
|
|
|
2862 "Number of days in Hebrew YEAR."
|
|
|
2863 (- (hebrew-calendar-elapsed-days (1+ year))
|
|
|
2864 (hebrew-calendar-elapsed-days year)))
|
|
|
2865
|
|
|
2866 (defun hebrew-calendar-long-heshvan-p (year)
|
|
|
2867 "t if Heshvan is long in Hebrew YEAR."
|
|
|
2868 (= (% (hebrew-calendar-days-in-year year) 10) 5))
|
|
|
2869
|
|
|
2870 (defun hebrew-calendar-short-kislev-p (year)
|
|
|
2871 "t if Kislev is short in Hebrew YEAR."
|
|
|
2872 (= (% (hebrew-calendar-days-in-year year) 10) 3))
|
|
|
2873
|
|
|
2874 (defun calendar-absolute-from-hebrew (date)
|
|
|
2875 "Absolute date of Hebrew DATE.
|
|
|
2876 The absolute date is the number of days elapsed since the (imaginary)
|
|
|
2877 Gregorian date Sunday, December 31, 1 BC."
|
|
|
2878 (let* ((month (extract-calendar-month date))
|
|
|
2879 (day (extract-calendar-day date))
|
|
|
2880 (year (extract-calendar-year date)))
|
|
|
2881 (+ day ;; Days so far this month.
|
|
|
2882 (if (< month 7);; before Tishri
|
|
|
2883 ;; Then add days in prior months this year before and after Nisan
|
|
|
2884 (+ (calendar-sum
|
|
|
2885 m 7 (<= m (hebrew-calendar-last-month-of-year year))
|
|
|
2886 (hebrew-calendar-last-day-of-month m year))
|
|
|
2887 (calendar-sum
|
|
|
2888 m 1 (< m month)
|
|
|
2889 (hebrew-calendar-last-day-of-month m year)))
|
|
|
2890 ;; Else add days in prior months this year
|
|
|
2891 (calendar-sum
|
|
|
2892 m 7 (< m month)
|
|
|
2893 (hebrew-calendar-last-day-of-month m year)))
|
|
|
2894 (hebrew-calendar-elapsed-days year);; Days in prior years.
|
|
|
2895 -1373429))) ;; Days elapsed before absolute date 1.
|
|
|
2896
|
|
|
2897 (defvar calendar-hebrew-month-name-array-common-year
|
|
|
2898 ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
|
|
|
2899 "Heshvan" "Kislev" "Teveth" "Shevat" "Adar"])
|
|
|
2900
|
|
|
2901 (defvar calendar-hebrew-month-name-array-leap-year
|
|
|
2902 ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri"
|
|
|
2903 "Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"])
|
|
|
2904
|
|
|
2905 (defun calendar-hebrew-date-string (&optional date)
|
|
|
2906 "String of Hebrew date before sunset of Gregorian DATE.
|
|
|
2907 Defaults to today's date if DATE is not given.
|
|
|
2908 Driven by the variable `calendar-date-display-form'."
|
|
|
2909 (let* ((hebrew-date (calendar-hebrew-from-absolute
|
|
|
2910 (calendar-absolute-from-gregorian
|
|
|
2911 (or date (calendar-current-date)))))
|
|
|
2912 (calendar-month-name-array
|
|
|
2913 (if (hebrew-calendar-leap-year-p (extract-calendar-year hebrew-date))
|
|
|
2914 calendar-hebrew-month-name-array-leap-year
|
|
|
2915 calendar-hebrew-month-name-array-common-year)))
|
|
|
2916 (calendar-date-string hebrew-date nil t)))
|
|
|
2917
|
|
|
2918 (defun calendar-print-hebrew-date ()
|
|
|
2919 "Show the Hebrew calendar equivalent of the date under the cursor."
|
|
|
2920 (interactive)
|
|
|
2921 (message "Hebrew date (until sunset): %s"
|
|
|
2922 (calendar-hebrew-date-string (calendar-cursor-to-date t))))
|
|
|
2923
|
|
|
2924 (defun hebrew-calendar-yahrzeit (death-date year)
|
|
|
2925 "Absolute date of the anniversary of Hebrew DEATH-DATE in Hebrew YEAR."
|
|
|
2926 (let* ((death-day (extract-calendar-day death-date))
|
|
|
2927 (death-month (extract-calendar-month death-date))
|
|
|
2928 (death-year (extract-calendar-year death-date)))
|
|
|
2929 (cond
|
|
|
2930 ;; If it's Heshvan 30 it depends on the first anniversary; if
|
|
|
2931 ;; that was not Heshvan 30, use the day before Kislev 1.
|
|
|
2932 ((and (= death-month 8)
|
|
|
2933 (= death-day 30)
|
|
|
2934 (not (hebrew-calendar-long-heshvan-p (1+ death-year))))
|
|
|
2935 (1- (calendar-absolute-from-hebrew (list 9 1 year))))
|
|
|
2936 ;; If it's Kislev 30 it depends on the first anniversary; if
|
|
|
2937 ;; that was not Kislev 30, use the day before Teveth 1.
|
|
|
2938 ((and (= death-month 9)
|
|
|
2939 (= death-day 30)
|
|
|
2940 (hebrew-calendar-short-kislev-p (1+ death-year)))
|
|
|
2941 (1- (calendar-absolute-from-hebrew (list 10 1 year))))
|
|
|
2942 ;; If it's Adar II, use the same day in last month of
|
|
|
2943 ;; year (Adar or Adar II).
|
|
|
2944 ((= death-month 13)
|
|
|
2945 (calendar-absolute-from-hebrew
|
|
|
2946 (list (hebrew-calendar-last-month-of-year year) death-day year)))
|
|
|
2947 ;; If it's the 30th in Adar I and year is not a leap year
|
|
|
2948 ;; (so Adar has only 29 days), use the last day in Shevat.
|
|
|
2949 ((and (= death-day 30)
|
|
|
2950 (= death-month 12)
|
|
|
2951 (not (hebrew-calendar-leap-year-p year)))
|
|
|
2952 (calendar-absolute-from-hebrew (list 11 30 year)))
|
|
|
2953 ;; In all other cases, use the normal anniversary of the date of death.
|
|
|
2954 (t (calendar-absolute-from-hebrew
|
|
|
2955 (list death-month death-day year))))))
|
|
|
2956
|
|
|
2957 (defun calendar-set-mode-line (str)
|
|
|
2958 "Set mode line to STR, centered, surrounded by dashes."
|
|
|
2959 (setq mode-line-format
|
|
|
2960 (calendar-string-spread (list "" str "") ?- (frame-width))))
|
|
|
2961
|
|
|
2962 ;;;###autoload
|
|
|
2963 (defun list-yahrzeit-dates (death-date start-year end-year)
|
|
|
2964 "List Yahrzeit dates for *Gregorian* DEATH-DATE from START-YEAR to END-YEAR.
|
|
|
2965 When called interactively from the calendar window, the date of death is taken
|
|
|
2966 from the cursor position."
|
|
|
2967 (interactive
|
|
|
2968 (let* ((death-date
|
|
|
2969 (if (equal (current-buffer) (get-buffer calendar-buffer))
|
|
|
2970 (calendar-cursor-to-date)
|
|
|
2971 (let* ((today (calendar-current-date))
|
|
|
2972 (year (calendar-read
|
|
|
2973 "Year of death (>0): "
|
|
|
2974 '(lambda (x) (> x 0))
|
|
|
2975 (int-to-string (extract-calendar-year today))))
|
|
|
2976 (month-array calendar-month-name-array)
|
|
|
2977 (completion-ignore-case t)
|
|
|
2978 (month (cdr (assoc
|
|
|
2979 (capitalize
|
|
|
2980 (completing-read
|
|
|
2981 "Month of death (name): "
|
|
|
2982 (mapcar 'list (append month-array nil))
|
|
|
2983 nil t))
|
|
|
2984 (calendar-make-alist
|
|
|
2985 month-array 1 'capitalize))))
|
|
|
2986 (last (calendar-last-day-of-month month year))
|
|
|
2987 (day (calendar-read
|
|
|
2988 (format "Day of death (1-%d): " last)
|
|
|
2989 '(lambda (x) (and (< 0 x) (<= x last))))))
|
|
|
2990 (list month day year))))
|
|
|
2991 (death-year (extract-calendar-year death-date))
|
|
|
2992 (start-year (calendar-read
|
|
|
2993 (format "Starting year of Yahrzeit table (>%d): "
|
|
|
2994 death-year)
|
|
|
2995 '(lambda (x) (> x death-year))
|
|
|
2996 (int-to-string (1+ death-year))))
|
|
|
2997 (end-year (calendar-read
|
|
|
2998 (format "Ending year of Yahrzeit table (>=%d): "
|
|
|
2999 start-year)
|
|
|
3000 '(lambda (x) (>= x start-year)))))
|
|
|
3001 (list death-date start-year end-year)))
|
|
|
3002 (message "Computing yahrzeits...")
|
|
|
3003 (let* ((yahrzeit-buffer "*Yahrzeits*")
|
|
|
3004 (h-date (calendar-hebrew-from-absolute
|
|
|
3005 (calendar-absolute-from-gregorian death-date)))
|
|
|
3006 (h-month (extract-calendar-month h-date))
|
|
|
3007 (h-day (extract-calendar-day h-date))
|
|
|
3008 (h-year (extract-calendar-year h-date)))
|
|
|
3009 (set-buffer (get-buffer-create yahrzeit-buffer))
|
|
|
3010 (setq buffer-read-only nil)
|
|
|
3011 (calendar-set-mode-line
|
|
|
3012 (format "Yahrzeit dates for %s = %s"
|
|
|
3013 (calendar-date-string death-date)
|
|
|
3014 (let ((calendar-month-name-array
|
|
|
3015 (if (hebrew-calendar-leap-year-p h-year)
|
|
|
3016 calendar-hebrew-month-name-array-leap-year
|
|
|
3017 calendar-hebrew-month-name-array-common-year)))
|
|
|
3018 (calendar-date-string h-date nil t))))
|
|
|
3019 (erase-buffer)
|
|
|
3020 (goto-char (point-min))
|
|
|
3021 (calendar-for-loop i from start-year to end-year do
|
|
|
3022 (insert
|
|
|
3023 (calendar-date-string
|
|
|
3024 (calendar-gregorian-from-absolute
|
|
|
3025 (hebrew-calendar-yahrzeit
|
|
|
3026 h-date
|
|
|
3027 (extract-calendar-year
|
|
|
3028 (calendar-hebrew-from-absolute
|
|
|
3029 (calendar-absolute-from-gregorian (list 1 1 i))))))) "\n"))
|
|
|
3030 (goto-char (point-min))
|
|
|
3031 (set-buffer-modified-p nil)
|
|
|
3032 (setq buffer-read-only t)
|
|
|
3033 (display-buffer yahrzeit-buffer)
|
|
|
3034 (message "Computing yahrzeits...done")))
|
|
|
3035
|
|
|
3036 (defun calendar-astro-date-string (&optional date)
|
|
|
3037 "String of astronomical (Julian) day number of afternoon of Gregorian DATE.
|
|
|
3038 Defaults to today's date if DATE is not given."
|
|
|
3039 (int-to-string
|
|
|
3040 (+ 1721425 (calendar-absolute-from-gregorian
|
|
|
3041 (or date (calendar-current-date))))))
|
|
|
3042
|
|
|
3043 (defun calendar-print-astro-day-number ()
|
|
|
3044 "Show astronomical (Julian) day number of afternoon on date shown by cursor."
|
|
|
3045 (interactive)
|
|
|
3046 (message
|
|
|
3047 "Astronomical (Julian) day number after noon UTC: %s"
|
|
|
3048 (calendar-astro-date-string (calendar-cursor-to-date t))))
|
|
|
3049
|
|
|
3050 (defun calendar-goto-astro-day-number (daynumber &optional noecho)
|
|
|
3051 "Move cursor to astronomical (Julian) DAYNUMBER.
|
|
|
3052 Echo astronomical (Julian) day number unless NOECHO is t."
|
|
|
3053 (interactive (list (calendar-read
|
|
|
3054 "Astronomical (Julian) day number (>1721425): "
|
|
|
3055 '(lambda (x) (> x 1721425)))))
|
|
|
3056 (calendar-goto-date (calendar-gregorian-from-absolute (- daynumber 1721425)))
|
|
|
3057 (or noecho (calendar-print-astro-day-number)))
|
|
|
3058
|
|
|
3059 (run-hooks 'calendar-load-hook)
|
|
|
3060
|
|
|
3061 (provide 'calendar)
|
|
|
3062
|
|
|
3063 ;;; calendar.el ends here
|
