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