* lisp/emacs-lisp/lisp.el (lisp-completion-at-point): Don't use
[emacs.git] / lisp / calendar / calendar.el
1 ;;; calendar.el --- calendar functions
2
3 ;; Copyright (C) 1988-1995, 1997, 2000-2014 Free Software Foundation, Inc.
4
5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
6 ;; Maintainer: Glenn Morris <rgm@gnu.org>
7 ;; Keywords: calendar
8 ;; Human-Keywords: calendar, Gregorian calendar, diary, holidays
9
10 ;; This file is part of GNU Emacs.
11
12 ;; GNU Emacs is free software: you can redistribute it and/or modify
13 ;; it under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation, either version 3 of the License, or
15 ;; (at your option) any later version.
16
17 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20 ;; GNU General Public License for more details.
21
22 ;; You should have received a copy of the GNU General Public License
23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
24
25 ;;; Commentary:
26
27 ;; This collection of functions implements a calendar window.  It
28 ;; generates a calendar for the current month, together with the
29 ;; previous and coming months, or for any other three-month period.
30 ;; The calendar can be scrolled forward and backward in the window to
31 ;; show months in the past or future; the cursor can move forward and
32 ;; backward by days, weeks, or months, making it possible, for
33 ;; instance, to jump to the date a specified number of days, weeks, or
34 ;; months from the date under the cursor.  The user can display a list
35 ;; of holidays and other notable days for the period shown; the
36 ;; notable days can be marked on the calendar, if desired.  The user
37 ;; can also specify that dates having corresponding diary entries (in
38 ;; a file that the user specifies) be marked; the diary entries for
39 ;; any date can be viewed in a separate window.  The diary and the
40 ;; notable days can be viewed independently of the calendar.  Dates
41 ;; can be translated from the (usual) Gregorian calendar to the day of
42 ;; the year/days remaining in year, to the ISO commercial calendar, to
43 ;; the Julian (old style) calendar, to the Hebrew calendar, to the
44 ;; Islamic calendar, to the Bahá'í calendar, to the French
45 ;; Revolutionary calendar, to the Mayan calendar, to the Chinese
46 ;; calendar, to the Coptic calendar, to the Ethiopic calendar, and to
47 ;; the astronomical (Julian) day number.  Times of sunrise/sunset can
48 ;; be displayed, as can the phases of the moon.  Appointment
49 ;; notification for diary entries is available.  Calendar printing via
50 ;; LaTeX is available.
51
52 ;; The following files are part of the calendar/diary code:
53
54 ;;    appt.el                    Appointment notification
55 ;;    cal-bahai.el               Bahá'í calendar
56 ;;    cal-china.el               Chinese calendar
57 ;;    cal-coptic.el              Coptic/Ethiopic calendars
58 ;;    cal-dst.el                 Daylight saving time rules
59 ;;    cal-french.el              French revolutionary calendar
60 ;;    cal-hebrew.el              Hebrew calendar
61 ;;    cal-html.el                Calendars in HTML
62 ;;    cal-islam.el               Islamic calendar
63 ;;    cal-iso.el                 ISO calendar
64 ;;    cal-julian.el              Julian/astronomical calendars
65 ;;    cal-mayan.el               Mayan calendars
66 ;;    cal-menu.el                Menu support
67 ;;    cal-move.el                Movement in the calendar
68 ;;    cal-persia.el              Persian calendar
69 ;;    cal-tex.el                 Calendars in LaTeX
70 ;;    cal-x.el                   Dedicated frame functions
71 ;;    calendar.el                This file
72 ;;    diary-lib.el               Diary functions
73 ;;    holidays.el                Holiday functions
74 ;;    lunar.el                   Phases of the moon
75 ;;    solar.el                   Sunrise/sunset, equinoxes/solstices
76
77 ;; Technical details of all the calendrical calculations can be found in
78 ;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold
79 ;; and Nachum Dershowitz, Cambridge University Press (2001).
80
81 ;; An earlier version of the technical details appeared in
82 ;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold,
83 ;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990),
84 ;; pages 899-928, and in ``Calendrical Calculations, Part II: Three Historical
85 ;; Calendars'' by E. M. Reingold,  N. Dershowitz, and S. M. Clamen,
86 ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
87 ;; pages 383-404.
88
89 ;; Hard copies of these two papers can be obtained by sending email to
90 ;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and
91 ;; the message BODY containing your mailing address (snail).
92
93
94 ;; A note on free variables:
95
96 ;; The calendar passes around a few dynamically bound variables, which
97 ;; unfortunately have rather common names.  They are meant to be
98 ;; available for external functions, so the names can't be changed.
99
100 ;; displayed-month, displayed-year: bound in calendar-generate, the
101 ;;   central month of the 3 month calendar window
102 ;; original-date, number: bound in diary-list-entries, the arguments
103 ;;   with which that function was called.
104 ;; date, entry: bound in diary-list-sexp-entries (qv)
105
106 ;; Bound in diary-list-entries:
107 ;; diary-entries-list: use in d-l, appt.el, and by diary-add-to-list
108 ;; diary-saved-point: only used in diary-lib.el, passed to the display func
109 ;; date-string: only used in diary-lib.el
110 ;; list-only: don't modify the diary-buffer, just return a list of entries
111 ;; file-glob-attrs: yuck
112
113 ;;; Code:
114
115 (load "cal-loaddefs" nil t)
116
117 ;; Avoid recursive load of calendar when loading cal-menu.  Yuck.
118 (provide 'calendar)
119 (require 'cal-menu)
120
121 (defgroup calendar nil
122   "Calendar and time management support."
123   :prefix "calendar-"
124   :group 'applications)
125
126 (defgroup calendar-hooks nil
127   "Calendar hooks."
128   :prefix "calendar-"
129   :group 'calendar)
130
131 (defgroup calendar-faces nil
132   "Calendar faces."
133   :prefix "calendar-"
134   :group 'calendar)
135
136 (defcustom calendar-offset 0
137   "The offset of the principal month from the center of the calendar window.
138 0 means the principal month is in the center (default), -1 means on the left,
139 +1 means on the right.  Larger (or smaller) values push the principal month off
140 the screen."
141   :type 'integer
142   :group 'calendar)
143
144 (defcustom calendar-setup nil
145   "The frame setup of the calendar.
146 The choices are: `one-frame' (calendar and diary together in one separate,
147 dedicated frame); `two-frames' (calendar and diary in separate, dedicated
148 frames); `calendar-only' (calendar in a separate, dedicated frame); with
149 any other value the current frame is used.  Using any of the first
150 three options overrides the value of `calendar-view-diary-initially-flag'."
151   :type '(choice
152           (const :tag "calendar and diary in separate frame" one-frame)
153           (const :tag "calendar and diary each in own frame" two-frames)
154           (const :tag "calendar in separate frame" calendar-only)
155           (const :tag "use current frame" nil))
156   :group 'calendar)
157
158 (defcustom calendar-minimum-window-height 8
159   "Minimum height `calendar-generate-window' should use for calendar window."
160   :type 'integer
161   :version "22.1"
162   :group 'calendar)
163
164 ;; See discussion in bug#1806.
165 (defcustom calendar-split-width-threshold nil
166   "Value to use for `split-width-threshold' when creating a calendar.
167 This only affects frames wider than the default value of
168 `split-width-threshold'."
169   :type '(choice (const nil)
170                  (integer))
171   :version "23.2"
172   :group 'calendar)
173
174 (defcustom calendar-week-start-day 0
175   "The day of the week on which a week in the calendar begins.
176 0 means Sunday (default), 1 means Monday, and so on.
177
178 If you change this variable directly (without using customize)
179 after starting `calendar', you should call `calendar-redraw' to
180 update the calendar display to reflect the change, otherwise
181 movement commands will not work correctly."
182   :type 'integer
183   ;; Change the initialize so that if you reload calendar.el, it will not
184   ;; cause a redraw (which may fail, e.g. with "invalid byte-code in
185   ;; calendar.elc" because of the "byte-compile-dynamic").
186   :initialize 'custom-initialize-default
187   :set (lambda (sym val)
188          (set sym val)
189          (calendar-redraw))
190   :group 'calendar)
191
192 (define-obsolete-variable-alias 'view-diary-entries-initially
193   'calendar-view-diary-initially-flag "23.1")
194
195 (defcustom calendar-view-diary-initially-flag nil
196   "Non-nil means display current date's diary entries on entry to calendar.
197 The diary is displayed in another window when the calendar is first displayed,
198 if the current date is visible.  The number of days of diary entries displayed
199 is governed by the variable `diary-number-of-entries'.  This variable can
200 be overridden by the value of `calendar-setup'."
201   :type 'boolean
202   :group 'diary)
203
204 (define-obsolete-variable-alias 'mark-diary-entries-in-calendar
205   'calendar-mark-diary-entries-flag "23.1")
206
207 ;; FIXME :set
208 (defcustom calendar-mark-diary-entries-flag nil
209   "Non-nil means mark dates with diary entries, in the calendar window.
210 The marking symbol is specified by the variable `diary-entry-marker'."
211   :type 'boolean
212   :group 'diary)
213
214 (defcustom calendar-remove-frame-by-deleting t
215   "Determine how the calendar mode removes a frame no longer needed.
216 If nil, make an icon of the frame.  If non-nil, delete the frame."
217   :type 'boolean
218   :version "23.1"                       ; changed from nil to t
219   :group 'view
220   :group 'calendar)
221
222 (defface calendar-today
223   '((t (:underline t)))
224   "Face for indicating today's date in the calendar.
225 See the variable `calendar-today-marker'."
226   :group 'calendar-faces)
227
228 (define-obsolete-face-alias 'calendar-today-face 'calendar-today "22.1")
229
230 (defface diary
231   '((((min-colors 88) (class color) (background light))
232      :foreground "red1")
233     (((class color) (background light))
234      :foreground "red")
235     (((min-colors 88) (class color) (background dark))
236      :foreground "yellow1")
237     (((class color) (background dark))
238      :foreground "yellow")
239     (t
240      :weight bold))
241   "Face for highlighting diary entries.
242 Used to mark diary entries in the calendar (see `diary-entry-marker'),
243 and to highlight the date header in the fancy diary."
244   :group 'calendar-faces)
245
246 (define-obsolete-face-alias 'diary-face 'diary "22.1")
247
248 (defface holiday
249   '((((class color) (background light))
250      :background "pink")
251     (((class color) (background dark))
252      :background "chocolate4")
253     (t
254      :inverse-video t))
255   "Face for indicating in the calendar dates that have holidays.
256 See `calendar-holiday-marker'."
257   :group 'calendar-faces)
258
259 (define-obsolete-face-alias 'holiday-face 'holiday "22.1")
260
261 (defface calendar-weekday-header '((t :inherit font-lock-constant-face))
262   "Face used for weekday column headers in the calendar.
263 See also the face `calendar-weekend-header'."
264   :version "24.4"
265   :group 'calendar-faces)
266
267 (defface calendar-weekend-header '((t :inherit font-lock-comment-face))
268   "Face used for weekend column headers in the calendar.
269 See also the face `calendar-weekday-header'."
270   :version "24.4"
271   :group 'calendar-faces)
272
273 (defface calendar-month-header '((t :inherit font-lock-function-name-face))
274   "Face used for month headers in the calendar."
275   :version "24.4"
276   :group 'calendar-faces)
277
278 ;; These briefly checked font-lock-mode, but that is broken, since it
279 ;; is a buffer-local variable, and which buffer happens to be current
280 ;; when this file is loaded shouldn't make a difference.  One could
281 ;; perhaps check global-font-lock-mode, or font-lock-global-modes; but
282 ;; this feature doesn't use font-lock, so there's no real reason it
283 ;; should respect those either.  See bug#2199.
284 ;; They also used to check display-color-p, but that is a problem if
285 ;; loaded from --daemon.  Since BW displays are rare now, this was
286 ;; also taken out.  The way to keep it would be to have nil mean do a
287 ;; runtime check whenever this variable is used.
288 (defcustom diary-entry-marker 'diary
289   "How to mark dates that have diary entries.
290 The value can be either a single-character string (e.g. \"+\") or a face."
291   :type '(choice (string :tag "Single character string") face)
292   :group 'diary
293   :version "23.1")
294
295 (defcustom calendar-today-marker 'calendar-today
296   "How to mark today's date in the calendar.
297 The value can be either a single-character string (e.g. \"=\") or a face.
298 Used by `calendar-mark-today'."
299   :type '(choice (string :tag "Single character string") face)
300   :group 'calendar
301   :version "23.1")
302
303 (defcustom calendar-holiday-marker 'holiday
304   "How to mark notable dates in the calendar.
305 The value can be either a single-character string (e.g. \"*\") or a face."
306   :type '(choice (string :tag "Single character string") face)
307   :group 'holidays
308   :version "23.1")
309
310 (define-obsolete-variable-alias 'view-calendar-holidays-initially
311   'calendar-view-holidays-initially-flag "23.1")
312
313 (defcustom calendar-view-holidays-initially-flag nil
314   "Non-nil means display holidays for current three month period on entry.
315 The holidays are displayed in another window when the calendar is first
316 displayed."
317   :type 'boolean
318   :group 'holidays)
319
320 (define-obsolete-variable-alias 'mark-holidays-in-calendar
321   'calendar-mark-holidays-flag "23.1")
322
323 ;; FIXME :set
324 (defcustom calendar-mark-holidays-flag nil
325   "Non-nil means mark dates of holidays in the calendar window.
326 The marking symbol is specified by the variable `calendar-holiday-marker'."
327   :type 'boolean
328   :group 'holidays)
329
330 (defcustom calendar-mode-hook nil
331   "Hook run when entering `calendar-mode'."
332   :type 'hook
333   :group 'calendar-hooks)
334
335 (defcustom calendar-load-hook nil
336   "List of functions to be called after the calendar is first loaded.
337 This is the place to add key bindings to `calendar-mode-map'."
338   :type 'hook
339   :group 'calendar-hooks)
340
341 (define-obsolete-variable-alias 'initial-calendar-window-hook
342   'calendar-initial-window-hook "23.1")
343
344 (defcustom calendar-initial-window-hook nil
345   "List of functions to be called when the calendar window is created.
346 Quitting the calendar and re-entering it will cause these functions
347 to be called again."
348   :type 'hook
349   :group 'calendar-hooks)
350
351 (define-obsolete-variable-alias 'today-visible-calendar-hook
352   'calendar-today-visible-hook "23.1")
353
354 (defcustom calendar-today-visible-hook nil
355   "List of functions called whenever the current date is visible.
356 To mark today's date, add the function `calendar-mark-today'.
357 To replace the date with asterisks, add the function `calendar-star-date'.
358 See also `calendar-today-invisible-hook'.
359
360 In general, be careful about changing characters in the calendar buffer,
361 since it may cause the movement commands to fail."
362   :type 'hook
363   :options '(calendar-mark-today calendar-star-date)
364   :group 'calendar-hooks)
365
366 (define-obsolete-variable-alias 'today-invisible-calendar-hook
367   'calendar-today-invisible-hook "23.1")
368
369 (defcustom calendar-today-invisible-hook nil
370   "List of functions called whenever the current date is not visible.
371 See also `calendar-today-visible-hook'."
372   :type 'hook
373   :group 'calendar-hooks)
374
375 (defcustom calendar-move-hook nil
376   "List of functions called whenever the cursor moves in the calendar.
377 For example,
378
379   (add-hook 'calendar-move-hook (lambda () (diary-view-entries 1)))
380
381 redisplays the diary for whatever date the cursor is moved to."
382   :type 'hook
383   :options '(calendar-update-mode-line)
384   :group 'calendar-hooks)
385
386 (defcustom calendar-date-echo-text
387   "mouse-2: general menu\nmouse-3: menu for this date"
388   "String displayed when the cursor is over a date in the calendar.
389 Can be either a fixed string, or a lisp expression that returns one.
390 When this expression is evaluated, DAY, MONTH, and YEAR are
391 integers appropriate to the relevant date.  For example, to
392 display the ISO date:
393
394   (setq calendar-date-echo-text '(format \"ISO date: %s\"
395                                          (calendar-iso-date-string
396                                           (list month day year))))
397 Changing this variable without using customize has no effect on
398 pre-existing calendar windows."
399   :group 'calendar
400   :initialize 'custom-initialize-default
401   :risky t
402   :set (lambda (sym val)
403          (set sym val)
404          (calendar-redraw))
405   :type '(choice (string :tag "Fixed string")
406                  (sexp :value
407                        (format "ISO date: %s"
408                                 (calendar-iso-date-string
409                                  (list month day year)))))
410   :version "23.1")
411
412
413 (defvar calendar-month-digit-width nil
414   "Width of the region with numbers in each month in the calendar.")
415
416 (defvar calendar-month-width nil
417   "Full width of each month in the calendar.")
418
419 (defvar calendar-right-margin nil
420   "Right margin of the calendar.")
421
422 (defvar calendar-month-edges nil
423   "Alist of month edge columns.
424 Each element has the form (N LEFT FIRST LAST RIGHT), where
425 LEFT is the leftmost column associated with month segment N,
426 FIRST and LAST are the first and last columns with day digits in,
427 and LAST is the rightmost column.")
428
429 (defun calendar-month-edges (segment)
430   "Compute the month edge columns for month SEGMENT.
431 Returns a list (LEFT FIRST LAST RIGHT), where LEFT is the
432 leftmost column associated with a month, FIRST and LAST are the
433 first and last columns with day digits in, and LAST is the
434 rightmost column."
435   ;; The leftmost column with a digit in it in this month segment.
436   (let* ((first (+ calendar-left-margin
437                         (* segment calendar-month-width)))
438          ;; The rightmost column with a digit in it in this month segment.
439          (last (+ first (1- calendar-month-digit-width)))
440          (left (if (eq segment 0)
441                    0
442                  (+ calendar-left-margin
443                     (* segment calendar-month-width)
444                     (- (/ calendar-intermonth-spacing 2)))))
445          ;; The rightmost edge of this month segment, dividing the
446          ;; space between months in two.
447          (right (+ calendar-left-margin
448                   (* (1+ segment) calendar-month-width)
449                   (- (/ calendar-intermonth-spacing 2)))))
450     (list left first last right)))
451
452 (defun calendar-recompute-layout-variables ()
453   "Recompute some layout-related calendar \"constants\"."
454   (setq calendar-month-digit-width (+ (* 6 calendar-column-width)
455                                       calendar-day-digit-width)
456         calendar-month-width (+ (* 7 calendar-column-width)
457                                 calendar-intermonth-spacing)
458         calendar-right-margin (+ calendar-left-margin
459                                    (* 3 (* 7 calendar-column-width))
460                                    (* 2 calendar-intermonth-spacing))
461         calendar-month-edges nil)
462   (dotimes (i 3)
463     (push (cons i (calendar-month-edges i)) calendar-month-edges))
464   (setq calendar-month-edges (reverse calendar-month-edges)))
465
466 (defun calendar-set-layout-variable (symbol value &optional minmax)
467   "Set SYMBOL's value to VALUE, an integer.
468 A positive/negative MINMAX enforces a minimum/maximum value.
469 Then redraw the calendar, if necessary."
470   (let ((oldvalue (symbol-value symbol)))
471     (custom-set-default symbol (if minmax
472                                    (if (< minmax 0)
473                                        (min value (- minmax))
474                                      (max value minmax))
475                                  value))
476     (unless (equal value oldvalue)
477       (calendar-recompute-layout-variables)
478       (calendar-redraw))))
479
480 (defcustom calendar-left-margin 5
481   "Empty space to the left of the first month in the calendar."
482   :group 'calendar
483   :initialize 'custom-initialize-default
484   :set 'calendar-set-layout-variable
485   :type 'integer
486   :version "23.1")
487
488 ;; Or you can view it as columns of width 2, with 1 space, no space
489 ;; after the last column, and a 5 space gap between month.
490 ;; FIXME check things work if this is odd.
491 (defcustom calendar-intermonth-spacing 4
492   "Space between months in the calendar.  Minimum value is 1."
493   :group 'calendar
494   :initialize 'custom-initialize-default
495   :set (lambda (sym val)
496          (calendar-set-layout-variable sym val 1))
497   :type 'integer
498   :version "23.1")
499
500 ;; FIXME calendar-month-column-width?
501 (defcustom calendar-column-width 3
502   "Width of each day column in the calendar.  Minimum value is 3."
503   :initialize 'custom-initialize-default
504   :set (lambda (sym val)
505          (calendar-set-layout-variable sym val 3))
506   :type 'integer
507   :version "23.1")
508
509 (defun calendar-day-header-construct (&optional width)
510   "Return the default value for `calendar-day-header-array'.
511 WIDTH defaults to `calendar-day-header-width'."
512   (or width (setq width calendar-day-header-width))
513   (calendar-abbrev-construct (if (<= width calendar-abbrev-length)
514                                  calendar-day-abbrev-array
515                                calendar-day-name-array)
516                              width))
517
518 ;; FIXME better to use a format spec?
519 (defcustom calendar-day-header-width 2
520   "Width of the day column headers in the calendar.
521 Must be at least one less than `calendar-column-width'."
522   :group 'calendar
523   :initialize 'custom-initialize-default
524   :set (lambda (sym val)
525          (or (calendar-customized-p 'calendar-day-header-array)
526              (setq calendar-day-header-array
527                    (calendar-day-header-construct val)))
528          (calendar-set-layout-variable sym val (- 1 calendar-column-width)))
529   :type 'integer
530   :version "23.1")
531
532 ;; FIXME a format specifier instead?
533 (defcustom calendar-day-digit-width 2
534   "Width of the day digits in the calendar.  Minimum value is 2."
535   :group 'calendar
536   :initialize 'custom-initialize-default
537   :set (lambda (sym val)
538          (calendar-set-layout-variable sym val 2))
539   :type 'integer
540   :version "23.1")
541
542 (defcustom calendar-intermonth-header nil
543   "Header text to display in the space to the left of each calendar month.
544 See `calendar-intermonth-text'."
545   :group 'calendar
546   :initialize 'custom-initialize-default
547   :risky t
548   :set (lambda (sym val)
549          (set sym val)
550          (calendar-redraw))
551   :type '(choice (const nil :tag "Nothing")
552                  (string :tag "Fixed string")
553                  (sexp :value
554                        (propertize "WK" 'font-lock-face
555                                    'font-lock-function-name-face)))
556   :version "23.1")
557
558 (defcustom calendar-intermonth-text nil
559   "Text to display in the space to the left of each calendar month.
560 Can be nil, a fixed string, or a lisp expression that returns a string.
561 When the expression is evaluated, the variables DAY, MONTH and YEAR
562 are integers appropriate for the first day in each week.
563 Will be truncated to the smaller of `calendar-left-margin' and
564 `calendar-intermonth-spacing'.  The last character is forced to be a space.
565 For example, to display the ISO week numbers:
566
567   (setq calendar-week-start-day 1
568         calendar-intermonth-text
569         '(propertize
570           (format \"%2d\"
571                   (car
572                    (calendar-iso-from-absolute
573                     (calendar-absolute-from-gregorian (list month day year)))))
574           'font-lock-face 'font-lock-function-name-face))
575
576 See also `calendar-intermonth-header'."
577   :group 'calendar
578   :initialize 'custom-initialize-default
579   :risky t
580   :set (lambda (sym val)
581          (set sym val)
582          (calendar-redraw))
583   :type '(choice (const nil :tag "Nothing")
584                  (string :tag "Fixed string")
585                  (sexp :value
586                        (propertize
587                         (format "%2d"
588                                 (car
589                                  (calendar-iso-from-absolute
590                                   (calendar-absolute-from-gregorian
591                                    (list month day year)))))
592                         'font-lock-face 'font-lock-function-name-face)))
593   :version "23.1")
594
595 (defcustom diary-file "~/diary"
596   "Name of the file in which one's personal diary of dates is kept.
597
598 The file's entries are lines beginning with any of the forms
599 specified by the variable `diary-date-forms', which by default
600 uses the forms of `diary-american-date-forms':
601
602             MONTH/DAY
603             MONTH/DAY/YEAR
604             MONTHNAME DAY
605             MONTHNAME DAY, YEAR
606             DAYNAME
607
608 with the remainder of the line being the diary entry string for
609 that date.  MONTH and DAY are one or two digit numbers, YEAR is a
610 number and may be written in full or abbreviated to the final two
611 digits (if `diary-abbreviated-year-flag' is non-nil).  MONTHNAME
612 and DAYNAME can be spelled in full (as specified by the variables
613 `calendar-month-name-array' and `calendar-day-name-array'), or
614 abbreviated (as specified by `calendar-month-abbrev-array' and
615 `calendar-day-abbrev-array') with or without a period.  Case is
616 ignored.  Any of DAY, MONTH, or MONTHNAME, YEAR can be `*' which
617 matches any day, month, or year, respectively.  If the date does
618 not contain a year, it is generic and applies to any year.  A
619 DAYNAME entry applies to the appropriate day of the week in every week.
620
621 You can customize `diary-date-forms' to your preferred format.
622 Three default styles are provided: `diary-american-date-forms',
623 `diary-european-date-forms', and `diary-iso-date-forms'.
624 You can choose between these by setting `calendar-date-style' in your
625 init file, or by using `calendar-set-date-style' when in the calendar.
626
627 A diary entry can be preceded by the character `diary-nonmarking-symbol'
628 \(ordinarily `&') to make that entry nonmarking--that is, it will not be
629 marked on dates in the calendar window but will appear in a diary window.
630
631 Multiline diary entries are made by indenting lines after the first with
632 either a TAB or one or more spaces.
633
634 Lines not in one the above formats are ignored.  Here are some sample diary
635 entries (in the default American style):
636
637      12/22/1988 Twentieth wedding anniversary!!
638      &1/1. Happy New Year!
639      10/22 Ruth's birthday.
640      21: Payday
641      Tuesday--weekly meeting with grad students at 10am
642               Supowit, Shen, Bitner, and Kapoor to attend.
643      1/13/89 Friday the thirteenth!!
644      &thu 4pm squash game with Lloyd.
645      mar 16 Dad's birthday
646      April 15, 1989 Income tax due.
647      &* 15 time cards due.
648
649 If the first line of a diary entry consists only of the date or day name with
650 no trailing blanks or punctuation, then that line is not displayed in the
651 diary window; only the continuation lines is shown.  For example, the
652 single diary entry
653
654      02/11/1989
655       Bill Blattner visits Princeton today
656       2pm Cognitive Studies Committee meeting
657       2:30-5:30 Lizzie at Lawrenceville for `Group Initiative'
658       4:00pm Jamie Tappenden
659       7:30pm Dinner at George and Ed's for Alan Ryan
660       7:30-10:00pm dance at Stewart Country Day School
661
662 will appear in the diary window without the date line at the beginning.  This
663 facility allows the diary window to look neater, but can cause confusion if
664 used with more than one day's entries displayed.
665
666 Diary entries can be based on Lisp sexps.  For example, the diary entry
667
668       %%(diary-block 11 1 1990 11 10 1990) Vacation
669
670 causes the diary entry \"Vacation\" to appear from November 1 through
671 November 10, 1990.  See the documentation for the function
672 `diary-list-sexp-entries' for more details.
673
674 Diary entries based on the Hebrew, the Islamic and/or the Bahá'í
675 calendar are also possible, but because these are somewhat slow, they
676 are ignored unless you set the `diary-nongregorian-listing-hook' and
677 the `diary-nongregorian-marking-hook' appropriately.  See the
678 documentation of these hooks for details.
679
680 Diary files can contain directives to include the contents of other files; for
681 details, see the documentation for the variable `diary-list-entries-hook'."
682   :type 'file
683   :group 'diary)
684
685 ;; FIXME do these have to be single characters?
686 (defcustom diary-nonmarking-symbol "&"
687   "Symbol indicating that a diary entry is not to be marked in the calendar."
688   :type 'string
689   :group 'diary)
690
691 (defcustom diary-chinese-entry-symbol "C"
692   "Symbol indicating a diary entry according to the Chinese calendar."
693   :type 'string
694   :group 'diary
695   :version "24.5")
696
697 (define-obsolete-variable-alias 'hebrew-diary-entry-symbol
698   'diary-hebrew-entry-symbol "23.1")
699
700 (defcustom diary-hebrew-entry-symbol "H"
701   "Symbol indicating a diary entry according to the Hebrew calendar."
702   :type 'string
703   :group 'diary)
704
705 (define-obsolete-variable-alias 'islamic-diary-entry-symbol
706   'diary-islamic-entry-symbol "23.1")
707
708 (defcustom diary-islamic-entry-symbol "I"
709   "Symbol indicating a diary entry according to the Islamic calendar."
710   :type 'string
711   :group 'diary)
712
713 (define-obsolete-variable-alias 'bahai-diary-entry-symbol
714   'diary-bahai-entry-symbol "23.1")
715
716 (defcustom diary-bahai-entry-symbol "B"
717   "Symbol indicating a diary entry according to the Bahá'í calendar."
718   :type 'string
719   :group 'diary)
720
721 (defcustom european-calendar-style nil
722   "Non-nil means use the European style of dates in the diary and display.
723 In this case, a date like 1/2/1990 would be interpreted as
724 February 1, 1990.  See `diary-european-date-forms' for the
725 default European diary date styles.
726
727 Setting this variable directly does not take effect (if the
728 calendar package is already loaded).  Rather, use either
729 \\[customize] or the function `calendar-set-date-style'."
730   :type 'boolean
731   ;; Without :initialize (require 'calendar) throws an error because
732   ;; calendar-set-date-style is undefined at this point.
733   :initialize 'custom-initialize-default
734   :set (lambda (symbol value)
735          (if value
736              (calendar-set-date-style 'european)
737            (calendar-set-date-style 'american)))
738   :group 'calendar)
739
740 (make-obsolete-variable 'european-calendar-style 'calendar-date-style "23.1")
741
742 ;; If this is autoloaded, c-d-s gets set before any customization of e-c-s.
743 (defcustom calendar-date-style (if european-calendar-style 'european
744                                  'american)
745   "Your preferred style for writing dates.
746 The options are:
747 `american' - month/day/year
748 `european' - day/month/year
749 `iso'      - year/month/day
750 This affects how dates written in your diary are interpreted.
751 It also affects date display, as well as those calendar and diary
752 functions that take a date as an argument, e.g. `diary-date', by
753 changing the order in which the arguments are interpreted.
754
755 Setting this variable directly does not take effect (if the
756 calendar package is already loaded).  Rather, use either
757 \\[customize] or the function `calendar-set-date-style'."
758   :version "23.1"
759   :type '(choice (const american :tag "Month/Day/Year")
760                  (const european :tag "Day/Month/Year")
761                  (const iso      :tag "Year/Month/Day"))
762   :initialize 'custom-initialize-default
763   :set (lambda (symbol value)
764          (calendar-set-date-style value))
765   :group 'calendar)
766
767 ;; Next three are provided to aid in setting diary-date-forms.
768 ;; FIXME move to diary-lib?
769 (defcustom diary-iso-date-forms
770   '((month "[-/]" day "[^-/0-9]")
771     (year "[-/]" month "[-/]" day "[^0-9]")
772     ;; Cannot allow [-/] as separators here, since it would also match
773     ;; the first element (bug#7377).
774     (monthname " *" day "[^-0-9]")
775     (year " *" monthname " *" day "[^0-9]")
776     (dayname "\\W"))
777     "List of pseudo-patterns describing the ISO style of dates.
778 The defaults are: MONTH[-/]DAY; YEAR[-/]MONTH[-/]DAY; MONTHNAME DAY;
779 YEAR MONTHNAME DAY; DAYNAME.  Normally you should not customize this,
780 but `diary-date-forms' (which see)."
781     :version "23.3"                     ; bug#7377
782     :type '(repeat (choice (cons :tag "Backup"
783                                :value (backup . nil)
784                                (const backup)
785                                (repeat (list :inline t :format "%v"
786                                              (symbol :tag "Keyword")
787                                              (choice symbol regexp))))
788                          (repeat (list :inline t :format "%v"
789                                        (symbol :tag "Keyword")
790                                        (choice symbol regexp)))))
791     :group 'diary)
792
793 (define-obsolete-variable-alias 'american-date-diary-pattern
794   'diary-american-date-forms "23.1")
795
796 (defcustom diary-american-date-forms
797   '((month "/" day "[^/0-9]")
798     (month "/" day "/" year "[^0-9]")
799     (monthname " *" day "[^,0-9]")
800     (monthname " *" day ", *" year "[^0-9]")
801     (dayname "\\W"))
802   "List of pseudo-patterns describing the American style of dates.
803 The defaults are: MONTH/DAY; MONTH/DAY/YEAR; MONTHNAME DAY;
804 MONTHNAME DAY, YEAR; DAYNAME.  Normally you should not customize this,
805 but `diary-date-forms' (which see)."
806   :type '(repeat (choice (cons :tag "Backup"
807                                :value (backup . nil)
808                                (const backup)
809                                (repeat (list :inline t :format "%v"
810                                              (symbol :tag "Keyword")
811                                              (choice symbol regexp))))
812                          (repeat (list :inline t :format "%v"
813                                        (symbol :tag "Keyword")
814                                        (choice symbol regexp)))))
815   :group 'diary)
816
817 (define-obsolete-variable-alias 'european-date-diary-pattern
818   'diary-european-date-forms "23.1")
819
820 (defcustom diary-european-date-forms
821   '((day "/" month "[^/0-9]")
822     (day "/" month "/" year "[^0-9]")
823     (backup day " *" monthname "\\W+\\<\\([^*0-9]\\|\\([0-9]+[:aApP]\\)\\)")
824     (day " *" monthname " *" year "[^0-9]")
825     (dayname "\\W"))
826   "List of pseudo-patterns describing the European style of dates.
827 The defaults are: DAY/MONTH; DAY/MONTH/YEAR; DAY MONTHNAME;
828 DAY MONTHNAME YEAR; DAYNAME.  Normally you should not customize this, but
829 `diary-date-forms' (which see)."
830   :type '(repeat (choice (cons :tag "Backup"
831                                :value (backup . nil)
832                                (const backup)
833                                (repeat (list :inline t :format "%v"
834                                              (symbol :tag "Keyword")
835                                              (choice symbol regexp))))
836                          (repeat (list :inline t :format "%v"
837                                        (symbol :tag "Keyword")
838                                        (choice symbol regexp)))))
839   :group 'diary)
840
841 (defvar diary-font-lock-keywords)
842
843 (defcustom diary-date-forms (cond ((eq calendar-date-style 'iso)
844                                    diary-iso-date-forms)
845                                   ((eq calendar-date-style 'european)
846                                    diary-european-date-forms)
847                                   (t diary-american-date-forms))
848   "List of pseudo-patterns describing the forms of date used in the diary.
849 The patterns on the list must be MUTUALLY EXCLUSIVE and should not match
850 any portion of the diary entry itself, just the date component.
851
852 A pseudo-pattern is a list of regular expressions and the keywords `month',
853 `day', `year', `monthname', and `dayname'.  The keyword `monthname' will
854 match the name of the month (see `calendar-month-name-array'), capitalized
855 or not, or its user-specified abbreviation (see `calendar-month-abbrev-array'),
856 followed by a period or not; it will also match `*'.  Similarly, `dayname'
857 will match the name of the day (see `calendar-day-name-array'), capitalized or
858 not, or its user-specified abbreviation (see `calendar-day-abbrev-array'),
859 followed by a period or not.  The keywords `month', `day', and `year' will
860 match those numerical values, preceded by arbitrarily many zeros; they will
861 also match `*'.
862
863 The matching of the diary entries with the date forms is done with the
864 standard syntax table from Fundamental mode, but with the `*' changed so
865 that it is a word constituent.
866
867 If, to be mutually exclusive, a pseudo-pattern must match a portion of the
868 diary entry itself, the first element of the pattern MUST be `backup'.  This
869 directive causes the date recognizer to back up to the beginning of the
870 current word of the diary entry, so in no case can the pattern match more than
871 a portion of the first word of the diary entry.
872
873 For examples of three common styles, see `diary-american-date-forms',
874 `diary-european-date-forms', and `diary-iso-date-forms'."
875   :type '(repeat (choice (cons :tag "Backup"
876                                :value (backup . nil)
877                                (const backup)
878                                (repeat (list :inline t :format "%v"
879                                              (symbol :tag "Keyword")
880                                              (choice symbol regexp))))
881                          (repeat (list :inline t :format "%v"
882                                        (symbol :tag "Keyword")
883                                        (choice symbol regexp)))))
884   :set-after '(calendar-date-style diary-iso-date-forms
885                                    diary-european-date-forms
886                                    diary-american-date-forms)
887   :initialize 'custom-initialize-default
888   :set (lambda (symbol value)
889          (unless (equal value (eval symbol))
890            (custom-set-default symbol value)
891            (setq diary-font-lock-keywords (diary-font-lock-keywords))
892            ;; Need to redraw not just to get new font-locking, but also
893            ;; to pick up any newly recognized entries.
894            (and (diary-live-p)
895                 (diary))))
896   :group 'diary)
897
898 ;; Next three are provided to aid in setting calendar-date-display-form.
899 (defcustom calendar-iso-date-display-form '((format "%s-%.2d-%.2d" year
900                                                (string-to-number month)
901                                                (string-to-number day)))
902   "Pseudo-pattern governing the way a date appears in the ISO style.
903 Normally you should not customize this, but `calendar-date-display-form'
904 \(which see)."
905   :type 'sexp
906   :version "23.1"
907   :group 'calendar)
908
909 (define-obsolete-variable-alias 'european-calendar-display-form
910   'calendar-european-date-display-form "23.1")
911
912 (defcustom calendar-european-date-display-form
913   '((if dayname (concat dayname ", ")) day " " monthname " " year)
914   "Pseudo-pattern governing the way a date appears in the European style.
915 Normally you should not customize this, but `calendar-date-display-form'
916 \(which see)."
917   :type 'sexp
918   :group 'calendar)
919
920 (define-obsolete-variable-alias 'american-calendar-display-form
921   'calendar-american-date-display-form "23.1")
922
923 (defcustom calendar-american-date-display-form
924   '((if dayname (concat dayname ", ")) monthname " " day ", " year)
925   "Pseudo-pattern governing the way a date appears in the American style.
926 Normally you should not customize this, but `calendar-date-display-form'
927 \(which see)."
928   :type 'sexp
929   :group 'calendar)
930
931 (defcustom calendar-date-display-form
932   (cond ((eq calendar-date-style 'iso)
933          calendar-iso-date-display-form)
934         ((eq calendar-date-style 'european)
935          calendar-european-date-display-form)
936         (t calendar-american-date-display-form))
937   "Pseudo-pattern governing the way a calendar date appears.
938 Used by the function `calendar-date-string' (which see), a pseudo-pattern
939 is a list of expressions that can involve the keywords `month', `day',
940 and `year' (all numbers in string form), and `monthname' and `dayname'
941 \(both alphabetic strings).  For example, a typical American form would be
942
943        '(month \"/\" day \"/\" (substring year -2))
944
945 whereas
946
947        '((format \"%9s, %9s %2s, %4s\" dayname monthname day year))
948
949 would give the usual American style in fixed-length fields.  The variables
950 `calendar-iso-date-display-form', `calendar-european-date-display-form', and
951 `calendar-american-date-display-form' provide some defaults for three common
952 styles."
953   :type 'sexp
954   :set-after '(calendar-date-style calendar-iso-date-display-form
955                                    calendar-european-date-display-form
956                                    calendar-american-date-display-form)
957   :group 'calendar)
958
959 (defcustom calendar-american-month-header
960   '(propertize (format "%s %d" (calendar-month-name month) year)
961                'font-lock-face 'calendar-month-header)
962   "Default format for calendar month headings with the American date style.
963 Normally you should not customize this, but `calender-month-header'."
964   :group 'calendar
965   :risky t
966   :type 'sexp
967   :version "24.4") ; font-lock-function-name-face -> calendar-month-header
968
969 (defcustom calendar-european-month-header
970   '(propertize (format "%s %d" (calendar-month-name month) year)
971                'font-lock-face 'calendar-month-header)
972   "Default format for calendar month headings with the European date style.
973 Normally you should not customize this, but `calender-month-header'."
974   :group 'calendar
975   :risky t
976   :type 'sexp
977   :version "24.4") ; font-lock-function-name-face -> calendar-month-header
978
979 (defcustom calendar-iso-month-header
980   '(propertize (format "%d %s" year (calendar-month-name month))
981                'font-lock-face 'calendar-month-header)
982   "Default format for calendar month headings with the ISO date style.
983 Normally you should not customize this, but `calender-month-header'."
984   :group 'calendar
985   :risky t
986   :type 'sexp
987   :version "24.4") ; font-lock-function-name-face -> calendar-month-header
988
989 (defcustom calendar-month-header
990   (cond ((eq calendar-date-style 'iso)
991          calendar-iso-month-header)
992         ((eq calendar-date-style 'european)
993          calendar-european-month-header)
994         (t calendar-american-month-header))
995   "Expression to evaluate to return the calendar month headings.
996 When this expression is evaluated, the variables MONTH and YEAR are
997 integers appropriate to the relevant month.  The result is padded
998 to the width of `calendar-month-digit-width'.
999
1000 For examples of three common styles, see `calendar-american-month-header',
1001 `calendar-european-month-header', and `calendar-iso-month-header'.
1002
1003 Changing this variable without using customize has no effect on
1004 pre-existing calendar windows."
1005   :group 'calendar
1006   :initialize 'custom-initialize-default
1007   :risky t
1008   :set (lambda (sym val)
1009          (set sym val)
1010          (calendar-redraw))
1011   :set-after '(calendar-date-style calendar-american-month-header
1012                                    calendar-european-month-header
1013                                    calendar-iso-month-header)
1014   :type 'sexp
1015   :version "24.3")
1016
1017 (defun calendar-set-date-style (style)
1018   "Set the style of calendar and diary dates to STYLE (a symbol).
1019 The valid styles are described in the documentation of `calendar-date-style'."
1020   (interactive (list (intern
1021                       (completing-read "Date style: "
1022                                        '("american" "european" "iso") nil t
1023                                        nil nil "american"))))
1024   (or (memq style '(american european iso))
1025       (setq style 'american))
1026   (setq calendar-date-style style
1027         calendar-date-display-form
1028         (symbol-value (intern-soft
1029                        (format "calendar-%s-date-display-form" style)))
1030         calendar-month-header
1031         (symbol-value (intern-soft (format "calendar-%s-month-header" style)))
1032         diary-date-forms
1033         (symbol-value (intern-soft (format "diary-%s-date-forms" style))))
1034   (calendar-redraw)
1035   (calendar-update-mode-line))
1036
1037 (defun european-calendar ()
1038   "Set the interpretation and display of dates to the European style."
1039   (declare (obsolete calendar-set-date-style "23.1"))
1040   (interactive)
1041   (calendar-set-date-style 'european))
1042
1043 (defun american-calendar ()
1044   "Set the interpretation and display of dates to the American style."
1045   (declare (obsolete calendar-set-date-style "23.1"))
1046   (interactive)
1047   (calendar-set-date-style 'american))
1048
1049 (define-obsolete-variable-alias 'holidays-in-diary-buffer
1050   'diary-show-holidays-flag "23.1")
1051
1052 (defcustom diary-show-holidays-flag t
1053   "Non-nil means include holidays in the diary display.
1054 The holidays appear in the mode line of the diary buffer, or in the
1055 fancy diary buffer next to the date.  This slows down the diary functions
1056 somewhat; setting it to nil makes the diary display faster."
1057   :type 'boolean
1058   :group 'holidays)
1059
1060 (defcustom calendar-debug-sexp nil
1061   "Turn debugging on when evaluating a sexp in the diary or holiday list."
1062   :type 'boolean
1063   :group 'calendar)
1064
1065 (define-obsolete-variable-alias 'all-hebrew-calendar-holidays
1066   'calendar-hebrew-all-holidays-flag "23.1")
1067
1068 (defcustom calendar-hebrew-all-holidays-flag nil
1069   "If nil, show only major holidays from the Hebrew calendar.
1070 This means only those Jewish holidays that appear on secular calendars.
1071 Otherwise, show all the holidays that would appear in a complete Hebrew
1072 calendar."
1073   :type 'boolean
1074   :group 'holidays)
1075
1076 (define-obsolete-variable-alias 'all-christian-calendar-holidays
1077   'calendar-christian-all-holidays-flag "23.1")
1078
1079 (defcustom calendar-christian-all-holidays-flag nil
1080   "If nil, show only major holidays from the Christian calendar.
1081 This means only those Christian holidays that appear on secular calendars.
1082 Otherwise, show all the holidays that would appear in a complete Christian
1083 calendar."
1084   :type 'boolean
1085   :group 'holidays)
1086
1087 (define-obsolete-variable-alias 'all-islamic-calendar-holidays
1088   'calendar-islamic-all-holidays-flag "23.1")
1089
1090 (defcustom calendar-islamic-all-holidays-flag nil
1091   "If nil, show only major holidays from the Islamic calendar.
1092 This means only those Islamic holidays that appear on secular calendars.
1093 Otherwise, show all the holidays that would appear in a complete Islamic
1094 calendar."
1095   :type 'boolean
1096   :group 'holidays)
1097
1098 (define-obsolete-variable-alias 'all-bahai-calendar-holidays
1099   'calendar-bahai-all-holidays-flag "23.1")
1100
1101 (defcustom calendar-bahai-all-holidays-flag nil
1102   "If nil, show only major holidays from the Bahá'í calendar.
1103 These are the days on which work and school must be suspended.
1104 Otherwise, show all the holidays that would appear in a complete Bahá'í
1105 calendar."
1106   :type 'boolean
1107   :group 'holidays)
1108
1109 (defcustom calendar-chinese-all-holidays-flag nil
1110   "If nil, show only the major holidays from the Chinese calendar."
1111   :version "23.1"
1112   :type 'boolean
1113   :group 'holidays)
1114
1115 ;;; End of user options.
1116
1117 (calendar-recompute-layout-variables)
1118
1119 (defconst calendar-first-date-row 3
1120   "First row in the calendar with actual dates.")
1121
1122 (defconst calendar-buffer "*Calendar*"
1123   "Name of the buffer used for the calendar.")
1124
1125 (defconst holiday-buffer "*Holidays*"
1126   "Name of the buffer used for the displaying the holidays.")
1127
1128 (defconst diary-fancy-buffer "*Fancy Diary Entries*"
1129   "Name of the buffer used for the optional fancy display of the diary.")
1130
1131 (define-obsolete-variable-alias 'fancy-diary-buffer 'diary-fancy-buffer "23.1")
1132
1133 (defconst calendar-other-calendars-buffer "*Other Calendars*"
1134   "Name of the buffer used for the display of date on other calendars.")
1135
1136 (defconst lunar-phases-buffer "*Phases of Moon*"
1137   "Name of the buffer used for the lunar phases.")
1138
1139 (defconst solar-sunrises-buffer "*Sunrise/Sunset Times*"
1140   "Name of buffer used for sunrise/sunset times.")
1141
1142 (defconst calendar-hebrew-yahrzeit-buffer "*Yahrzeits*"
1143   "Name of the buffer used by `list-yahrzeit-dates'.")
1144
1145 (defmacro calendar-increment-month (mon yr n &optional nmonths)
1146   "Increment the variables MON and YR by N months.
1147 Forward if N is positive or backward if N is negative.
1148 A negative YR is interpreted as BC; -1 being 1 BC, and so on.
1149 Optional NMONTHS is the number of months per year (default 12)."
1150   ;; Can view this as a form of base-nmonths arithmetic, in which "a
1151   ;; year" = "ten", and we never bother to use hundreds.
1152   `(let ((nmonths (or ,nmonths 12))
1153          macro-y)
1154      (if (< ,yr 0) (setq ,yr (1+ ,yr))) ; -1 BC -> 0 AD, etc
1155      (setq macro-y (+ (* ,yr nmonths) ,mon -1 ,n)
1156            ,mon (1+ (mod macro-y nmonths))
1157            ,yr (/ macro-y nmonths))
1158      ;; Alternative:
1159 ;;;      (setq macro-y (+ (* ,yr nmonths) ,mon -1 ,n)
1160 ;;;            ,yr (/ macro-y nmonths)
1161 ;;;            ,mon (- macro-y (* ,yr nmonths)))
1162      (and (< macro-y 0) (> ,mon 1) (setq ,yr (1- ,yr)))
1163      (if (< ,yr 1) (setq ,yr (1- ,yr))))) ; 0 AD -> -1 BC, etc
1164
1165 (define-obsolete-function-alias 'increment-calendar-month
1166   'calendar-increment-month "23.1")
1167
1168 (defvar displayed-month)
1169 (defvar displayed-year)
1170
1171 (defun calendar-increment-month-cons (n &optional mon yr)
1172   "Return the Nth month after MON/YR.
1173 The return value is a pair (MONTH . YEAR).
1174 MON defaults to `displayed-month'.  YR defaults to `displayed-year'."
1175   (unless mon (setq mon displayed-month))
1176   (unless yr (setq yr displayed-year))
1177   (calendar-increment-month mon yr n)
1178   (cons mon yr))
1179
1180 (defmacro calendar-for-loop (var from init to final do &rest body)
1181   "Execute a for loop.
1182 Evaluate BODY with VAR bound to successive integers from INIT to FINAL,
1183 inclusive.  The standard macro `dotimes' is preferable in most cases."
1184   (declare (obsolete "use `dotimes' or `while' instead." "23.1")
1185            (debug (symbolp "from" form "to" form "do" body))
1186            (indent defun))
1187   `(let ((,var (1- ,init)))
1188     (while (>= ,final (setq ,var (1+ ,var)))
1189       ,@body)))
1190
1191 (defmacro calendar-sum (index initial condition expression)
1192   "For INDEX = INITIAL, +1, ... (as long as CONDITION holds), sum EXPRESSION."
1193   (declare (debug (symbolp form form form)))
1194   `(let ((,index ,initial)
1195          (sum 0))
1196     (while ,condition
1197       (setq sum (+ sum ,expression)
1198             ,index (1+ ,index)))
1199     sum))
1200
1201 (defmacro calendar-in-read-only-buffer (buffer &rest body)
1202   "Switch to BUFFER and execute the forms in BODY.
1203 First creates or erases BUFFER as needed.  Leaves BUFFER read-only,
1204 with disabled undo.  Leaves point at point-min, displays BUFFER."
1205   (declare (indent 1) (debug t))
1206   `(progn
1207      (set-buffer (get-buffer-create ,buffer))
1208      (or (derived-mode-p 'special-mode) (special-mode))
1209      (setq buffer-read-only nil
1210            buffer-undo-list t)
1211      (erase-buffer)
1212      ,@body
1213      (goto-char (point-min))
1214      (set-buffer-modified-p nil)
1215      (setq buffer-read-only t)
1216      (display-buffer ,buffer)))
1217
1218 ;; The following are in-line for speed; they can be called thousands of times
1219 ;; when looking up holidays or processing the diary.  Here, for example, are
1220 ;; the numbers of calls to calendar/diary/holiday functions in preparing the
1221 ;; fancy diary display, for a moderately complex diary file, with functions
1222 ;; used instead of macros.  There were a total of 10000 such calls:
1223 ;;
1224 ;;  1934   calendar-extract-month
1225 ;;  1852   calendar-extract-year
1226 ;;  1819   calendar-extract-day
1227 ;;   845   calendar-leap-year-p
1228 ;;   837   calendar-day-number
1229 ;;   775   calendar-absolute-from-gregorian
1230 ;;   346   calendar-last-day-of-month
1231 ;;   286   calendar-hebrew-last-day-of-month
1232 ;;   188   calendar-hebrew-leap-year-p
1233 ;;   180   calendar-hebrew-elapsed-days
1234 ;;   163   calendar-hebrew-last-month-of-year
1235 ;;    66   calendar-date-compare
1236 ;;    65   calendar-hebrew-days-in-year
1237 ;;    60   calendar-julian-to-absolute
1238 ;;    50   calendar-hebrew-to-absolute
1239 ;;    43   calendar-date-equal
1240 ;;    38   calendar-gregorian-from-absolute
1241 ;;     .
1242 ;;
1243 ;; The use of these seven macros eliminates the overhead of 92% of the function
1244 ;; calls; it's faster this way.
1245
1246 (defsubst calendar-extract-month (date)
1247   "Extract the month part of DATE which has the form (month day year)."
1248   (car date))
1249
1250 (define-obsolete-function-alias 'extract-calendar-month
1251   'calendar-extract-month "23.1")
1252
1253 ;; Note gives wrong answer for result of (calendar-read-date 'noday),
1254 ;; but that is only used by `calendar-other-month'.
1255 (defsubst calendar-extract-day (date)
1256   "Extract the day part of DATE which has the form (month day year)."
1257   (cadr date))
1258
1259 (define-obsolete-function-alias 'extract-calendar-day
1260   'calendar-extract-day "23.1")
1261
1262 (defsubst calendar-extract-year (date)
1263   "Extract the year part of DATE which has the form (month day year)."
1264   (nth 2 date))
1265
1266 (define-obsolete-function-alias 'extract-calendar-year
1267   'calendar-extract-year "23.1")
1268
1269 (defsubst calendar-leap-year-p (year)
1270   "Return t if YEAR is a Gregorian leap year.
1271 A negative year is interpreted as BC; -1 being 1 BC, and so on."
1272   ;; 1 BC = 0 AD, 2 BC acts like 1 AD, etc.
1273   (if (< year 0) (setq year (1- (abs year))))
1274   (and (zerop (% year 4))
1275        (or (not (zerop (% year 100)))
1276            (zerop (% year 400)))))
1277
1278 ;; The foregoing is a bit faster, but not as clear as the following:
1279 ;;
1280 ;;(defsubst calendar-leap-year-p (year)
1281 ;;  "Return t if YEAR is a Gregorian leap year."
1282 ;;  (or
1283 ;;   (and (zerop (% year 4))
1284 ;;        (not (zerop (% year 100))))
1285 ;;   (zerop (% year 400)))
1286
1287 (defsubst calendar-last-day-of-month (month year)
1288   "The last day in MONTH during YEAR."
1289   (if (and (= month 2) (calendar-leap-year-p year))
1290       29
1291     (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month))))
1292
1293 ;; An explanation of the calculation can be found in PascAlgorithms by
1294 ;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988.
1295
1296 (defsubst calendar-day-number (date)
1297   "Return the day number within the year of the date DATE.
1298 For example, (calendar-day-number '(1 1 1987)) returns the value 1,
1299 while (calendar-day-number '(12 31 1980)) returns 366."
1300   (let* ((month (calendar-extract-month date))
1301          (day (calendar-extract-day date))
1302          (year (calendar-extract-year date))
1303          (day-of-year (+ day (* 31 (1- month)))))
1304     (when (> month 2)
1305       (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10)))
1306       (if (calendar-leap-year-p year)
1307           (setq day-of-year (1+ day-of-year))))
1308     day-of-year))
1309
1310 (defsubst calendar-absolute-from-gregorian (date)
1311   "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
1312 The Gregorian date Sunday, December 31, 1 BC is imaginary.
1313 DATE is a list of the form (month day year).  A negative year is
1314 interpreted as BC; -1 being 1 BC, and so on.  Dates before 12/31/1 BC
1315 return negative results."
1316   (let ((year (calendar-extract-year date))
1317         offset-years)
1318     (cond ((zerop year)
1319            (error "There was no year zero"))
1320           ((> year 0)
1321            (setq offset-years (1- year))
1322            (+ (calendar-day-number date) ; days this year
1323               (* 365 offset-years)       ; + days in prior years
1324               (/ offset-years 4)         ; + Julian leap years
1325               (- (/ offset-years 100))   ; - century years
1326               (/ offset-years 400)))     ; + Gregorian leap years
1327           (t
1328            ;; Years between date and 1 BC, excluding 1 BC (1 for 2 BC, etc).
1329            (setq offset-years (abs (1+ year)))
1330            (- (calendar-day-number date)
1331               (* 365 offset-years)
1332               (/ offset-years 4)
1333               (- (/ offset-years 100))
1334               (/ offset-years 400)
1335               (calendar-day-number '(12 31 -1))))))) ; days in year 1 BC
1336
1337 ;;;###autoload
1338 (defun calendar (&optional arg)
1339   "Display a three-month Gregorian calendar.
1340 The three months appear side by side, with the current month in
1341 the middle surrounded by the previous and next months.  The
1342 cursor is put on today's date.  If optional prefix argument ARG
1343 is non-nil, prompts for the central month and year.
1344
1345 Once in the calendar window, future or past months can be moved
1346 into view.  Arbitrary months can be displayed, or the calendar
1347 can be scrolled forward or backward.  The cursor can be moved
1348 forward or backward by one day, one week, one month, or one year.
1349 All of these commands take prefix arguments which, when negative,
1350 cause movement in the opposite direction.  For convenience, the
1351 digit keys and the minus sign are automatically prefixes.  Use
1352 \\[describe-mode] for details of the key bindings in the calendar
1353 window.
1354
1355 Displays the calendar in a separate window, or optionally in a
1356 separate frame, depending on the value of `calendar-setup'.
1357
1358 If `calendar-view-diary-initially-flag' is non-nil, also displays the
1359 diary entries for the current date (or however many days
1360 `diary-number-of-entries' specifies).  This variable can be
1361 overridden by `calendar-setup'.  As well as being displayed,
1362 diary entries can also be marked on the calendar (see
1363 `calendar-mark-diary-entries-flag').
1364
1365 Runs the following hooks:
1366
1367 `calendar-load-hook' - after loading calendar.el
1368 `calendar-today-visible-hook', `calendar-today-invisible-hook' - after
1369    generating a calendar, if today's date is visible or not, respectively
1370 `calendar-initial-window-hook' - after first creating a calendar
1371
1372 This function is suitable for execution in an init file."
1373   (interactive "P")
1374   ;; Avoid loading cal-x unless it will be used.
1375   (if (and (memq calendar-setup '(one-frame two-frames calendar-only))
1376            (display-multi-frame-p))
1377       (calendar-frame-setup calendar-setup arg)
1378     (calendar-basic-setup arg)))
1379
1380 (defun calendar-basic-setup (&optional arg nodisplay)
1381   "Create a three-month calendar.
1382 If optional prefix argument ARG is non-nil, prompts for the month
1383 and year, else uses the current date.  If NODISPLAY is non-nil, don't
1384 display the generated calendar."
1385   (interactive "P")
1386   (let ((buff (current-buffer)))
1387     (set-buffer (get-buffer-create calendar-buffer))
1388     (calendar-mode)
1389     (let* ((pop-up-windows t)
1390            ;; Not really needed now, but means we use exactly the same
1391            ;; behavior as before in the non-wide case (see below).
1392            (split-height-threshold 1000)
1393            (split-width-threshold calendar-split-width-threshold)
1394            (date (if arg (calendar-read-date t)
1395                    (calendar-current-date)))
1396            (month (calendar-extract-month date))
1397            (year (calendar-extract-year date)))
1398       (calendar-increment-month month year (- calendar-offset))
1399       ;; Display the buffer before calling calendar-generate-window so that it
1400       ;; can get a chance to adjust the window sizes to the frame size.
1401       (unless nodisplay
1402         ;; We want a window configuration that looks something like
1403         ;; X        X | Y
1404         ;; -        -----
1405         ;; C        Z | C
1406         ;; where C is the calendar, and the LHS is the traditional,
1407         ;; non-wide frame, and the RHS is the wide frame case.
1408         ;; We should end up in the same state regardless of whether the
1409         ;; windows were initially split or not.
1410         ;; Previously, we only thought about the non-wide case.
1411         ;; We could just set split-height-threshold to 1000, relying on
1412         ;; the fact that the window splitting treated a single window as
1413         ;; a special case and would always split it (vertically).  The
1414         ;; same thing does not work in the wide-frame case, so now we do
1415         ;; the splitting by hand.
1416         ;; See discussion in bug#1806.
1417         ;; Actually, this still does not do quite the right thing in the
1418         ;; wide frame case if started from a configuration like the LHS.
1419         ;; Eg if you start with a non-wide frame, call calendar, then
1420         ;; make the frame wider.  This one is problematic because you
1421         ;; might need to split a totally unrelated window.  Oh well, it
1422         ;; seems unlikely, and perhaps respecting the original layout is
1423         ;; the right thing in that case.
1424         ;;
1425         ;; Is this a wide frame?  If so, split it horizontally.
1426
1427         ;; The following doesn't sound useful: If we split horizontally
1428         ;; here, the subsequent `pop-to-buffer' will likely split again
1429         ;; horizontally and we end up with three side-by-side windows.
1430         (when (window-splittable-p (selected-window) t)
1431           (split-window-right))
1432         (pop-to-buffer calendar-buffer)
1433         ;; Has the window already been split vertically?
1434         (when (and (not (window-dedicated-p))
1435                    (window-splittable-p (selected-window))
1436                    (window-full-height-p))
1437           (let ((win (split-window-below)))
1438             ;; In the upper window, show whatever was visible before.
1439             ;; This looks better than using other-buffer.
1440             (switch-to-buffer buff)
1441             ;; Switch to the lower window with the calendar buffer.
1442             (select-window win))))
1443       (calendar-generate-window month year)
1444       (if (and calendar-view-diary-initially-flag
1445                (calendar-date-is-visible-p date))
1446           ;; Do not clobber the calendar with the diary, if the diary
1447           ;; has previously been shown in the window that now shows the
1448           ;; calendar (bug#18381).
1449           (let ((display-buffer-overriding-action
1450                  '(nil . ((inhibit-same-window . t)))))
1451             (diary-view-entries)))))
1452   (if calendar-view-holidays-initially-flag
1453       (let* ((diary-buffer (diary-live-p))
1454              (diary-window (if diary-buffer (get-buffer-window diary-buffer)))
1455              (split-height-threshold (if diary-window 2 1000)))
1456         ;; FIXME display buffer?
1457         (calendar-list-holidays)))
1458   (run-hooks 'calendar-initial-window-hook))
1459
1460 (defun calendar-generate-window (&optional mon yr)
1461   "Generate the calendar window for the current date.
1462 Optional integers MON and YR are used instead of today's date."
1463   (let* ((inhibit-read-only t)
1464          (today (calendar-current-date))
1465          (month (calendar-extract-month today))
1466          (day (calendar-extract-day today))
1467          (year (calendar-extract-year today))
1468          (today-visible (or (not mon)
1469                             (<= (abs (calendar-interval mon yr month year)) 1)))
1470          (in-calendar-window (eq (window-buffer)
1471                                  (get-buffer calendar-buffer))))
1472     (calendar-generate (or mon month) (or yr year))
1473     (calendar-update-mode-line)
1474     (calendar-cursor-to-visible-date
1475      (if today-visible today (list displayed-month 1 displayed-year)))
1476     (set-buffer-modified-p nil)
1477     ;; Don't do any window-related stuff if we weren't called from a
1478     ;; window displaying the calendar.
1479     (when in-calendar-window
1480       (if (window-combined-p)
1481           ;; Adjust the window to exactly fit the displayed calendar.
1482           (fit-window-to-buffer nil nil calendar-minimum-window-height)
1483         ;; For a full height window or a window that is horizontally
1484         ;; combined don't fit height to that of its buffer.
1485         (set-window-vscroll nil 0))
1486       (sit-for 0))
1487     (and calendar-mark-holidays-flag
1488          ;; (calendar-date-is-valid-p today) ; useful for BC dates
1489          (calendar-mark-holidays)
1490          (and in-calendar-window (sit-for 0)))
1491     (unwind-protect
1492         (if calendar-mark-diary-entries-flag (diary-mark-entries))
1493       (run-hooks (if today-visible
1494                      'calendar-today-visible-hook
1495                    'calendar-today-invisible-hook)))))
1496
1497 (defun calendar-generate (month year)
1498   "Generate a three-month Gregorian calendar centered around MONTH, YEAR."
1499   ;; A negative YEAR is interpreted as BC; -1 being 1 BC, and so on.
1500   ;; Note that while calendars for years BC could be displayed as it
1501   ;; stands, almost all other calendar functions (eg holidays) would
1502   ;; at best have unpredictable results for such dates.
1503   (if (< (+ month (* 12 (1- year))) 2)
1504       (error "Months before January, 1 AD cannot be displayed"))
1505   (setq displayed-month month
1506         displayed-year year)
1507   (erase-buffer)
1508   (calendar-increment-month month year -1)
1509   (dotimes (i 3)
1510     (calendar-generate-month month year
1511                              (+ calendar-left-margin
1512                                 (* calendar-month-width i)))
1513     (calendar-increment-month month year 1)))
1514
1515 (defun calendar-move-to-column (indent)
1516   "Like `move-to-column', but indents if the line is too short."
1517   (if (< (move-to-column indent) indent)
1518       (indent-to indent)))
1519
1520 (defun calendar-ensure-newline ()
1521   "Move to the next line, adding a newline if necessary."
1522   (or (zerop (forward-line 1))
1523       (insert "\n")))
1524
1525 (defun calendar-insert-at-column (indent string truncate)
1526   "Move to column INDENT, adding spaces as needed.
1527 Inserts STRING so that it ends at INDENT.  STRING is either a
1528 literal string, or a sexp to evaluate to return such.  Truncates
1529 STRING to length TRUNCATE, and ensures a trailing space."
1530   (if (not (ignore-errors (stringp (setq string (eval string)))))
1531       (calendar-move-to-column indent)
1532     (if (> (string-width string) truncate)
1533         (setq string (truncate-string-to-width string truncate)))
1534     (or (string-match " $" string)
1535         (setq string (concat (if (= (string-width string) truncate)
1536                                  (substring string 0 -1)
1537                                string)
1538                              ;; Avoid inserting text properties unless
1539                              ;; we have to (ie, non-unit-width chars).
1540                              ;; This is by no means essential.
1541                              (if (= (string-width string) (length string))
1542                                  " "
1543                                ;; Cribbed from buff-menu.el.
1544                                (propertize
1545                                 " " 'display `(space :align-to ,indent))))))
1546     (calendar-move-to-column (- indent (string-width string)))
1547     (insert string)))
1548
1549 (defun calendar-generate-month (month year indent)
1550   "Produce a calendar for MONTH, YEAR on the Gregorian calendar.
1551 The calendar is inserted at the top of the buffer in which point is currently
1552 located, but indented INDENT spaces.  The indentation is done from the first
1553 character on the line and does not disturb the first INDENT characters on the
1554 line."
1555   (let ((blank-days                     ; at start of month
1556          (mod
1557           (- (calendar-day-of-week (list month 1 year))
1558              calendar-week-start-day)
1559           7))
1560          (last (calendar-last-day-of-month month year))
1561          (trunc (min calendar-intermonth-spacing
1562                      (1- calendar-left-margin)))
1563          (day 1)
1564          j)
1565    (goto-char (point-min))
1566    (calendar-move-to-column indent)
1567    (insert
1568     (calendar-string-spread (list calendar-month-header)
1569                             ?\s calendar-month-digit-width))
1570    (calendar-ensure-newline)
1571    (calendar-insert-at-column indent calendar-intermonth-header trunc)
1572    ;; Use the first N characters of each day to head the columns.
1573    (dotimes (i 7)
1574      (setq j (mod (+ calendar-week-start-day i) 7))
1575      (insert
1576       (truncate-string-to-width
1577        (propertize (calendar-day-name j 'header t)
1578                    'font-lock-face (if (memq j '(0 6))
1579                                        'calendar-weekend-header
1580                                      'calendar-weekday-header))
1581        calendar-day-header-width nil ?\s)
1582       (make-string (- calendar-column-width calendar-day-header-width) ?\s)))
1583    (calendar-ensure-newline)
1584    (calendar-insert-at-column indent calendar-intermonth-text trunc)
1585    ;; Add blank days before the first of the month.
1586    (insert (make-string (* blank-days calendar-column-width) ?\s))
1587    ;; Put in the days of the month.
1588    (dotimes (i last)
1589      (setq day (1+ i))
1590      ;; TODO should numbers be left-justified, centered...?
1591      (insert (propertize
1592               (format (format "%%%dd" calendar-day-digit-width) day)
1593               'mouse-face 'highlight
1594               'help-echo (eval calendar-date-echo-text)
1595               ;; 'date property prevents intermonth text confusing re-searches.
1596               ;; (Tried intangible, it did not really work.)
1597               'date t)
1598              (make-string
1599               (- calendar-column-width calendar-day-digit-width) ?\s))
1600      (when (and (zerop (mod (+ day blank-days) 7))
1601                 (/= day last))
1602        (calendar-ensure-newline)
1603        (setq day (1+ day))              ; first day of next week
1604        (calendar-insert-at-column indent calendar-intermonth-text trunc)))))
1605
1606 (defun calendar-redraw ()
1607   "Redraw the calendar display, if `calendar-buffer' is live."
1608   (interactive)
1609   (when (get-buffer calendar-buffer)
1610     (with-current-buffer calendar-buffer
1611       (let ((cursor-date (calendar-cursor-to-nearest-date)))
1612         (calendar-generate-window displayed-month displayed-year)
1613         (calendar-cursor-to-visible-date cursor-date))
1614       (when (window-live-p (get-buffer-window))
1615         (set-window-point (get-buffer-window) (point))))))
1616
1617 (defvar calendar-mode-map
1618   (let ((map (make-keymap)))
1619     (suppress-keymap map)
1620     (dolist (c '(narrow-to-region mark-word mark-sexp mark-paragraph
1621                  mark-defun mark-whole-buffer mark-page
1622                  downcase-region upcase-region kill-region
1623                  copy-region-as-kill capitalize-region write-region))
1624       (define-key map (vector 'remap c) 'calendar-not-implemented))
1625     (define-key map "<"     'calendar-scroll-right)
1626     (define-key map "\C-x<" 'calendar-scroll-right)
1627     (define-key map [prior] 'calendar-scroll-right-three-months)
1628     (define-key map "\ev"   'calendar-scroll-right-three-months)
1629     (define-key map ">"     'calendar-scroll-left)
1630     (define-key map "\C-x>" 'calendar-scroll-left)
1631     (define-key map [next]  'calendar-scroll-left-three-months)
1632     (define-key map "\C-v"  'calendar-scroll-left-three-months)
1633     (define-key map "\C-b"  'calendar-backward-day)
1634     (define-key map "\C-p"  'calendar-backward-week)
1635     (define-key map "\e{"   'calendar-backward-month)
1636     (define-key map "\C-x[" 'calendar-backward-year)
1637     (define-key map "\C-f"  'calendar-forward-day)
1638     (define-key map "\C-n"  'calendar-forward-week)
1639     (define-key map [left]  'calendar-backward-day)
1640     (define-key map [up]    'calendar-backward-week)
1641     (define-key map [right] 'calendar-forward-day)
1642     (define-key map [down]  'calendar-forward-week)
1643     (define-key map "\e}"   'calendar-forward-month)
1644     (define-key map "\C-x]" 'calendar-forward-year)
1645     (define-key map "\C-a"  'calendar-beginning-of-week)
1646     (define-key map "\C-e"  'calendar-end-of-week)
1647     (define-key map "\ea"   'calendar-beginning-of-month)
1648     (define-key map "\ee"   'calendar-end-of-month)
1649     (define-key map "\e<"   'calendar-beginning-of-year)
1650     (define-key map "\e>"   'calendar-end-of-year)
1651     (define-key map "\C-@"  'calendar-set-mark)
1652     ;; Many people are used to typing C-SPC and getting C-@.
1653     (define-key map [?\C-\s] 'calendar-set-mark)
1654     (define-key map "\C-x\C-x" 'calendar-exchange-point-and-mark)
1655     (define-key map "\e=" 'calendar-count-days-region)
1656     (define-key map "gd"  'calendar-goto-date)
1657     (define-key map "gD"  'calendar-goto-day-of-year)
1658     (define-key map "gj"  'calendar-julian-goto-date)
1659     (define-key map "ga"  'calendar-astro-goto-day-number)
1660     (define-key map "gh"  'calendar-hebrew-goto-date)
1661     (define-key map "gi"  'calendar-islamic-goto-date)
1662     (define-key map "gb"  'calendar-bahai-goto-date)
1663     (define-key map "gC"  'calendar-chinese-goto-date)
1664     (define-key map "gk"  'calendar-coptic-goto-date)
1665     (define-key map "ge"  'calendar-ethiopic-goto-date)
1666     (define-key map "gp"  'calendar-persian-goto-date)
1667     (define-key map "gc"  'calendar-iso-goto-date)
1668     (define-key map "gw"  'calendar-iso-goto-week)
1669     (define-key map "gf"  'calendar-french-goto-date)
1670     (define-key map "gml"  'calendar-mayan-goto-long-count-date)
1671     (define-key map "gmpc" 'calendar-mayan-previous-round-date)
1672     (define-key map "gmnc" 'calendar-mayan-next-round-date)
1673     (define-key map "gmph" 'calendar-mayan-previous-haab-date)
1674     (define-key map "gmnh" 'calendar-mayan-next-haab-date)
1675     (define-key map "gmpt" 'calendar-mayan-previous-tzolkin-date)
1676     (define-key map "gmnt" 'calendar-mayan-next-tzolkin-date)
1677     (define-key map "Aa"   'appt-add)
1678     (define-key map "Ad"   'appt-delete)
1679     (define-key map "S"   'calendar-sunrise-sunset)
1680     (define-key map "M"   'calendar-lunar-phases)
1681     (define-key map " "   'scroll-other-window)
1682     (define-key map [?\S-\ ] 'scroll-other-window-down)
1683     (define-key map "\d"  'scroll-other-window-down)
1684     (define-key map "\C-c\C-l" 'calendar-redraw)
1685     (define-key map "."   'calendar-goto-today)
1686     (define-key map "o"   'calendar-other-month)
1687     (define-key map "q"   'calendar-exit)
1688     (define-key map "a"   'calendar-list-holidays)
1689     (define-key map "h"   'calendar-cursor-holidays)
1690     (define-key map "x"   'calendar-mark-holidays)
1691     (define-key map "u"   'calendar-unmark)
1692     (define-key map "m"   'diary-mark-entries)
1693     (define-key map "d"   'diary-view-entries)
1694     (define-key map "D"   'diary-view-other-diary-entries)
1695     (define-key map "s"   'diary-show-all-entries)
1696     (define-key map "pd"  'calendar-print-day-of-year)
1697     (define-key map "pC"  'calendar-chinese-print-date)
1698     (define-key map "pk"  'calendar-coptic-print-date)
1699     (define-key map "pe"  'calendar-ethiopic-print-date)
1700     (define-key map "pp"  'calendar-persian-print-date)
1701     (define-key map "pc"  'calendar-iso-print-date)
1702     (define-key map "pj"  'calendar-julian-print-date)
1703     (define-key map "pa"  'calendar-astro-print-day-number)
1704     (define-key map "ph"  'calendar-hebrew-print-date)
1705     (define-key map "pi"  'calendar-islamic-print-date)
1706     (define-key map "pb"  'calendar-bahai-print-date)
1707     (define-key map "pf"  'calendar-french-print-date)
1708     (define-key map "pm"  'calendar-mayan-print-date)
1709     (define-key map "po"  'calendar-print-other-dates)
1710     (define-key map "id"  'diary-insert-entry)
1711     (define-key map "iw"  'diary-insert-weekly-entry)
1712     (define-key map "im"  'diary-insert-monthly-entry)
1713     (define-key map "iy"  'diary-insert-yearly-entry)
1714     (define-key map "ia"  'diary-insert-anniversary-entry)
1715     (define-key map "ib"  'diary-insert-block-entry)
1716     (define-key map "ic"  'diary-insert-cyclic-entry)
1717     (define-key map "ihd" 'diary-hebrew-insert-entry)
1718     (define-key map "ihm" 'diary-hebrew-insert-monthly-entry)
1719     (define-key map "ihy" 'diary-hebrew-insert-yearly-entry)
1720     (define-key map "iid" 'diary-islamic-insert-entry)
1721     (define-key map "iim" 'diary-islamic-insert-monthly-entry)
1722     (define-key map "iiy" 'diary-islamic-insert-yearly-entry)
1723     (define-key map "iBd" 'diary-bahai-insert-entry)
1724     (define-key map "iBm" 'diary-bahai-insert-monthly-entry)
1725     (define-key map "iBy" 'diary-bahai-insert-yearly-entry)
1726     (define-key map "iCd" 'diary-chinese-insert-entry)
1727     (define-key map "iCm" 'diary-chinese-insert-monthly-entry)
1728     (define-key map "iCy" 'diary-chinese-insert-yearly-entry)
1729     (define-key map "iCa" 'diary-chinese-insert-anniversary-entry)
1730     (define-key map "?"   'calendar-goto-info-node)
1731     (define-key map "Hm" 'cal-html-cursor-month)
1732     (define-key map "Hy" 'cal-html-cursor-year)
1733     (define-key map "tm" 'cal-tex-cursor-month)
1734     (define-key map "tM" 'cal-tex-cursor-month-landscape)
1735     (define-key map "td" 'cal-tex-cursor-day)
1736     (define-key map "tw1" 'cal-tex-cursor-week)
1737     (define-key map "tw2" 'cal-tex-cursor-week2)
1738     (define-key map "tw3" 'cal-tex-cursor-week-iso) ; FIXME twi ?
1739     (define-key map "tw4" 'cal-tex-cursor-week-monday) ; twm ?
1740     (define-key map "twW" 'cal-tex-cursor-week2-summary)
1741     (define-key map "tfd" 'cal-tex-cursor-filofax-daily)
1742     (define-key map "tfw" 'cal-tex-cursor-filofax-2week)
1743     (define-key map "tfW" 'cal-tex-cursor-filofax-week)
1744     (define-key map "tfy" 'cal-tex-cursor-filofax-year)
1745     (define-key map "ty" 'cal-tex-cursor-year)
1746     (define-key map "tY" 'cal-tex-cursor-year-landscape)
1747
1748     (define-key map [menu-bar edit] 'undefined)
1749     (define-key map [menu-bar search] 'undefined)
1750
1751     (easy-menu-define nil map nil cal-menu-sunmoon-menu)
1752     (easy-menu-define nil map nil cal-menu-diary-menu)
1753     (easy-menu-define nil map nil cal-menu-holidays-menu)
1754     (easy-menu-define nil map nil cal-menu-goto-menu)
1755     (easy-menu-define nil map nil cal-menu-scroll-menu)
1756
1757     ;; These are referenced in the default calendar-date-echo-text.
1758     (define-key map [down-mouse-3]
1759       (easy-menu-binding cal-menu-context-mouse-menu))
1760     (define-key map [down-mouse-2]
1761       (easy-menu-binding cal-menu-global-mouse-menu))
1762
1763     ;; cf scroll-bar.el.
1764     (if (and (boundp 'x-toolkit-scroll-bars) x-toolkit-scroll-bars)
1765         (define-key map [vertical-scroll-bar mouse-1]
1766           'calendar-scroll-toolkit-scroll)
1767       ;; Left-click moves us forward in time, right-click backwards.
1768       (define-key map [vertical-scroll-bar mouse-1] 'calendar-scroll-left)
1769       (define-key map [vertical-scroll-bar drag-mouse-1] 'calendar-scroll-left)
1770       ;; down-mouse-2 stays as scroll-bar-drag.
1771       (define-key map [vertical-scroll-bar mouse-3] 'calendar-scroll-right)
1772       (define-key map [vertical-scroll-bar drag-mouse-3]
1773         'calendar-scroll-right))
1774     map)
1775   "Keymap for `calendar-mode'.")
1776
1777 ;; Calendar mode is suitable only for specially formatted data.
1778 (put 'calendar-mode 'mode-class 'special)
1779
1780 (defun calendar-mode-line-entry (command echo &optional key string)
1781   "Return a propertized string for `calendar-mode-line-format'.
1782 COMMAND is a command to run, ECHO is the help-echo text, KEY
1783 is COMMAND's keybinding, STRING describes the binding."
1784   (propertize (or key
1785                   (substitute-command-keys
1786                    (format "\\<calendar-mode-map>\\[%s] %s" command string)))
1787               'help-echo (format "mouse-1: %s" echo)
1788               'mouse-face 'mode-line-highlight
1789               'keymap (make-mode-line-mouse-map 'mouse-1 command)))
1790
1791 ;; After calendar-mode-map.
1792 (defcustom calendar-mode-line-format
1793   (list
1794    (calendar-mode-line-entry 'calendar-scroll-right "previous month" "<")
1795    "Calendar"
1796    (concat
1797     (calendar-mode-line-entry 'calendar-goto-info-node "read Info on Calendar"
1798                               nil "info")
1799     " / "
1800     (calendar-mode-line-entry 'calendar-other-month "choose another month"
1801                               nil "other")
1802     " / "
1803     (calendar-mode-line-entry 'calendar-goto-today "go to today's date"
1804                               nil "today"))
1805    '(calendar-date-string (calendar-current-date) t)
1806    (calendar-mode-line-entry 'calendar-scroll-left "next month" ">"))
1807   "If non-nil, the mode line of the calendar buffer.
1808 This is a list of items that evaluate to strings.  The elements
1809 are evaluated and concatenated, evenly separated by blanks.
1810 During evaluation, the variable `date' is available as the date
1811 nearest the cursor (or today's date if that fails).  To update
1812 the mode-line as the cursor moves, add
1813 `calendar-update-mode-line' to `calendar-move-hook'.
1814
1815 If nil, do not modify the mode line at all.
1816
1817 Here is an example that has the Hebrew date, the day number/days
1818 remaining in the year, and the ISO week/year numbers:
1819
1820   (list
1821    \"\"
1822    '(calendar-hebrew-date-string date)
1823    '(let* ((year (calendar-extract-year date))
1824            (d (calendar-day-number date))
1825            (days-remaining
1826             (- (calendar-day-number (list 12 31 year)) d)))
1827       (format \"%d/%d\" d days-remaining))
1828    '(let* ((d (calendar-absolute-from-gregorian date))
1829            (iso-date (calendar-iso-from-absolute d)))
1830       (format \"ISO week %d of %d\"
1831         (calendar-extract-month iso-date)
1832         (calendar-extract-year iso-date)))
1833    \"\"))"
1834   :risky t
1835   :type 'sexp
1836   :group 'calendar)
1837
1838 (defun calendar-goto-info-node ()
1839   "Go to the info node for the calendar."
1840   (interactive)
1841   (info "(emacs)Calendar/Diary")
1842   (fit-window-to-buffer))
1843
1844 (defvar calendar-mark-ring nil
1845   "Used by `calendar-set-mark'.")
1846
1847 (define-derived-mode calendar-mode nil "Calendar"
1848   "A major mode for the calendar window.
1849 For a complete description, see the info node `Calendar/Diary'.
1850
1851 \\<calendar-mode-map>\\{calendar-mode-map}"
1852   (setq buffer-read-only t
1853         buffer-undo-list t
1854         indent-tabs-mode nil)
1855   (set (make-local-variable 'scroll-margin) 0) ; bug#10379
1856   (calendar-update-mode-line)
1857   (make-local-variable 'calendar-mark-ring)
1858   (make-local-variable 'displayed-month) ; month in middle of window
1859   (make-local-variable 'displayed-year)  ; year in middle of window
1860   ;; Most functions only work if displayed-month and displayed-year are set,
1861   ;; so let's make sure they're always set.  Most likely, this will be reset
1862   ;; soon in calendar-generate, but better safe than sorry.
1863   (unless (boundp 'displayed-month) (setq displayed-month 1))
1864   (unless (boundp 'displayed-year)  (setq displayed-year  2001))
1865   (if (bound-and-true-p calendar-font-lock-keywords)
1866       (set (make-local-variable 'font-lock-defaults)
1867            '(calendar-font-lock-keywords t))))
1868
1869 (defun calendar-string-spread (strings char length)
1870   "Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH.
1871 The effect is like mapconcat but the separating pieces are as balanced as
1872 possible.  Each item of STRINGS is evaluated before concatenation so it can
1873 actually be an expression that evaluates to a string.  If LENGTH is too short,
1874 the STRINGS are just concatenated and the result truncated."
1875 ;; The algorithm is based on equation (3.25) on page 85 of Concrete
1876 ;; Mathematics by Ronald L. Graham, Donald E. Knuth, and Oren Patashnik,
1877 ;; Addison-Wesley, Reading, MA, 1989.
1878   (let* ((strings (mapcar 'eval
1879                           (if (< (length strings) 2)
1880                               (append (list "") strings (list ""))
1881                             strings)))
1882          (n (- length (string-width (apply 'concat strings))))
1883          (m (* (1- (length strings)) (char-width char)))
1884          (s (car strings))
1885          (strings (cdr strings))
1886          (i 0))
1887     (dolist (string strings)
1888       (setq s (concat s
1889                       (make-string (max 0 (/ (+ n i) m)) char)
1890                       string)
1891             i (1+ i)))
1892     (truncate-string-to-width s length)))
1893
1894 (defun calendar-update-mode-line ()
1895   "Update the calendar mode line with the current date and date style."
1896   (if (and calendar-mode-line-format
1897            (bufferp (get-buffer calendar-buffer)))
1898       (with-current-buffer calendar-buffer
1899         (let ((start (- calendar-left-margin 2))
1900               (date (condition-case nil
1901                         (calendar-cursor-to-nearest-date)
1902                       (error (calendar-current-date)))))
1903           (setq mode-line-format
1904                 (concat (make-string (max 0 (+ start
1905                                                (- (car (window-inside-edges))
1906                                                   (car (window-edges))))) ?\s)
1907                         (calendar-string-spread
1908                          (mapcar 'eval calendar-mode-line-format)
1909                          ?\s (- calendar-right-margin (1- start))))))
1910         (force-mode-line-update))))
1911
1912 (defun calendar-buffer-list ()
1913   "List of all calendar-related buffers (as buffers, not strings)."
1914   (let (buffs)
1915     (dolist (b (list calendar-hebrew-yahrzeit-buffer lunar-phases-buffer
1916                      holiday-buffer diary-fancy-buffer solar-sunrises-buffer
1917                      (get-file-buffer diary-file)
1918                      calendar-buffer calendar-other-calendars-buffer))
1919       (and b (setq b (get-buffer b))
1920            (push b buffs)))
1921     buffs))
1922
1923 (defun calendar-exit (&optional kill)
1924   "Get out of the calendar window and hide it and related buffers."
1925   (interactive "P")
1926   (let ((diary-buffer (get-file-buffer diary-file))
1927         (calendar-buffers (calendar-buffer-list)))
1928     (when (or (not diary-buffer)
1929               (not (buffer-modified-p diary-buffer))
1930               (yes-or-no-p
1931                "Diary modified; do you really want to exit the calendar? "))
1932       (if (and calendar-setup (display-multi-frame-p))
1933           ;; FIXME: replace this cruft with the `quit-restore' window property
1934           (dolist (w (window-list-1 nil nil t))
1935             (if (and (memq (window-buffer w) calendar-buffers)
1936                      (window-dedicated-p w))
1937                 (if (eq (window-deletable-p w) 'frame)
1938                     (if calendar-remove-frame-by-deleting
1939                         (delete-frame (window-frame w))
1940                       (iconify-frame (window-frame w)))
1941                   (quit-window kill w))))
1942         (dolist (b calendar-buffers)
1943           (quit-windows-on b kill))))))
1944
1945 (define-obsolete-function-alias 'exit-calendar 'calendar-exit "23.1")
1946
1947 (defun calendar-current-date (&optional offset)
1948   "Return the current date in a list (month day year).
1949 Optional integer OFFSET is a number of days from the current date."
1950   (let* ((now (decode-time))
1951          (now (list (nth 4 now) (nth 3 now) (nth 5 now))))
1952     (if (zerop (or offset 0))
1953         now
1954       (calendar-gregorian-from-absolute
1955        (+ offset (calendar-absolute-from-gregorian now))))))
1956
1957 (defun calendar-column-to-segment ()
1958   "Convert current column to calendar month \"segment\".
1959 The left-most month returns 0, the next right 1, and so on."
1960   (let ((col (max 0 (+ (current-column)
1961                        (/ calendar-intermonth-spacing 2)
1962                        (- calendar-left-margin)))))
1963     (/ col (+ (* 7 calendar-column-width) calendar-intermonth-spacing))))
1964
1965 (defun calendar-cursor-to-date (&optional error event)
1966   "Return a list (month day year) of current cursor position.
1967 If cursor is not on a specific date, signals an error if optional parameter
1968 ERROR is non-nil, otherwise just returns nil.
1969 If EVENT is non-nil, it's an event indicating the buffer position to
1970 use instead of point."
1971   (with-current-buffer
1972       (if event (window-buffer (posn-window (event-start event)))
1973         (current-buffer))
1974     (save-excursion
1975       (and event (setq event (event-start event))
1976            (goto-char (posn-point event)))
1977       (let* ((segment (calendar-column-to-segment))
1978              (month (% (+ displayed-month (1- segment)) 12)))
1979         ;; Call with point on either of the two digits in a 2-digit date,
1980         ;; or on or before the digit of a 1-digit date.
1981         (if (not (and (looking-at "[ 0-9]?[0-9][^0-9]")
1982                       (get-text-property (point) 'date)))
1983             (if error (user-error "Not on a date!"))
1984           ;; Convert segment to real month and year.
1985           (if (zerop month) (setq month 12))
1986           ;; Go back to before the first date digit.
1987           (or (looking-at " ")
1988               (re-search-backward "[^0-9]"))
1989           (list month
1990                 (string-to-number
1991                  (buffer-substring (1+ (point))
1992                                    (+ 1 calendar-day-digit-width (point))))
1993                 (cond
1994                  ((and (= 12 month) (zerop segment)) (1- displayed-year))
1995                  ((and (= 1 month) (= segment 2)) (1+ displayed-year))
1996                  (t displayed-year))))))))
1997
1998 ;; The following version of calendar-gregorian-from-absolute is preferred for
1999 ;; reasons of clarity, BUT it's much slower than the version that follows it.
2000
2001 ;;(defun calendar-gregorian-from-absolute (date)
2002 ;;  "Compute the list (month day year) corresponding to the absolute DATE.
2003 ;;The absolute date is the number of days elapsed since the (imaginary)
2004 ;;Gregorian date Sunday, December 31, 1 BC."
2005 ;;  (let* ((approx (/ date 366)) ; approximation from below
2006 ;;         (year                ; search forward from the approximation
2007 ;;          (+ approx
2008 ;;             (calendar-sum y approx
2009 ;;                 (>= date (calendar-absolute-from-gregorian (list 1 1 (1+ y))))
2010 ;;                  1)))
2011 ;;         (month                         ; search forward from January
2012 ;;          (1+ (calendar-sum m 1
2013 ;;                   (> date
2014 ;;                      (calendar-absolute-from-gregorian
2015 ;;                       (list m (calendar-last-day-of-month m year) year)))
2016 ;;                   1)))
2017 ;;         (day                      ; calculate the day by subtraction
2018 ;;          (- date
2019 ;;             (1- (calendar-absolute-from-gregorian (list month 1 year))))))
2020 ;;    (list month day year)))
2021
2022 (defun calendar-gregorian-from-absolute (date)
2023   "Compute the list (month day year) corresponding to the absolute DATE.
2024 The absolute date is the number of days elapsed since the (imaginary)
2025 Gregorian date Sunday, December 31, 1 BC.  This function does not
2026 handle dates in years BC."
2027   ;; See the footnote on page 384 of ``Calendrical Calculations, Part II:
2028   ;; Three Historical Calendars'' by E. M. Reingold,  N. Dershowitz, and S. M.
2029   ;; Clamen, Software--Practice and Experience, Volume 23, Number 4
2030   ;; (April, 1993), pages 383-404 for an explanation.
2031   (let* ((d0 (1- date))
2032          (n400 (/ d0 146097))
2033          (d1 (% d0 146097))
2034          (n100 (/ d1 36524))
2035          (d2 (% d1 36524))
2036          (n4 (/ d2 1461))
2037          (d3 (% d2 1461))
2038          (n1 (/ d3 365))
2039          (day (1+ (% d3 365)))
2040          (year (+ (* 400 n400) (* 100 n100) (* n4 4) n1))
2041          (month 1)
2042          mdays)
2043     (if (or (= n100 4) (= n1 4))
2044         (list 12 31 year)
2045       (setq year (1+ year))
2046       (while (< (setq mdays (calendar-last-day-of-month month year)) day)
2047         (setq day (- day mdays)
2048               month (1+ month)))
2049       (list month day year))))
2050
2051 (defun calendar-other-month (month year &optional event)
2052   "Display a three-month calendar centered around MONTH and YEAR.
2053 EVENT is an event like `last-nonmenu-event'."
2054   (interactive (let ((event (list last-nonmenu-event)))
2055                  (append (calendar-read-date 'noday) event)))
2056   (save-selected-window
2057     (and event
2058          (setq event (event-start event))
2059          (select-window (posn-window event)))
2060     (unless (and (= month displayed-month)
2061                  (= year displayed-year))
2062       (let ((old-date (calendar-cursor-to-date))
2063             (today (calendar-current-date)))
2064         (calendar-generate-window month year)
2065         (calendar-cursor-to-visible-date
2066          (cond
2067           ((calendar-date-is-visible-p old-date) old-date)
2068           ((calendar-date-is-visible-p today) today)
2069           (t (list month 1 year))))))))
2070
2071 (defun calendar-set-mark (arg &optional event)
2072   "Mark the date under the cursor, or jump to marked date.
2073 With no prefix argument, push current date onto marked date ring.
2074 With argument ARG, jump to mark, pop it, and put point at end of ring."
2075   (interactive
2076    (list current-prefix-arg last-nonmenu-event))
2077   (let ((date (calendar-cursor-to-date t event)))
2078     (if arg
2079         (if (null calendar-mark-ring)
2080             (error "No mark set in this buffer")
2081           (calendar-goto-date (car calendar-mark-ring))
2082           (setq calendar-mark-ring
2083                 (cdr (nconc calendar-mark-ring (list date)))))
2084       (push date calendar-mark-ring)
2085       ;; Since the top of the mark ring is the marked date in the
2086       ;; calendar, the mark ring in the calendar is one longer than
2087       ;; in other buffers to get the same effect.
2088       (if (> (length calendar-mark-ring) (1+ mark-ring-max))
2089           (setcdr (nthcdr mark-ring-max calendar-mark-ring) nil))
2090       (message "Mark set"))))
2091
2092 (defun calendar-exchange-point-and-mark ()
2093   "Exchange the current cursor position with the marked date."
2094   (interactive)
2095   (let ((mark (car calendar-mark-ring))
2096         (date (calendar-cursor-to-date t)))
2097     (if (null mark)
2098         (error "No mark set in this buffer")
2099       (setq calendar-mark-ring (cons date (cdr calendar-mark-ring)))
2100       (calendar-goto-date mark))))
2101
2102 (defun calendar-count-days-region ()
2103   "Count the number of days (inclusive) between point and the mark."
2104   (interactive)
2105   (let* ((days (- (calendar-absolute-from-gregorian
2106                    (calendar-cursor-to-date t))
2107                   (calendar-absolute-from-gregorian
2108                    (or (car calendar-mark-ring)
2109                        (error "No mark set in this buffer")))))
2110          (days (1+ (if (> days 0) days (- days)))))
2111     (message "Region has %d day%s (inclusive)"
2112              days (if (> days 1) "s" ""))))
2113
2114 (defun calendar-not-implemented ()
2115   "Not implemented."
2116   (interactive)
2117   (error "%s not available in the calendar"
2118          (global-key-binding (this-command-keys))))
2119
2120 (defun calendar-read (prompt acceptable &optional initial-contents)
2121   "Return an object read from the minibuffer.
2122 Prompt with the string PROMPT and use the function ACCEPTABLE to decide if
2123 entered item is acceptable.  If non-nil, optional third arg INITIAL-CONTENTS
2124 is a string to insert in the minibuffer before reading."
2125   (let ((value (read-minibuffer prompt initial-contents)))
2126     (while (not (funcall acceptable value))
2127       (setq value (read-minibuffer prompt initial-contents)))
2128     value))
2129
2130
2131 (defun calendar-customized-p (symbol)
2132   "Return non-nil if SYMBOL has been customized."
2133   (and (default-boundp symbol)
2134        (let ((standard (get symbol 'standard-value)))
2135          (and standard
2136               (not (equal (eval (car standard)) (default-value symbol)))))))
2137
2138 (defun calendar-abbrev-construct (full &optional maxlen)
2139   "From sequence FULL, return a vector of abbreviations.
2140 Each abbreviation is no longer than MAXLEN (default `calendar-abbrev-length')
2141 characters."
2142   (or maxlen (setq maxlen calendar-abbrev-length))
2143   (apply 'vector (mapcar
2144                   (lambda (f)
2145                     ;; TODO? truncate-string-to-width?
2146                     (substring f 0 (min maxlen (length f))))
2147                   full)))
2148
2149 (defcustom calendar-day-name-array
2150   ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]
2151   "Array of capitalized strings giving, in order from Sunday, the day names.
2152 If you change this without using customize after the calendar has loaded,
2153 then you may also want to change `calendar-day-abbrev-array'
2154 and `calendar-day-header-array'."
2155   :group 'calendar
2156   :initialize 'custom-initialize-default
2157   :set (lambda (symbol value)
2158          (let ((dcustomized (calendar-customized-p 'calendar-day-abbrev-array))
2159                (hcustomized (calendar-customized-p 'cal-html-day-abbrev-array))
2160                (ccustomized (calendar-customized-p 'calendar-day-header-array)))
2161            (set symbol value)
2162            (or dcustomized
2163                (setq calendar-day-abbrev-array
2164                      (calendar-abbrev-construct calendar-day-name-array)))
2165            (and (not hcustomized)
2166                 (boundp 'cal-html-day-abbrev-array)
2167                 (setq cal-html-day-abbrev-array calendar-day-abbrev-array))
2168            (or ccustomized
2169                (equal calendar-day-header-array
2170                       (setq calendar-day-header-array
2171                             (calendar-day-header-construct)))
2172                (calendar-redraw))))
2173   :type '(vector (string :tag "Sunday")
2174                  (string :tag "Monday")
2175                  (string :tag "Tuesday")
2176                  (string :tag "Wednesday")
2177                  (string :tag "Thursday")
2178                  (string :tag "Friday")
2179                  (string :tag "Saturday")))
2180
2181 (defcustom calendar-abbrev-length 3
2182   "Default length of abbreviations to use for day and month names.
2183 If you change this without using customize after the calendar has loaded,
2184 then you may also want to change `calendar-day-abbrev-array' and
2185 `calendar-month-abbrev-array'."
2186   :group 'calendar
2187   :initialize 'custom-initialize-default
2188   :set (lambda (symbol value)
2189          (let ((dcustomized (calendar-customized-p 'calendar-day-abbrev-array))
2190                (mcustomized (calendar-customized-p
2191                              'calendar-month-abbrev-array))
2192                (hcustomized (calendar-customized-p 'cal-html-day-abbrev-array))
2193                (ccustomized (calendar-customized-p 'calendar-day-header-array)))
2194            (set symbol value)
2195            (or dcustomized
2196                (setq calendar-day-abbrev-array
2197                      (calendar-abbrev-construct calendar-day-name-array)))
2198            (or mcustomized
2199                (setq calendar-month-abbrev-array
2200                      (calendar-abbrev-construct calendar-month-name-array)))
2201            (and (not hcustomized)
2202                 (boundp 'cal-html-day-abbrev-array)
2203                 (setq cal-html-day-abbrev-array calendar-day-abbrev-array))
2204            (or ccustomized
2205                (equal calendar-day-header-array
2206                       (setq calendar-day-header-array
2207                             (calendar-day-header-construct)))
2208                (calendar-redraw))))
2209   :type 'integer)
2210
2211 (defcustom calendar-day-abbrev-array
2212   (calendar-abbrev-construct calendar-day-name-array)
2213   "Array of capitalized strings giving the abbreviated day names.
2214 The order should be the same as that of the full names specified
2215 in `calendar-day-name-array'.  These abbreviations may be used
2216 instead of the full names in the diary file.  Do not include a
2217 trailing `.' in the strings specified in this variable, though
2218 you may use such in the diary file.  By default, each string is
2219 the first `calendar-abbrev-length' characters of the corresponding
2220 full name."
2221   :group 'calendar
2222   :initialize 'custom-initialize-default
2223   :set-after '(calendar-abbrev-length calendar-day-name-array)
2224   :set (lambda (symbol value)
2225          (let ((hcustomized (calendar-customized-p 'cal-html-day-abbrev-array))
2226                (ccustomized (calendar-customized-p 'calendar-day-header-array)))
2227            (set symbol value)
2228            (and (not hcustomized)
2229                 (boundp 'cal-html-day-abbrev-array)
2230                 (setq cal-html-day-abbrev-array calendar-day-abbrev-array))
2231            (or ccustomized
2232                (equal calendar-day-header-array
2233                       (setq calendar-day-header-array
2234                             (calendar-day-header-construct)))
2235                (calendar-redraw))))
2236   :type '(vector (string :tag "Sun")
2237                  (string :tag "Mon")
2238                  (string :tag "Tue")
2239                  (string :tag "Wed")
2240                  (string :tag "Thu")
2241                  (string :tag "Fri")
2242                  (string :tag "Sat"))
2243   ;; Made defcustom, changed defaults from nil nil...
2244   :version "24.1")
2245
2246 (defcustom calendar-day-header-array (calendar-day-header-construct)
2247   "Array of strings to use for the headers of the calendar's day columns.
2248 The order should be the same as in `calendar-day-name-array'.
2249 In use, the calendar truncates elements to no more than
2250 `calendar-day-header-width' columns wide.
2251 Emacs constructs the default from either `calendar-day-name-array'
2252 \(if `calendar-day-header-width' is more than `calendar-abbrev-length'),
2253 or from `calendar-day-abbrev-array' (assuming that the abbreviated
2254 name are more likely to be unique when truncated)."
2255   :group 'calendar
2256   :initialize 'custom-initialize-default
2257   :set-after '(calendar-day-header-width
2258                calendar-abbrev-length calendar-day-name-array
2259                calendar-day-abbrev-array)
2260   :set (lambda (symbol value)
2261          (or (equal calendar-day-header-array
2262                     (set symbol value))
2263              (calendar-redraw)))
2264   :type '(vector (string :tag "Su")
2265                  (string :tag "Mo")
2266                  (string :tag "Tu")
2267                  (string :tag "We")
2268                  (string :tag "Th")
2269                  (string :tag "Fr")
2270                  (string :tag "Sa"))
2271   :version "24.4")
2272
2273 (defcustom calendar-month-name-array
2274   ["January" "February" "March"     "April"   "May"      "June"
2275    "July"    "August"   "September" "October" "November" "December"]
2276   "Array of capitalized strings giving, in order, the month names.
2277 If you change this without using customize after the calendar has loaded,
2278 then you may also want to change `calendar-month-abbrev-array'."
2279   :group 'calendar
2280   :initialize 'custom-initialize-default
2281   :set (lambda (symbol value)
2282          (let ((mcustomized (calendar-customized-p
2283                             'calendar-month-abbrev-array)))
2284            (set symbol value)
2285            (or mcustomized
2286                (setq calendar-month-abbrev-array
2287                      (calendar-abbrev-construct calendar-month-name-array)))))
2288   :type '(vector (string :tag "January")
2289                  (string :tag "February")
2290                  (string :tag "March")
2291                  (string :tag "April")
2292                  (string :tag "May")
2293                  (string :tag "June")
2294                  (string :tag "July")
2295                  (string :tag "August")
2296                  (string :tag "September")
2297                  (string :tag "October")
2298                  (string :tag "November")
2299                  (string :tag "December")))
2300
2301 (defcustom calendar-month-abbrev-array
2302   (calendar-abbrev-construct calendar-month-name-array)
2303  "Array of capitalized strings giving the abbreviated month names.
2304 The order should be the same as that of the full names specified
2305 in `calendar-month-name-array'.  These abbreviations are used in
2306 the calendar menu entries, and can also be used in the diary
2307 file.  Do not include a trailing `.' in the strings specified in
2308 this variable, though you may use such in the diary file.  By
2309 default, each string is the first ``calendar-abbrev-length'
2310 characters of the corresponding full name."
2311  :group 'calendar
2312  :set-after '(calendar-abbrev-length calendar-month-name-array)
2313  :type '(vector (string :tag "Jan")
2314                 (string :tag "Feb")
2315                 (string :tag "Mar")
2316                 (string :tag "Apr")
2317                 (string :tag "May")
2318                 (string :tag "Jun")
2319                 (string :tag "Jul")
2320                 (string :tag "Aug")
2321                 (string :tag "Sep")
2322                 (string :tag "Oct")
2323                 (string :tag "Nov")
2324                 (string :tag "Dec"))
2325  ;; Made defcustom, changed defaults from nil nil...
2326  :version "24.1")
2327
2328 (defun calendar-make-alist (sequence &optional start-index filter
2329                                      &rest sequences)
2330   "Return an association list corresponding to SEQUENCE.
2331 Associates each element of SEQUENCE with an incremented integer,
2332 starting from START-INDEX (default 1).  Applies the function FILTER,
2333 if provided, to each key in the alist.  Repeats the process, with
2334 indices starting from START-INDEX each time, for any remaining
2335 arguments SEQUENCES."
2336   (or start-index (setq start-index 1))
2337   (let (index alist)
2338     (mapc (lambda (seq)
2339             (setq index start-index)
2340             (mapc (lambda (elem)
2341                     (setq alist (cons
2342                                  (cons (if filter (funcall filter elem) elem)
2343                                        index)
2344                                  alist)
2345                           index (1+ index)))
2346                   seq))
2347           (append (list sequence) sequences))
2348     (reverse alist)))
2349
2350 (defun calendar-read-date (&optional noday)
2351   "Prompt for Gregorian date.  Return a list (month day year).
2352 If optional NODAY is t, does not ask for day, but just returns
2353 \(month 1 year); if NODAY is any other non-nil value the value returned is
2354 \(month year)"
2355   (let* ((year (calendar-read
2356                 "Year (>0): "
2357                 (lambda (x) (> x 0))
2358                 (number-to-string (calendar-extract-year
2359                                 (calendar-current-date)))))
2360          (month-array calendar-month-name-array)
2361          (completion-ignore-case t)
2362          (month (cdr (assoc-string
2363                        (completing-read
2364                         "Month name: "
2365                         (mapcar 'list (append month-array nil))
2366                         nil t)
2367                       (calendar-make-alist month-array 1) t)))
2368          (last (calendar-last-day-of-month month year)))
2369     (if noday
2370         (if (eq noday t)
2371             (list month 1 year)
2372           (list month year))
2373       (list month
2374             (calendar-read (format "Day (1-%d): " last)
2375                            (lambda (x) (and (< 0 x) (<= x last))))
2376             year))))
2377
2378 (defun calendar-interval (mon1 yr1 mon2 yr2)
2379   "The number of months difference between MON1, YR1 and MON2, YR2.
2380 The result is positive if the second date is later than the first.
2381 Negative years are interpreted as years BC; -1 being 1 BC, and so on."
2382   (if (< yr1 0) (setq yr1 (1+ yr1)))      ; -1 BC -> 0 AD, etc
2383   (if (< yr2 0) (setq yr2 (1+ yr2)))
2384   (+ (* 12 (- yr2 yr1))
2385      (- mon2 mon1)))
2386
2387 (defvar calendar-font-lock-keywords nil
2388   "Default keywords to highlight in Calendar mode.")
2389
2390 (make-obsolete-variable 'calendar-font-lock-keywords
2391                         "set font-lock keywords in `calendar-mode-hook', \
2392 or customize calendar faces." "24.4")
2393
2394 (defun calendar-day-name (date &optional abbrev absolute)
2395   "Return a string with the name of the day of the week of DATE.
2396 DATE should be a list in the format (MONTH DAY YEAR), unless the
2397 optional argument ABSOLUTE is non-nil, in which case DATE should
2398 be an integer in the range 0 to 6 corresponding to the day of the
2399 week.  Day names are taken from the variable `calendar-day-name-array',
2400 unless the optional argument ABBREV is non-nil:
2401 `header' means to use `calendar-day-header-array';
2402 t to use `calendar-day-abbrev-array'."
2403   (aref (cond ((eq abbrev 'header) calendar-day-header-array)
2404               (abbrev calendar-day-abbrev-array)
2405               (t calendar-day-name-array))
2406         (if absolute date (calendar-day-of-week date))))
2407
2408 (defun calendar-month-name (month &optional abbrev)
2409   "Return a string with the name of month number MONTH.
2410 Months are numbered from one.  Month names are taken from the
2411 variable `calendar-month-name-array', unless the optional
2412 argument ABBREV is non-nil, in which case
2413 `calendar-month-abbrev-array' is used."
2414   (aref (if abbrev calendar-month-abbrev-array calendar-month-name-array)
2415         (1- month)))
2416
2417 (defun calendar-day-of-week (date)
2418   "Return the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc.
2419 DATE is a list of the form (month day year).  A negative year is
2420 interpreted as BC; -1 being 1 BC, and so on."
2421   (mod (calendar-absolute-from-gregorian date) 7))
2422
2423 (defun calendar-week-end-day ()
2424   "Return the index (0 for Sunday, etc.) of the last day of the week."
2425   (mod (+ calendar-week-start-day 6) 7))
2426
2427 (defun calendar-unmark ()
2428   "Delete all diary/holiday marks/highlighting from the calendar."
2429   (interactive)
2430   (setq calendar-mark-holidays-flag nil
2431         calendar-mark-diary-entries-flag nil)
2432   (with-current-buffer calendar-buffer
2433     (mapc 'delete-overlay (overlays-in (point-min) (point-max)))))
2434
2435 (defun calendar-date-is-visible-p (date)
2436   "Return non-nil if DATE is valid and is visible in the calendar window."
2437   (and (calendar-date-is-valid-p date)
2438        (< (abs (calendar-interval
2439                 displayed-month displayed-year
2440                 (calendar-extract-month date) (calendar-extract-year date)))
2441           2)))
2442
2443 ;; FIXME can this be generalized for holiday-chinese?
2444 (defun calendar-nongregorian-visible-p (month day toabs fromabs switch)
2445   "Return non-nil if MONTH, DAY is visible in the calendar window.
2446 MONTH and DAY are in some non-Gregorian calendar system.  The
2447 functions TOABS and FROMABS convert that system to and from
2448 absolute, respectively.  SWITCH is a function that takes a single
2449 argument (a local month number).  It applies when the local year
2450 changes across the calendar window, and returns non-nil if the
2451 specified month should be associated with the higher year.
2452 Returns the corresponding Gregorian date."
2453   ;; We need to choose the local year associated with month and day
2454   ;; that might make them visible.
2455   (let* ((m1 displayed-month)
2456          (y1 displayed-year)
2457          (m2 displayed-month)
2458          (y2 displayed-year)
2459          ;; Absolute date of first/last dates in calendar window.
2460          (start-date (progn
2461                        (calendar-increment-month m1 y1 -1)
2462                        (calendar-absolute-from-gregorian (list m1 1 y1))))
2463          (end-date (progn
2464                      (calendar-increment-month m2 y2 1)
2465                      (calendar-absolute-from-gregorian
2466                       (list m2 (calendar-last-day-of-month m2 y2) y2))))
2467          ;; Local date of first/last date in calendar window.
2468          (local-start (funcall fromabs start-date))
2469          (local-end (funcall fromabs end-date))
2470          ;; Local year of first/last dates.
2471          ;; Can only differ if displayed-month = 12, 1, 2.
2472          (local-y1 (calendar-extract-year local-start))
2473          (local-y2 (calendar-extract-year local-end))
2474          ;; Choose which year might be visible in the window.
2475          ;; Obviously it only matters when y1 and y2 differ, ie
2476          ;; when the _local_ new year is visible.
2477          (year (if (funcall switch month) local-y2 local-y1))
2478          (date (calendar-gregorian-from-absolute
2479                 (funcall toabs (list month day year)))))
2480     (if (calendar-date-is-visible-p date)
2481         date)))
2482
2483 (defun calendar-date-is-valid-p (date)
2484   "Return t if DATE is a valid date."
2485   (let ((month (calendar-extract-month date))
2486         (day (calendar-extract-day date))
2487         (year (calendar-extract-year date)))
2488     (and (<= 1 month) (<= month 12)
2489          ;; (calendar-read-date t) used to return a date with day = nil.
2490          ;; Should not be valid (?), since many funcs prob assume integer.
2491          ;; (calendar-read-date 'noday) returns (month year), which
2492          ;; currently results in calendar-extract-year returning nil.
2493          day year (<= 1 day) (<= day (calendar-last-day-of-month month year))
2494          ;; BC dates left as non-valid, to suppress errors from
2495          ;; complex holiday algorithms not suitable for years BC.
2496          ;; Note there are side effects on calendar navigation.
2497          (<= 1 year))))
2498
2499 (define-obsolete-function-alias 'calendar-date-is-legal-p
2500     'calendar-date-is-valid-p "23.1")
2501
2502 (defun calendar-date-equal (date1 date2)
2503   "Return t if the DATE1 and DATE2 are the same."
2504   (and
2505    (= (calendar-extract-month date1) (calendar-extract-month date2))
2506    (= (calendar-extract-day date1) (calendar-extract-day date2))
2507    (= (calendar-extract-year date1) (calendar-extract-year date2))))
2508
2509 (defun calendar-make-temp-face (attrlist)
2510   "Return a temporary face based on the attributes in ATTRLIST.
2511 ATTRLIST is a list with elements of the form :face face :foreground color."
2512   (let ((attrs attrlist)
2513         faceinfo face temp-face)
2514     ;; Separate :face from the other attributes.  Use the last :face
2515     ;; if there are more than one.  FIXME is merging meaningful?
2516     (while attrs
2517       (if (eq (car attrs) :face)
2518           (setq face (intern-soft (cadr attrs))
2519                 attrs (cddr attrs))
2520         (push (car attrs) faceinfo)
2521         (setq attrs (cdr attrs))))
2522     (or (facep face) (setq face 'default))
2523     (if (not faceinfo)
2524         ;; No attributes to apply, so just use an existing-face.
2525         face
2526       ;; FIXME should we be using numbered temp-faces, re-using where poss?
2527       (setq temp-face
2528             (make-symbol
2529              (concat ":caltemp"
2530                      (mapconcat (lambda (sym)
2531                                   (cond
2532                                    ((symbolp sym) (symbol-name sym))
2533                                    ((numberp sym) (number-to-string sym))
2534                                    (t sym)))
2535                                 attrlist ""))))
2536       (make-face temp-face)
2537       (copy-face face temp-face)
2538       ;; Apply the font aspects.
2539       (apply 'set-face-attribute temp-face nil (nreverse faceinfo))
2540       temp-face)))
2541
2542 (defun calendar-mark-visible-date (date &optional mark)
2543   "Mark DATE in the calendar window with MARK.
2544 MARK is a single-character string, a list of face attributes/values, or a face.
2545 MARK defaults to `diary-entry-marker'."
2546   (if (calendar-date-is-valid-p date)
2547       (with-current-buffer calendar-buffer
2548         (save-excursion
2549           (calendar-cursor-to-visible-date date)
2550           (setq mark
2551                 (or (and (stringp mark) (= (length mark) 1) mark) ; single-char
2552                     ;; The next two use to also check font-lock-mode.
2553                     ;; See comments above diary-entry-marker for why
2554                     ;; this was dropped.
2555 ;;;                    (and font-lock-mode
2556 ;;;                         (or
2557                           (and (listp mark) (> (length mark) 0) mark) ; attrs
2558                           (and (facep mark) mark) ; )) face-name
2559                           diary-entry-marker))
2560           (cond
2561            ;; Face or an attr-list that contained a face.
2562            ((facep mark)
2563             (overlay-put
2564              (make-overlay (1- (point)) (1+ (point))) 'face mark))
2565            ;; Single-character mark, goes after the date.
2566            ((and (stringp mark) (= (length mark) 1))
2567             (overlay-put
2568              (make-overlay (1+ (point)) (+ 2 (point))) 'display mark))
2569            (t                           ; attr list
2570             (overlay-put
2571              (make-overlay (1- (point)) (1+ (point))) 'face
2572              (calendar-make-temp-face mark))))))))
2573
2574 (define-obsolete-function-alias 'mark-visible-calendar-date
2575   'calendar-mark-visible-date "23.1")
2576
2577 (defun calendar-star-date ()
2578   "Replace the date under the cursor in the calendar window with asterisks.
2579 You might want to add this function to `calendar-today-visible-hook'."
2580   (unless (catch 'found
2581             (dolist (ol (overlays-at (point)))
2582               (and (overlay-get ol 'calendar-star)
2583                    (throw 'found t))))
2584     (let ((ol (make-overlay (1- (point)) (point))))
2585       (overlay-put ol 'display "*")
2586       (overlay-put ol 'calendar-star t)
2587       ;; Use copy-sequence to avoid merging of identical 'display props.
2588       ;; Use two overlays so as not to mess up
2589       ;; calendar-cursor-to-nearest-date (and calendar-forward-day).
2590       (overlay-put (setq ol (make-overlay (point) (1+ (point))))
2591                    'display (copy-sequence "*"))
2592       (overlay-put ol 'calendar-star t))))
2593
2594 (defun calendar-mark-today ()
2595   "Mark the date under the cursor in the calendar window.
2596 The date is marked with `calendar-today-marker'.  You might want to add
2597 this function to `calendar-today-visible-hook'."
2598   (calendar-mark-visible-date (calendar-cursor-to-date) calendar-today-marker))
2599
2600 ;; FIXME why the car? Almost every usage calls list on the args.
2601 (defun calendar-date-compare (date1 date2)
2602   "Return t if DATE1 is before DATE2, nil otherwise.
2603 The actual dates are in the car of DATE1 and DATE2."
2604   (< (calendar-absolute-from-gregorian (car date1))
2605      (calendar-absolute-from-gregorian (car date2))))
2606
2607 (defun calendar-date-string (date &optional abbreviate nodayname)
2608   "A string form of DATE, driven by the variable `calendar-date-display-form'.
2609 An optional parameter ABBREVIATE, when non-nil, causes the month
2610 and day names to be abbreviated as specified by
2611 `calendar-month-abbrev-array' and `calendar-day-abbrev-array',
2612 respectively.  An optional parameter NODAYNAME, when t, omits the
2613 name of the day of the week."
2614   (let* ((dayname (unless nodayname (calendar-day-name date abbreviate)))
2615          (month (calendar-extract-month date))
2616          (monthname (calendar-month-name month abbreviate))
2617          (day (number-to-string (calendar-extract-day date)))
2618          (month (number-to-string month))
2619          (year (number-to-string (calendar-extract-year date))))
2620     (mapconcat 'eval calendar-date-display-form "")))
2621
2622 (defun calendar-dayname-on-or-before (dayname date)
2623   "Return the absolute date of the DAYNAME on or before absolute DATE.
2624 DAYNAME=0 means Sunday, DAYNAME=1 means Monday, and so on.
2625
2626 Note: Applying this function to d+6 gives us the DAYNAME on or after an
2627 absolute day d.  Similarly, applying it to d+3 gives the DAYNAME nearest to
2628 absolute date d, applying it to d-1 gives the DAYNAME previous to absolute
2629 date d, and applying it to d+7 gives the DAYNAME following absolute date d."
2630   (- date (% (- date dayname) 7)))
2631
2632 (defun calendar-nth-named-absday (n dayname month year &optional day)
2633   "Absolute date of the Nth DAYNAME after/before MONTH YEAR DAY.
2634 A DAYNAME of 0 means Sunday, 1 means Monday, and so on.
2635 If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive).
2636 If N<0, return the Nth DAYNAME before MONTH DAY, YEAR (inclusive).
2637 DAY defaults to 1 if N>0, and MONTH's last day otherwise."
2638   (if (> n 0)
2639       (+ (* 7 (1- n))
2640          (calendar-dayname-on-or-before
2641           dayname
2642           (+ 6 (calendar-absolute-from-gregorian
2643                 (list month (or day 1) year)))))
2644     (+ (* 7 (1+ n))
2645        (calendar-dayname-on-or-before
2646         dayname
2647         (calendar-absolute-from-gregorian
2648          (list month
2649                (or day (calendar-last-day-of-month month year))
2650                year))))))
2651
2652 (defun calendar-nth-named-day (n dayname month year &optional day)
2653   "Date of the Nth DAYNAME after/before MONTH YEAR DAY.
2654 Like `calendar-nth-named-absday', but returns a Gregorian date."
2655   (calendar-gregorian-from-absolute
2656    (calendar-nth-named-absday n dayname month year day)))
2657
2658 (defun calendar-day-of-year-string (&optional date)
2659   "String of day number of year of Gregorian DATE.
2660 Defaults to today's date if DATE is not given."
2661   (let* ((d (or date (calendar-current-date)))
2662          (year (calendar-extract-year d))
2663          (day (calendar-day-number d))
2664          (days-remaining (- (calendar-day-number (list 12 31 year)) day)))
2665     (format "Day %d of %d; %d day%s remaining in the year"
2666             day year days-remaining (if (= days-remaining 1) "" "s"))))
2667
2668 (defun calendar-other-dates (date)
2669   "Return a list of strings giving Gregorian DATE in other calendars.
2670 DATE is (month day year).  Calendars that do not apply are omitted."
2671   (let (odate)
2672     (delq nil
2673           (list
2674            (calendar-day-of-year-string date)
2675            (format "ISO date: %s" (calendar-iso-date-string date))
2676            (format "Julian date: %s"
2677                    (calendar-julian-date-string date))
2678            (format "Astronomical (Julian) day number (at noon UTC): %s.0"
2679                    (calendar-astro-date-string date))
2680            (format "Fixed (RD) date: %s"
2681                    (calendar-absolute-from-gregorian date))
2682            (format "Hebrew date (before sunset): %s"
2683                    (calendar-hebrew-date-string date))
2684            (format "Persian date: %s"
2685                    (calendar-persian-date-string date))
2686            (unless (string-equal
2687                     (setq odate (calendar-islamic-date-string date))
2688                     "")
2689              (format "Islamic date (before sunset): %s" odate))
2690            (unless (string-equal
2691                     (setq odate (calendar-bahai-date-string date))
2692                     "")
2693              (format "Bahá'í date: %s" odate))
2694            (format "Chinese date: %s"
2695                    (calendar-chinese-date-string date))
2696            (unless (string-equal
2697                     (setq odate (calendar-coptic-date-string date))
2698                     "")
2699              (format "Coptic date: %s" odate))
2700            (unless (string-equal
2701                     (setq odate (calendar-ethiopic-date-string date))
2702                     "")
2703              (format "Ethiopic date: %s" odate))
2704            (unless (string-equal
2705                     (setq odate (calendar-french-date-string date))
2706                     "")
2707              (format "French Revolutionary date: %s" odate))
2708            (format "Mayan date: %s"
2709                    (calendar-mayan-date-string date))))))
2710
2711 (declare-function x-popup-menu "menu.c" (position menu))
2712
2713 (defun calendar-print-other-dates (&optional event)
2714   "Show dates on other calendars for date under the cursor.
2715 If called by a mouse-event, pops up a menu with the result."
2716   (interactive (list last-nonmenu-event))
2717   (let* ((date (calendar-cursor-to-date t event))
2718          (title (format "%s (Gregorian)" (calendar-date-string date)))
2719          (others (calendar-other-dates date))
2720          selection)
2721     (if (mouse-event-p event)
2722         (and (setq selection (cal-menu-x-popup-menu event title
2723                                (mapcar 'list others)))
2724              (call-interactively selection))
2725       (calendar-in-read-only-buffer calendar-other-calendars-buffer
2726         (calendar-set-mode-line title)
2727         (insert (mapconcat 'identity others "\n"))))))
2728
2729 (defun calendar-print-day-of-year ()
2730   "Show day number in year/days remaining in year for date under the cursor."
2731   (interactive)
2732   (message "%s" (calendar-day-of-year-string (calendar-cursor-to-date t))))
2733
2734 (defun calendar-set-mode-line (str)
2735   "Set mode line to STR, centered, surrounded by dashes."
2736   (let* ((edges (window-edges))
2737          ;; As per doc of window-width, total visible mode-line length.
2738          (width (- (nth 2 edges) (car edges))))
2739     ;; Hack for --daemon.  See bug #2199.
2740     ;; If no frame exists yet, we have no idea what width to use.
2741     (and (= width 10)
2742          (not window-system)
2743          (setq width (string-to-number (or (getenv "COLUMNS") "80"))))
2744     (setq mode-line-format
2745           (if buffer-file-name
2746               `("-" mode-line-modified
2747                 ,(calendar-string-spread (list str) ?- (- width 6))
2748                 "---")
2749             (calendar-string-spread (list str) ?- width)))))
2750
2751 (define-obsolete-function-alias 'calendar-version 'emacs-version "23.1")
2752
2753 (run-hooks 'calendar-load-hook)
2754
2755 (provide 'calendar)
2756
2757 ;; Local variables:
2758 ;; byte-compile-dynamic: t
2759 ;; coding: utf-8
2760 ;; End:
2761
2762 ;;; calendar.el ends here