Mercurial > hg > xemacs-beta
diff lisp/calendar/calendar.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
author | cvs |
---|---|
date | Mon, 13 Aug 2007 08:45:50 +0200 |
parents | |
children | ac2d302a0011 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/calendar/calendar.el Mon Aug 13 08:45:50 2007 +0200 @@ -0,0 +1,2931 @@ +;;; calendar.el --- Calendar functions. -*-byte-compile-dynamic: t;-*- + +;;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994 Free Software +;;; Foundation, Inc. + +;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> +;; Keywords: calendar +;; Human-Keywords: calendar, Gregorian calendar, Julian calendar, +;; Hebrew calendar, Islamic calendar, ISO calendar, Julian day number, +;; diary, holidays + +;; This file is part of XEmacs. + +;; XEmacs is free software; you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; XEmacs is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with XEmacs; see the file COPYING. If not, write to the Free +;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; This collection of functions implements a calendar window. It +;; generates a calendar for the current month, together with the previous +;; and coming months, or for any other three-month period. The calendar +;; can be scrolled forward and backward in the window to show months in +;; the past or future; the cursor can move forward and backward by days, +;; weeks, or months, making it possible, for instance, to jump to the +;; date a specified number of days, weeks, or months from the date under +;; the cursor. The user can display a list of holidays and other notable +;; days for the period shown; the notable days can be marked on the +;; calendar, if desired. The user can also specify that dates having +;; corresponding diary entries (in a file that the user specifies) be +;; marked; the diary entries for any date can be viewed in a separate +;; window. The diary and the notable days can be viewed independently of +;; the calendar. Dates can be translated from the (usual) Gregorian +;; calendar to the day of the year/days remaining in year, to the ISO +;; commercial calendar, to the Julian (old style) calendar, to the Hebrew +;; calendar, to the Islamic calendar, to the French Revolutionary calendar, +;; to the Mayan calendar, and to the astronomical (Julian) day number. +;; When floating point is available, times of sunrise/sunset can be displayed, +;; as can the phases of the moon. Appointment notification for diary entries +;; is available. + +;; The following files are part of the calendar/diary code: + +;; cal-menu.el Menu support +;; cal-x.el X-windows dedicated frame functions +;; diary-lib.el, diary-ins.el Diary functions +;; holidays.el Holiday functions +;; cal-french.el French Revolutionary calendar +;; cal-mayan.el Mayan calendars +;; cal-dst.el Daylight savings time rules +;; solar.el Sunrise/sunset, equinoxes/solstices +;; lunar.el Phases of the moon +;; appt.el Appointment notification + +;; Comments, corrections, and improvements should be sent to +;; Edward M. Reingold Department of Computer Science +;; (217) 333-6733 University of Illinois at Urbana-Champaign +;; reingold@cs.uiuc.edu 1304 West Springfield Avenue +;; Urbana, Illinois 61801 + +;; GNU Emacs users too numerous to list pointed out a variety of problems +;; with earlier forms of the `infinite' sliding calendar and suggested some +;; of the features included in this package. Especially significant in this +;; regard was the suggestion of mark-diary-entries and view-diary-entries, +;; together ideas for their implementation, by +;; Michael S. Littman Cognitive Science Research Group +;; (201) 829-5155 Bell Communications Research +;; mlittman@wind.bellcore.com 445 South St. Box 1961 (2L-331) +;; Morristown, NJ 07960 + +;; The algorithms for the Hebrew calendar are those of the Rambam (Rabbi Moses +;; Maimonides), from his Mishneh Torah, as implemented by +;; Nachum Dershowitz Department of Computer Science +;; (217) 333-4219 University of Illinois at Urbana-Champaign +;; nachum@cs.uiuc.edu 1304 West Springfield Avenue +;; Urbana, Illinois 61801 + +;; Technical details of all the calendrical calculations can be found in + +;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, +;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990), +;; pages 899-928. ``Calendrical Calculations, Part II: Three Historical +;; Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. Clamen, +;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993), +;; pages 383-404. + +;; Hard copies of these two papers can be obtained by sending email to +;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and +;; the message BODY containing your mailing address (snail). + +;;; Code: + +(defun calendar-version () + (interactive) + (message "Version 5.3, January 25, 1994")) + +;;;###autoload +(defvar calendar-week-start-day 0 + "*The day of the week on which a week in the calendar begins. +0 means Sunday (default), 1 means Monday, and so on.") + +;;;###autoload +(defvar calendar-offset 0 + "*The offset of the principal month from the center of the calendar window. +0 means the principal month is in the center (default), -1 means on the left, ++1 means on the right. Larger (or smaller) values push the principal month off +the screen.") + +;;;###autoload +(defvar view-diary-entries-initially nil + "*Non-nil means display current date's diary entries on entry. +The diary is displayed in another window when the calendar is first displayed, +if the current date is visible. The number of days of diary entries displayed +is governed by the variable `number-of-diary-entries'.") + +;;;###autoload +(defvar number-of-diary-entries 1 + "*Specifies how many days of diary entries are to be displayed initially. +This variable affects the diary display when the command M-x diary is used, +or if the value of the variable `view-diary-entries-initially' is t. For +example, if the default value 1 is used, then only the current day's diary +entries will be displayed. If the value 2 is used, then both the current +day's and the next day's entries will be displayed. + +The value can also be a vector such as [0 2 2 2 2 4 1]; this value +says to display no diary entries on Sunday, the display the entries +for the current date and the day after on Monday through Thursday, +display Friday through Monday's entries on Friday, and display only +Saturday's entries on Saturday. + +This variable does not affect the diary display with the `d' command +from the calendar; in that case, the prefix argument controls the +number of days of diary entries displayed.") + +;;;###autoload +(defvar mark-diary-entries-in-calendar nil + "*Non-nil means mark dates with diary entries, in the calendar window. +The marking symbol is specified by the variable `diary-entry-marker'.") + +(defvar diary-entry-marker + (progn + (make-face 'diary-face) + (cond ((face-differs-from-default-p 'diary-face) nil) + (t (set-face-foreground 'diary-face "red" 'global '(x color)) + (set-face-highlight-p 'diary-face t 'global 'tty) + ;; avoid a weird problem when byte-compiling appt.el + ;; in batch mode. + (if (and (not noninteractive) (fboundp 'x-make-font-bold)) + (let ((bfont (x-make-font-bold + (face-font-instance 'default))) + (mono-tag (list 'x 'mono)) + (gray-tag (list 'x 'grayscale))) + (if bfont + (progn + (set-face-font 'diary-face bfont 'global mono-tag) + (set-face-font 'diary-face bfont 'global + gray-tag))))))) + 'diary-face) + "*Used to mark dates that have diary entries. +Can be either a single-character string or a face.") + +(defvar calendar-today-marker + (progn + (make-face 'calendar-today-face) + (if (not (face-differs-from-default-p 'calendar-today-face)) + (set-face-underline-p 'calendar-today-face t)) + 'calendar-today-face) + "*Used to mark today's date. +Can be either a single-character string or a face.") + +(defvar calendar-holiday-marker + (progn + (make-face 'holiday-face) + (cond ((face-differs-from-default-p 'holiday-face) nil) + (t (let ((color-tag (list 'x 'color)) + (mono-tag (list 'x 'mono)) + (gray-tag (list 'x 'grayscale))) + (set-face-background 'holiday-face [default foreground] 'global + mono-tag) + (set-face-foreground 'holiday-face [default background] 'global + mono-tag) + (set-face-background 'holiday-face [default foreground] 'global + gray-tag) + (set-face-foreground 'holiday-face [default background] 'global + gray-tag) + (set-face-background 'holiday-face "pink" 'global color-tag) + (set-face-reverse-p 'holiday-face t 'global 'tty)))) + 'holiday-face) + "*Used to mark notable dates in the calendar. +Can be either a single-character string or a face.") + +;;;###autoload +(defvar view-calendar-holidays-initially nil + "*Non-nil means display holidays for current three month period on entry. +The holidays are displayed in another window when the calendar is first +displayed.") + +;;;###autoload +(defvar mark-holidays-in-calendar nil + "*Non-nil means mark dates of holidays in the calendar window. +The marking symbol is specified by the variable `calendar-holiday-marker'.") + +;;;###autoload +(defvar all-hebrew-calendar-holidays nil + "*If nil, show only major holidays from the Hebrew calendar. +This means only those Jewish holidays that appear on secular calendars. + +If t, show all the holidays that would appear in a complete Hebrew calendar.") + +;;;###autoload +(defvar all-christian-calendar-holidays nil + "*If nil, show only major holidays from the Christian calendar. +This means only those Christian holidays that appear on secular calendars. + +If t, show all the holidays that would appear in a complete Christian +calendar.") + +;;;###autoload +(defvar all-islamic-calendar-holidays nil + "*If nil, show only major holidays from the Islamic calendar. +This means only those Islamic holidays that appear on secular calendars. + +If t, show all the holidays that would appear in a complete Islamic +calendar.") + +;;;###autoload +(defvar calendar-load-hook nil + "*List of functions to be called after the calendar is first loaded. +This is the place to add key bindings to `calendar-mode-map'.") + +;;;###autoload +(defvar initial-calendar-window-hook nil + "*List of functions to be called when the calendar window is first opened. +The functions invoked are called after the calendar window is opened, but +once opened is never called again. Leaving the calendar with the `q' command +and reentering it will cause these functions to be called again.") + +;;;###autoload +(defvar today-visible-calendar-hook nil + "*List of functions called whenever the current date is visible. +This can be used, for example, to replace today's date with asterisks; a +function `calendar-star-date' is included for this purpose: + (setq today-visible-calendar-hook 'calendar-star-date) +It can also be used to mark the current date with `calendar-today-marker'; +a function is also provided for this: + (setq today-visible-calendar-hook 'calendar-mark-today) + +The corresponding variable `today-invisible-calendar-hook' is the list of +functions called when the calendar function was called when the current +date is not visible in the window. + +Other than the use of the provided functions, the changing of any +characters in the calendar buffer by the hooks may cause the failure of the +functions that move by days and weeks.") + +;;;###autoload +(defvar today-invisible-calendar-hook nil + "*List of functions called whenever the current date is not visible. + +The corresponding variable `today-visible-calendar-hook' is the list of +functions called when the calendar function was called when the current +date is visible in the window. + +Other than the use of the provided functions, the changing of any +characters in the calendar buffer by the hooks may cause the failure of the +functions that move by days and weeks.") + +;;;###autoload +(defvar diary-file "~/diary" + "*Name of the file in which one's personal diary of dates is kept. + +The file's entries are lines in any of the forms + + MONTH/DAY + MONTH/DAY/YEAR + MONTHNAME DAY + MONTHNAME DAY, YEAR + DAYNAME + +at the beginning of the line; the remainder of the line is the diary entry +string for that date. MONTH and DAY are one or two digit numbers, YEAR is +a number and may be written in full or abbreviated to the final two digits. +If the date does not contain a year, it is generic and applies to any year. +DAYNAME entries apply to any date on which is on that day of the week. +MONTHNAME and DAYNAME can be spelled in full, abbreviated to three +characters (with or without a period), capitalized or not. Any of DAY, +MONTH, or MONTHNAME, YEAR can be `*' which matches any day, month, or year, +respectively. + +The European style (in which the day precedes the month) can be used +instead, if you execute `european-calendar' when in the calendar, or set +`european-calendar-style' to t in your .emacs file. The European forms are + + DAY/MONTH + DAY/MONTH/YEAR + DAY MONTHNAME + DAY MONTHNAME YEAR + DAYNAME + +To revert to the default American style from the European style, execute +`american-calendar' in the calendar. + +A diary entry can be preceded by the character +`diary-nonmarking-symbol' (ordinarily `&') to make that entry +nonmarking--that is, it will not be marked on dates in the calendar +window but will appear in a diary window. + +Multiline diary entries are made by indenting lines after the first with +either a TAB or one or more spaces. + +Lines not in one the above formats are ignored. Here are some sample diary +entries (in the default American style): + + 12/22/1988 Twentieth wedding anniversary!! + &1/1. Happy New Year! + 10/22 Ruth's birthday. + 21: Payday + Tuesday--weekly meeting with grad students at 10am + Supowit, Shen, Bitner, and Kapoor to attend. + 1/13/89 Friday the thirteenth!! + &thu 4pm squash game with Lloyd. + mar 16 Dad's birthday + April 15, 1989 Income tax due. + &* 15 time cards due. + +If the first line of a diary entry consists only of the date or day name with +no trailing blanks or punctuation, then that line is not displayed in the +diary window; only the continuation lines is shown. For example, the +single diary entry + + 02/11/1989 + Bill Blattner visits Princeton today + 2pm Cognitive Studies Committee meeting + 2:30-5:30 Lizzie at Lawrenceville for `Group Initiative' + 4:00pm Jamie Tappenden + 7:30pm Dinner at George and Ed's for Alan Ryan + 7:30-10:00pm dance at Stewart Country Day School + +will appear in the diary window without the date line at the beginning. This +facility allows the diary window to look neater, but can cause confusion if +used with more than one day's entries displayed. + +Diary entries can be based on Lisp sexps. For example, the diary entry + + %%(diary-block 11 1 1990 11 10 1990) Vacation + +causes the diary entry \"Vacation\" to appear from November 1 through November +10, 1990. Other functions available are `diary-float', `diary-anniversary', +`diary-cyclic', `diary-day-of-year', `diary-iso-date', `diary-french-date', +`diary-hebrew-date', `diary-islamic-date', `diary-mayan-date', +`diary-yahrzeit', `diary-sunrise-sunset', `diary-phases-of-moon', +`diary-parasha', `diary-omer', `diary-rosh-hodesh', and +`diary-sabbath-candles'. See the documentation for the function +`list-sexp-diary-entries' for more details. + +Diary entries based on the Hebrew and/or the Islamic calendar are also +possible, but because these are somewhat slow, they are ignored +unless you set the `nongregorian-diary-listing-hook' and the +`nongregorian-diary-marking-hook' appropriately. See the documentation +for these functions for details. + +Diary files can contain directives to include the contents of other files; for +details, see the documentation for the variable `list-diary-entries-hook'.") + +;;;###autoload +(defvar diary-nonmarking-symbol "&" + "*Symbol indicating that a diary entry is not to be marked in the calendar.") + +;;;###autoload +(defvar hebrew-diary-entry-symbol "H" + "*Symbol indicating a diary entry according to the Hebrew calendar.") + +;;;###autoload +(defvar islamic-diary-entry-symbol "I" + "*Symbol indicating a diary entry according to the Islamic calendar.") + +;;;###autoload +(defvar diary-include-string "#include" + "*The string indicating inclusion of another file of diary entries. +See the documentation for the function `include-other-diary-files'.") + +;;;###autoload +(defvar sexp-diary-entry-symbol "%%" + "*The string used to indicate a sexp diary entry in diary-file. +See the documentation for the function `list-sexp-diary-entries'.") + +;;;###autoload +(defvar abbreviated-calendar-year t + "*Interpret a two-digit year DD in a diary entry as either 19DD or 20DD. +For the Gregorian calendar; similarly for the Hebrew and Islamic calendars. +If this variable is nil, years must be written in full.") + +;;;###autoload +(defvar european-calendar-style nil + "*Use the European style of dates in the diary and in any displays. +If this variable is t, a date 1/2/1990 would be interpreted as February 1, +1990. The accepted European date styles are + + DAY/MONTH + DAY/MONTH/YEAR + DAY MONTHNAME + DAY MONTHNAME YEAR + DAYNAME + +Names can be capitalized or not, written in full, or abbreviated to three +characters with or without a period.") + +;;;###autoload +(defvar american-date-diary-pattern + '((month "/" day "[^/0-9]") + (month "/" day "/" year "[^0-9]") + (monthname " *" day "[^,0-9]") + (monthname " *" day ", *" year "[^0-9]") + (dayname "\\W")) + "*List of pseudo-patterns describing the American patterns of date used. +See the documentation of `diary-date-forms' for an explanation.") + +;;;###autoload +(defvar european-date-diary-pattern + '((day "/" month "[^/0-9]") + (day "/" month "/" year "[^0-9]") + (backup day " *" monthname "\\W+\\<[^*0-9]") + (day " *" monthname " *" year "[^0-9]") + (dayname "\\W")) + "*List of pseudo-patterns describing the European patterns of date used. +See the documentation of `diary-date-forms' for an explanation.") + +(defvar diary-date-forms + (if european-calendar-style + european-date-diary-pattern + american-date-diary-pattern) + "*List of pseudo-patterns describing the forms of date used in the diary. +The patterns on the list must be MUTUALLY EXCLUSIVE and must should not match +any portion of the diary entry itself, just the date component. + +A pseudo-pattern is a list of regular expressions and the keywords `month', +`day', `year', `monthname', and `dayname'. The keyword `monthname' will +match the name of the month, capitalized or not, or its three-letter +abbreviation, followed by a period or not; it will also match `*'. +Similarly, `dayname' will match the name of the day, capitalized or not, or +its three-letter abbreviation, followed by a period or not. The keywords +`month', `day', and `year' will match those numerical values, preceded by +arbitrarily many zeros; they will also match `*'. + +The matching of the diary entries with the date forms is done with the +standard syntax table from Fundamental mode, but with the `*' changed so +that it is a word constituent. + +If, to be mutually exclusive, a pseudo-pattern must match a portion of the +diary entry itself, the first element of the pattern MUST be `backup'. This +directive causes the date recognizer to back up to the beginning of the +current word of the diary entry, so in no case can the pattern match more than +a portion of the first word of the diary entry.") + +;;;###autoload +(defvar european-calendar-display-form + '((if dayname (concat dayname ", ")) day " " monthname " " year) + "*Pseudo-pattern governing the way a date appears in the European style. +See the documentation of calendar-date-display-form for an explanation.") + +;;;###autoload +(defvar american-calendar-display-form + '((if dayname (concat dayname ", ")) monthname " " day ", " year) + "*Pseudo-pattern governing the way a date appears in the American style. +See the documentation of `calendar-date-display-form' for an explanation.") + +(defvar calendar-date-display-form + (if european-calendar-style + european-calendar-display-form + american-calendar-display-form) + "*Pseudo-pattern governing the way a date appears. + +Used by the function `calendar-date-string', a pseudo-pattern is a list of +expressions that can involve the keywords `month', `day', and `year', all +numbers in string form, and `monthname' and `dayname', both alphabetic +strings. For example, the ISO standard would use the pseudo- pattern + + '(year \"-\" month \"-\" day) + +while a typical American form would be + + '(month \"/\" day \"/\" (substring year -2)) + +and + + '((format \"%9s, %9s %2s, %4s\" dayname monthname day year)) + +would give the usual American style in fixed-length fields. + +See the documentation of the function `calendar-date-string'.") + +(defun european-calendar () + "Set the interpretation and display of dates to the European style." + (interactive) + (setq european-calendar-style t) + (setq calendar-date-display-form european-calendar-display-form) + (setq diary-date-forms european-date-diary-pattern) + (update-calendar-mode-line)) + +(defun american-calendar () + "Set the interpretation and display of dates to the American style." + (interactive) + (setq european-calendar-style nil) + (setq calendar-date-display-form american-calendar-display-form) + (setq diary-date-forms american-date-diary-pattern) + (update-calendar-mode-line)) + +;;;###autoload +(defvar print-diary-entries-hook 'lpr-buffer + "*List of functions called after a temporary diary buffer is prepared. +The buffer shows only the diary entries currently visible in the diary +buffer. The default just does the printing. Other uses might include, for +example, rearranging the lines into order by day and time, saving the buffer +instead of deleting it, or changing the function used to do the printing.") + +;;;###autoload +(defvar list-diary-entries-hook nil + "*List of functions called after diary file is culled for relevant entries. +It is to be used for diary entries that are not found in the diary file. + +A function `include-other-diary-files' is provided for use as the value of +this hook. This function enables you to use shared diary files together +with your own. The files included are specified in the diary file by lines +of the form + + #include \"filename\" + +This is recursive; that is, #include directives in files thus included are +obeyed. You can change the \"#include\" to some other string by changing +the variable `diary-include-string'. When you use `include-other-diary-files' +as part of the list-diary-entries-hook, you will probably also want to use the +function `mark-included-diary-files' as part of `mark-diary-entries-hook'. + +For example, you could use + + (setq list-diary-entries-hook + '(include-other-diary-files sort-diary-entries)) + (setq diary-display-hook 'fancy-diary-display) + +in your `.emacs' file to cause the fancy diary buffer to be displayed with +diary entries from various included files, each day's entries sorted into +lexicographic order.") + +;;;###autoload +(defvar diary-hook nil + "*List of functions called after the display of the diary. +Can be used for appointment notification.") + +;;;###autoload +(defvar diary-display-hook nil + "*List of functions that handle the display of the diary. +If nil (the default), `simple-diary-display' is used. Use `ignore' for no +diary display. + +Ordinarily, this just displays the diary buffer (with holidays indicated in +the mode line), if there are any relevant entries. At the time these +functions are called, the variable `diary-entries-list' is a list, in order +by date, of all relevant diary entries in the form of ((MONTH DAY YEAR) +STRING), where string is the diary entry for the given date. This can be +used, for example, a different buffer for display (perhaps combined with +holidays), or produce hard copy output. + +A function `fancy-diary-display' is provided as an alternative +choice for this hook; this function prepares a special noneditable diary +buffer with the relevant diary entries that has neat day-by-day arrangement +with headings. The fancy diary buffer will show the holidays unless the +variable `holidays-in-diary-buffer' is set to nil. Ordinarily, the fancy +diary buffer will not show days for which there are no diary entries, even +if that day is a holiday; if you want such days to be shown in the fancy +diary buffer, set the variable `diary-list-include-blanks' to t.") + +;;;###autoload +(defvar nongregorian-diary-listing-hook nil + "*List of functions called for listing diary file and included files. +As the files are processed for diary entries, these functions are used to cull +relevant entries. You can use either or both of `list-hebrew-diary-entries' +and `list-islamic-diary-entries'. The documentation for these functions +describes the style of such diary entries.") + +;;;###autoload +(defvar mark-diary-entries-hook nil + "*List of functions called after marking diary entries in the calendar. + +A function `mark-included-diary-files' is also provided for use as the +mark-diary-entries-hook; it enables you to use shared diary files together +with your own. The files included are specified in the diary file by lines +of the form + #include \"filename\" +This is recursive; that is, #include directives in files thus included are +obeyed. You can change the \"#include\" to some other string by changing the +variable `diary-include-string'. When you use `mark-included-diary-files' as +part of the mark-diary-entries-hook, you will probably also want to use the +function `include-other-diary-files' as part of `list-diary-entries-hook'.") + +;;;###autoload +(defvar nongregorian-diary-marking-hook nil + "*List of functions called for marking diary file and included files. +As the files are processed for diary entries, these functions are used to cull +relevant entries. You can use either or both of `mark-hebrew-diary-entries' +and `mark-islamic-diary-entries'. The documentation for these functions +describes the style of such diary entries.") + +;;;###autoload +(defvar diary-list-include-blanks nil + "*If nil, do not include days with no diary entry in the list of diary entries. +Such days will then not be shown in the the fancy diary buffer, even if they +are holidays.") + +;;;###autoload +(defvar holidays-in-diary-buffer t + "*Non-nil means include holidays in the diary display. +The holidays appear in the mode line of the diary buffer, or in the +fancy diary buffer next to the date. This slows down the diary functions +somewhat; setting it to nil makes the diary display faster.") + +(defvar calendar-mark-ring nil) + +;;;###autoload +(put 'general-holidays 'risky-local-variable t) +;;;###autoload +(defvar general-holidays + '((holiday-fixed 1 1 "New Year's Day") + (holiday-float 1 1 3 "Martin Luther King Day") + (holiday-fixed 2 2 "Ground Hog Day") + (holiday-fixed 2 14 "Valentine's Day") + (holiday-float 2 1 3 "President's Day") + (holiday-fixed 3 17 "St. Patrick's Day") + (holiday-fixed 4 1 "April Fool's Day") + (holiday-float 5 0 2 "Mother's Day") + (holiday-float 5 1 -1 "Memorial Day") + (holiday-fixed 6 14 "Flag Day") + (holiday-float 6 0 3 "Father's Day") + (holiday-fixed 7 4 "Independence Day") + (holiday-float 9 1 1 "Labor Day") + (holiday-float 10 1 2 "Columbus Day") + (holiday-fixed 10 31 "Halloween") + (holiday-fixed 11 11 "Veteran's Day") + (holiday-float 11 4 4 "Thanksgiving")) + "*General holidays. Default value is for the United States. +See the documentation for `calendar-holidays' for details.") + +;;;###autoload +(put 'local-holidays 'risky-local-variable t) +;;;###autoload +(defvar local-holidays nil + "*Local holidays. +See the documentation for `calendar-holidays' for details.") + +;;;###autoload +(put 'other-holidays 'risky-local-variable t) +;;;###autoload +(defvar other-holidays nil + "*User defined holidays. +See the documentation for `calendar-holidays' for details.") + +;;;###autoload +(put 'hebrew-holidays-1 'risky-local-variable t) +;;;###autoload +(defvar hebrew-holidays-1 + '((holiday-rosh-hashanah-etc) + (if all-hebrew-calendar-holidays + (holiday-julian + 11 + (let* ((m displayed-month) + (y displayed-year) + (year)) + (increment-calendar-month m y -1) + (let ((year (extract-calendar-year + (calendar-julian-from-absolute + (calendar-absolute-from-gregorian + (list m 1 y)))))) + (if (zerop (% (1+ year) 4)) + 22 + 21))) "\"Tal Umatar\" (evening)")))) + +;;;###autoload +(put 'hebrew-holidays-2 'risky-local-variable t) +;;;###autoload +(defvar hebrew-holidays-2 + '((if all-hebrew-calendar-holidays + (holiday-hanukkah) + (holiday-hebrew 9 25 "Hanukkah")) + (if all-hebrew-calendar-holidays + (holiday-hebrew + 10 + (let ((h-year (extract-calendar-year + (calendar-hebrew-from-absolute + (calendar-absolute-from-gregorian + (list displayed-month 28 displayed-year)))))) + (if (= (% (calendar-absolute-from-hebrew (list 10 10 h-year)) + 7) + 6) + 11 10)) + "Tzom Teveth")) + (if all-hebrew-calendar-holidays + (holiday-hebrew 11 15 "Tu B'Shevat")))) + +;;;###autoload +(put 'hebrew-holidays-3 'risky-local-variable t) +;;;###autoload +(defvar hebrew-holidays-3 + '((if all-hebrew-calendar-holidays + (holiday-hebrew + 11 + (let ((m displayed-month) + (y displayed-year)) + (increment-calendar-month m y 1) + (let* ((h-year (extract-calendar-year + (calendar-hebrew-from-absolute + (calendar-absolute-from-gregorian + (list m + (calendar-last-day-of-month m y) + y))))) + (s-s + (calendar-hebrew-from-absolute + (if (= + (% (calendar-absolute-from-hebrew + (list 7 1 h-year)) + 7) + 6) + (calendar-dayname-on-or-before + 6 (calendar-absolute-from-hebrew + (list 11 17 h-year))) + (calendar-dayname-on-or-before + 6 (calendar-absolute-from-hebrew + (list 11 16 h-year)))))) + (day (extract-calendar-day s-s))) + day)) + "Shabbat Shirah")))) + +;;;###autoload +(put 'hebrew-holidays-4 'risky-local-variable t) +;;;###autoload +(defvar hebrew-holidays-4 + '((holiday-passover-etc) + (if (and all-hebrew-calendar-holidays + (let* ((m displayed-month) + (y displayed-year) + (year)) + (increment-calendar-month m y -1) + (let ((year (extract-calendar-year + (calendar-julian-from-absolute + (calendar-absolute-from-gregorian + (list m 1 y)))))) + (= 21 (% year 28))))) + (holiday-julian 3 26 "Kiddush HaHamah")) + (if all-hebrew-calendar-holidays + (holiday-tisha-b-av-etc)))) + +;;;###autoload +(put 'hebrew-holidays 'risky-local-variable t) +;;;###autoload +(defvar hebrew-holidays (append hebrew-holidays-1 hebrew-holidays-2 + hebrew-holidays-3 hebrew-holidays-4) + "*Jewish holidays. +See the documentation for `calendar-holidays' for details.") + +;;;###autoload +(put 'christian-holidays 'risky-local-variable t) +;;;###autoload +(defvar christian-holidays + '((if all-christian-calendar-holidays + (holiday-fixed 1 6 "Epiphany")) + (holiday-easter-etc) + (if all-christian-calendar-holidays + (holiday-greek-orthodox-easter)) + (if all-christian-calendar-holidays + (holiday-fixed 8 15 "Assumption")) + (if all-christian-calendar-holidays + (holiday-advent)) + (holiday-fixed 12 25 "Christmas") + (if all-christian-calendar-holidays + (holiday-julian 12 25 "Eastern Orthodox Christmas"))) + "*Christian holidays. +See the documentation for `calendar-holidays' for details.") + +;;;###autoload +(put 'islamic-holidays 'risky-local-variable t) +;;;###autoload +(defvar islamic-holidays + '((holiday-islamic + 1 1 + (format "Islamic New Year %d" + (let ((m displayed-month) + (y displayed-year)) + (increment-calendar-month m y 1) + (extract-calendar-year + (calendar-islamic-from-absolute + (calendar-absolute-from-gregorian + (list + m (calendar-last-day-of-month m y) y))))))) + (if all-islamic-calendar-holidays + (holiday-islamic 1 10 "Ashura")) + (if all-islamic-calendar-holidays + (holiday-islamic 3 12 "Mulad-al-Nabi")) + (if all-islamic-calendar-holidays + (holiday-islamic 7 26 "Shab-e-Mi'raj")) + (if all-islamic-calendar-holidays + (holiday-islamic 8 15 "Shab-e-Bara't")) + (holiday-islamic 9 1 "Ramadan Begins") + (if all-islamic-calendar-holidays + (holiday-islamic 9 27 "Shab-e Qadr")) + (if all-islamic-calendar-holidays + (holiday-islamic 10 1 "Id-al-Fitr")) + (if all-islamic-calendar-holidays + (holiday-islamic 12 10 "Id-al-Adha"))) + "*Islamic holidays. +See the documentation for `calendar-holidays' for details.") + +;;;###autoload +(put 'solar-holidays 'risky-local-variable t) +;;;###autoload +(defvar solar-holidays + '((if (fboundp 'atan) + (solar-equinoxes-solstices)) + (if (progn + (require 'cal-dst) + t) + (funcall + 'holiday-sexp + calendar-daylight-savings-starts + '(format "Daylight Savings Time Begins %s" + (if (fboundp 'atan) + (solar-time-string + (/ calendar-daylight-savings-starts-time (float 60)) + calendar-standard-time-zone-name) + "")))) + (funcall + 'holiday-sexp + calendar-daylight-savings-ends + '(format "Daylight Savings Time Ends %s" + (if (fboundp 'atan) + (solar-time-string + (/ calendar-daylight-savings-ends-time (float 60)) + calendar-daylight-time-zone-name) + "")))) + "*Sun-related holidays. +See the documentation for `calendar-holidays' for details.") + +;;;###autoload +(put 'calendar-holidays 'risky-local-variable t) +(defvar calendar-holidays + (append general-holidays local-holidays other-holidays + christian-holidays hebrew-holidays islamic-holidays + solar-holidays) + "*List of notable days for the command M-x holidays. + +Additional holidays are easy to add to the list, just put them in the list +`other-holidays' in your .emacs file. Similarly, by setting any of +`general-holidays', `local-holidays' `christian-holidays', `hebrew-holidays', +`islamic-holidays', or `solar-holidays' to nil in your .emacs file, you can +eliminate unwanted categories of holidays. The intention is that (in the US) +`local-holidays' be set in site-init.el and `other-holidays' be set by the +user. + +Entries on the list are expressions that return (possibly empty) lists of +items of the form ((month day year) string) of a holiday in the in the +three-month period centered around `displayed-month' of `displayed-year'. +Several basic functions are provided for this purpose: + + (holiday-fixed MONTH DAY STRING) is a fixed date on the Gregorian calendar + (holiday-float MONTH DAYNAME K STRING &optional day) is the Kth DAYNAME in + MONTH on the Gregorian calendar (0 for Sunday, + etc.); K<0 means count back from the end of the + month. An optional parameter DAY means the Kth + DAYNAME after/before MONTH DAY. + (holiday-hebrew MONTH DAY STRING) a fixed date on the Hebrew calendar + (holiday-islamic MONTH DAY STRING) a fixed date on the Islamic calendar + (holiday-julian MONTH DAY STRING) a fixed date on the Julian calendar + (holiday-sexp SEXP STRING) SEXP is a Gregorian-date-valued expression + in the variable `year'; if it evaluates to + a visible date, that's the holiday; if it + evaluates to nil, there's no holiday. STRING + is an expression in the variable `date'. + +For example, to add Bastille Day, celebrated in France on July 14, add + + (holiday-fixed 7 14 \"Bastille Day\") + +to the list. To add Hurricane Supplication Day, celebrated in the Virgin +Islands on the fourth Monday in August, add + + (holiday-float 8 1 4 \"Hurricane Supplication Day\") + +to the list (the last Monday would be specified with `-1' instead of `4'). +To add the last day of Hanukkah to the list, use + + (holiday-hebrew 10 2 \"Last day of Hanukkah\") + +since the Hebrew months are numbered with 1 starting from Nisan, while to +add the Islamic feast celebrating Mohammed's birthday use + + (holiday-islamic 3 12 \"Mohammed's Birthday\") + +since the Islamic months are numbered from 1 starting with Muharram. To +add Thomas Jefferson's birthday, April 2, 1743 (Julian), use + + (holiday-julian 4 2 \"Jefferson's Birthday\") + +To include a holiday conditionally, use the sexp form or a conditional. For +example, to include American presidential elections, which occur on the first +Tuesday after the first Monday in November of years divisible by 4, add + + (holiday-sexp + (if (zerop (% year 4)) + (calendar-gregorian-from-absolute + (1+ (calendar-dayname-on-or-before + 1 (+ 6 (calendar-absolute-from-gregorian + (list 11 1 year))))))) + \"US Presidential Election\") + +or + + (if (zerop (% displayed-year 4)) + (holiday-fixed 11 + (extract-calendar-day + (calendar-gregorian-from-absolute + (1+ (calendar-dayname-on-or-before + 1 (+ 6 (calendar-absolute-from-gregorian + (list 11 1 displayed-year))))))) + \"US Presidential Election\")) + +to the list. To include the phases of the moon, add + + (lunar-phases) + +to the holiday list, where `lunar-phases' is an Emacs-Lisp function that +you've written to return a (possibly empty) list of the relevant VISIBLE dates +with descriptive strings such as + + (((2 6 1989) \"New Moon\") ((2 12 1989) \"First Quarter Moon\") ... ).") + +(defconst calendar-buffer "*Calendar*" + "Name of the buffer used for the calendar.") + +(defconst holiday-buffer "*Holidays*" + "Name of the buffer used for the displaying the holidays.") + +(defconst fancy-diary-buffer "*Fancy Diary Entries*" + "Name of the buffer used for the optional fancy display of the diary.") + +(defconst lunar-phases-buffer "*Phases of Moon*" + "Name of the buffer used for the lunar phases.") + +(defmacro increment-calendar-month (mon yr n) + "Move the variables MON and YR to the month and year by N months. +Forward if N is positive or backward if N is negative." + (` (let (( macro-y (+ (* (, yr) 12) (, mon) -1 (, n) ))) + (setq (, mon) (1+ (% macro-y 12) )) + (setq (, yr) (/ macro-y 12))))) + +(defmacro calendar-for-loop (var from init to final do &rest body) + "Execute a for loop." + (` (let (( (, var) (1- (, init)) )) + (while (>= (, final) (setq (, var) (1+ (, var)))) + (,@ body))))) + +(defmacro calendar-sum (index initial condition expression) + "For INDEX = INITIAL et seq, as long as CONDITION holds, sum EXPRESSION." + (` (let (( (, index) (, initial)) + (sum 0)) + (while (, condition) + (setq sum (+ sum (, expression) )) + (setq (, index) (1+ (, index)))) + sum))) + +;; The following are in-line for speed; they can be called thousands of times +;; when looking up holidays or processing the diary. Here, for example, are +;; the numbers of calls to calendar/diary/holiday functions in preparing the +;; fancy diary display, for a moderately complex diary file, with functions +;; used instead of macros. There were a total of 10000 such calls: +;; +;; 1934 extract-calendar-month +;; 1852 extract-calendar-year +;; 1819 extract-calendar-day +;; 845 calendar-leap-year-p +;; 837 calendar-day-number +;; 775 calendar-absolute-from-gregorian +;; 346 calendar-last-day-of-month +;; 286 hebrew-calendar-last-day-of-month +;; 188 hebrew-calendar-leap-year-p +;; 180 hebrew-calendar-elapsed-days +;; 163 hebrew-calendar-last-month-of-year +;; 66 calendar-date-compare +;; 65 hebrew-calendar-days-in-year +;; 60 calendar-absolute-from-julian +;; 50 calendar-absolute-from-hebrew +;; 43 calendar-date-equal +;; 38 calendar-gregorian-from-absolute +;; . +;; . +;; . +;; +;; The use of these seven macros eliminates the overhead of 92% of the function +;; calls; it's faster this way. + +(defsubst extract-calendar-month (date) + "Extract the month part of DATE which has the form (month day year)." + (car date)) + +(defsubst extract-calendar-day (date) + "Extract the day part of DATE which has the form (month day year)." + (car (cdr date))) + +(defsubst extract-calendar-year (date) + "Extract the year part of DATE which has the form (month day year)." + (car (cdr (cdr date)))) + +(defsubst calendar-leap-year-p (year) + "Returns t if YEAR is a Gregorian leap year." + (and (zerop (% year 4)) + (or (not (zerop (% year 100))) + (zerop (% year 400))))) + +;; The foregoing is a bit faster, but not as clear as the following: +;; +;;(defsubst calendar-leap-year-p (year) +;; "Returns t if YEAR is a Gregorian leap year." +;; (or +;; (and (= (% year 4) 0) +;; (/= (% year 100) 0)) +;; (= (% year 400) 0))) + +(defsubst calendar-last-day-of-month (month year) + "The last day in MONTH during YEAR." + (if (and (= month 2) (calendar-leap-year-p year)) + 29 + (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) + +;; An explanation of the calculation can be found in PascAlgorithms by +;; Edward and Ruth Reingold, Scott-Foresman/Little, Brown, 1988. + +(defsubst calendar-day-number (date) + "Return the day number within the year of the date DATE. +For example, (calendar-day-number '(1 1 1987)) returns the value 1, +while (calendar-day-number '(12 31 1980)) returns 366." + (let* ((month (extract-calendar-month date)) + (day (extract-calendar-day date)) + (year (extract-calendar-year date)) + (day-of-year (+ day (* 31 (1- month))))) + (if (> month 2) + (progn + (setq day-of-year (- day-of-year (/ (+ 23 (* 4 month)) 10))) + (if (calendar-leap-year-p year) + (setq day-of-year (1+ day-of-year))))) + day-of-year)) + +(defsubst calendar-absolute-from-gregorian (date) + "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. +The Gregorian date Sunday, December 31, 1 BC is imaginary." + (let ((prior-years (1- (extract-calendar-year date)))) + (+ (calendar-day-number date);; Days this year + (* 365 prior-years);; + Days in prior years + (/ prior-years 4);; + Julian leap years + (- (/ prior-years 100));; - century years + (/ prior-years 400))));; + Gregorian leap years + +;;;###autoload +(defun calendar (&optional arg) + "Display a three-month calendar in another window. +The three months appear side by side, with the current month in the middle +surrounded by the previous and next months. The cursor is put on today's date. + +If called with an optional prefix argument, prompts for month and year. + +This function is suitable for execution in a .emacs file; appropriate setting +of the variable `view-diary-entries-initially' will cause the diary entries for +the current date to be displayed in another window. The value of the variable +`number-of-diary-entries' controls the number of days of diary entries +displayed upon initial display of the calendar. + +An optional prefix argument ARG causes the calendar displayed to be ARG +months in the future if ARG is positive or in the past if ARG is negative; +in this case the cursor goes on the first day of the month. + +Once in the calendar window, future or past months can be moved into view. +Arbitrary months can be displayed, or the calendar can be scrolled forward +or backward. + +The cursor can be moved forward or backward by one day, one week, one month, +or one year. All of these commands take prefix arguments which, when negative, +cause movement in the opposite direction. For convenience, the digit keys +and the minus sign are automatically prefixes. The window is replotted as +necessary to display the desired date. + +Diary entries can be marked on the calendar or displayed in another window. + +Use M-x describe-mode for details of the key bindings in the calendar window. + +The Gregorian calendar is assumed. + +After loading the calendar, the hooks given by the variable +`calendar-load-hook' are run. This is the place to add key bindings to the +calendar-mode-map. + +After preparing the calendar window initially, the hooks given by the variable +`initial-calendar-window-hook' are run. + +The hooks given by the variable `today-visible-calendar-hook' are run +everytime the calendar window gets scrolled, if the current date is visible +in the window. If it is not visible, the hooks given by the variable +`today-invisible-calendar-hook' are run. Thus, for example, setting +`today-visible-calendar-hook' to 'calendar-star-date will cause today's date +to be replaced by asterisks to highlight it whenever it is in the window." + (interactive "P") + (set-buffer (get-buffer-create calendar-buffer)) + (calendar-mode) + (let* ((pop-up-windows t) + (split-height-threshold 1000) + (date (if arg + (calendar-read-date t) + (calendar-current-date))) + (month (extract-calendar-month date)) + (year (extract-calendar-year date))) + (pop-to-buffer calendar-buffer) + (increment-calendar-month month year (- calendar-offset)) + (generate-calendar-window month year) + (if (and view-diary-entries-initially (calendar-date-is-visible-p date)) + (view-diary-entries + (if (vectorp number-of-diary-entries) + (aref number-of-diary-entries (calendar-day-of-week date)) + number-of-diary-entries)))) + (let* ((diary-buffer (get-file-buffer diary-file)) + (diary-window (if diary-buffer (get-buffer-window diary-buffer))) + (split-height-threshold (if diary-window 2 1000))) + (if view-calendar-holidays-initially + (list-calendar-holidays))) + (run-hooks 'initial-calendar-window-hook)) + +(autoload 'view-diary-entries "diary-lib" + "Prepare and display a buffer with diary entries. +Searches your diary file for entries that match ARG days starting with +the date indicated by the cursor position in the displayed three-month +calendar." + t) + +(autoload 'calendar-sunrise-sunset "solar" + "Local time of sunrise and sunset for date under cursor." + t) + +(autoload 'calendar-phases-of-moon "lunar" + "Create a buffer of the phases of the moon for the current calendar window." + t) + +(autoload 'calendar-print-french-date "cal-french" + "Show the French Revolutionary calendar equivalent of the date under the cursor." + t) + +(autoload 'calendar-goto-french-date "cal-french" + "Move cursor to French Revolutionary date." + t) + +(autoload 'calendar-french-date-string "cal-french" + "String of French Revolutionary date of Gregorian DATE." + t) + +(autoload 'calendar-mayan-date-string "cal-mayan" + "String of Mayan date of Gregorian DATE." + t) + +(autoload 'calendar-print-mayan-date "cal-mayan" + "Show the Mayan long count, Tzolkin, and Haab equivalents of the date under the cursor." + t) + +(autoload 'calendar-goto-mayan-long-count-date "cal-mayan" + "Move cursor to Mayan long count date." + t) + +(autoload 'calendar-next-haab-date "cal-mayan" + "Move cursor to next instance of Mayan Haab date." + t) + +(autoload 'calendar-previous-haab-date "cal-mayan" + "Move cursor to previous instance of Mayan Haab date." + t) + +(autoload 'calendar-next-tzolkin-date "cal-mayan" + "Move cursor to next instance of Mayan Tzolkin date." + t) + +(autoload 'calendar-previous-tzolkin-date "cal-mayan" + "Move cursor to previous instance of Mayan Tzolkin date." + t) + +(autoload 'calendar-next-calendar-round-date "cal-mayan" + "Move cursor to next instance of Mayan Haab/Tzoklin combination." + t) + +(autoload 'calendar-previous-calendar-round-date "cal-mayan" + "Move cursor to previous instance of Mayan Haab/Tzoklin combination." + t) + +(autoload 'show-all-diary-entries "diary-lib" + "Show all of the diary entries in the diary file. +This function gets rid of the selective display of the diary file so that +all entries, not just some, are visible. If there is no diary buffer, one +is created." + t) + +(autoload 'mark-diary-entries "diary-lib" + "Mark days in the calendar window that have diary entries. +Each entry in diary file visible in the calendar window is marked." + t) + +(autoload 'insert-diary-entry "diary-ins" + "Insert a diary entry for the date indicated by point." + t) + +(autoload 'insert-weekly-diary-entry "diary-ins" + "Insert a weekly diary entry for the day of the week indicated by point." + t) + + +(autoload 'insert-monthly-diary-entry "diary-ins" + "Insert a monthly diary entry for the day of the month indicated by point." + t) + +(autoload 'insert-yearly-diary-entry "diary-ins" + "Insert an annual diary entry for the day of the year indicated by point." + t) + +(autoload 'insert-anniversary-diary-entry "diary-ins" + "Insert an anniversary diary entry for the date indicated by point." + t) + +(autoload 'insert-block-diary-entry "diary-ins" + "Insert a block diary entry for the dates indicated by point and mark." + t) + +(autoload 'insert-cyclic-diary-entry "diary-ins" + "Insert a cyclic diary entry starting at the date indicated by point." + t) + +(autoload 'insert-hebrew-diary-entry "diary-ins" + "Insert a diary entry for the Hebrew date corresponding to the date +indicated by point." + t) + +(autoload 'insert-monthly-hebrew-diary-entry "diary-ins" + "Insert a monthly diary entry for the day of the Hebrew month corresponding +to the date indicated by point." + t) + +(autoload 'insert-yearly-hebrew-diary-entry "diary-ins" + "Insert an annual diary entry for the day of the Hebrew year corresponding +to the date indicated by point." + t) + +(autoload 'insert-islamic-diary-entry "diary-ins" + "Insert a diary entry for the Islamic date corresponding to the date +indicated by point." + t) + +(autoload 'insert-monthly-islamic-diary-entry "diary-ins" + "Insert a monthly diary entry for the day of the Islamic month corresponding +to the date indicated by point." + t) + +(autoload 'insert-yearly-islamic-diary-entry "diary-ins" + "Insert an annual diary entry for the day of the Islamic year corresponding +to the date indicated by point." + t) + +(autoload 'list-calendar-holidays "holidays" + "Create a buffer containing the holidays for the current calendar window. +The holidays are those in the list `calendar-notable-days'. Returns t if any +holidays are found, nil if not." + t) + +(autoload 'mark-calendar-holidays "holidays" + "Mark notable days in the calendar window." + t) + +(autoload 'calendar-cursor-holidays "holidays" + "Find holidays for the date specified by the cursor in the calendar window." + t) + +(defun generate-calendar-window (&optional mon yr) + "Generate the calendar window for the current date. +Or, for optional MON, YR." + (let* ((buffer-read-only nil) + (today (calendar-current-date)) + (month (extract-calendar-month today)) + (day (extract-calendar-day today)) + (year (extract-calendar-year today)) + (today-visible + (or (not mon) + (let ((offset (calendar-interval mon yr month year))) + (and (<= offset 1) (>= offset -1))))) + (day-in-week (calendar-day-of-week today))) + (update-calendar-mode-line) + (if mon + (generate-calendar mon yr) + (generate-calendar month year)) + (calendar-cursor-to-visible-date + (if today-visible today (list displayed-month 1 displayed-year))) + (set-buffer-modified-p nil) + (or (one-window-p t) + (/= (frame-width) (window-width)) + (shrink-window (- (window-height) 9))) + (sit-for 0) + (and mark-holidays-in-calendar + (mark-calendar-holidays) + (sit-for 0)) + (unwind-protect + (if mark-diary-entries-in-calendar (mark-diary-entries)) + (if today-visible + (run-hooks 'today-visible-calendar-hook) + (run-hooks 'today-invisible-calendar-hook))))) + +(defun generate-calendar (month year) + "Generate a three-month Gregorian calendar centered around MONTH, YEAR." + (if (< (+ month (* 12 (1- year))) 2) + (error "Months before February, 1 AD are not available.")) + (setq displayed-month month) + (setq displayed-year year) + (erase-buffer) + (increment-calendar-month month year -1) + (calendar-for-loop i from 0 to 2 do + (generate-calendar-month month year (+ 5 (* 25 i))) + (increment-calendar-month month year 1))) + +(defun generate-calendar-month (month year indent) + "Produce a calendar for MONTH, YEAR on the Gregorian calendar. +The calendar is inserted in the buffer starting at the line on which point +is currently located, but indented INDENT spaces. The indentation is done +from the first character on the line and does not disturb the first INDENT +characters on the line." + (let* ((blank-days;; at start of month + (mod + (- (calendar-day-of-week (list month 1 year)) + calendar-week-start-day) + 7)) + (last (calendar-last-day-of-month month year))) + (goto-char (point-min)) + (calendar-insert-indented + (calendar-string-spread + (list "" (format "%s %d" (calendar-month-name month) year) "") ? 20) + indent t) + (calendar-insert-indented "" indent);; Go to proper spot + (calendar-for-loop i from 0 to 6 do + (insert (substring (aref calendar-day-name-array + (mod (+ calendar-week-start-day i) 7)) + 0 2)) + (insert " ")) + (calendar-insert-indented "" 0 t);; Force onto following line + (calendar-insert-indented "" indent);; Go to proper spot + ;; Add blank days before the first of the month + (calendar-for-loop i from 1 to blank-days do (insert " ")) + ;; Put in the days of the month + (calendar-for-loop i from 1 to last do + (insert (format "%2d " i)) + (put-text-property (- (point) (if (< i 10) 2 3)) (1- (point)) + 'highlight t) + (and (zerop (mod (+ i blank-days) 7)) + (/= i last) + (calendar-insert-indented "" 0 t) ;; Force onto following line + (calendar-insert-indented "" indent)))));; Go to proper spot + +(defun calendar-insert-indented (string indent &optional newline) + "Insert STRING at column INDENT. +If the optional parameter NEWLINE is t, leave point at start of next line, +inserting a newline if there was no next line; otherwise, leave point after +the inserted text. Value is always t." + ;; Try to move to that column. + (move-to-column indent) + ;; If line is too short, indent out to that column. + (if (< (current-column) indent) + (indent-to indent)) + (insert string) + ;; Advance to next line, if requested. + (if newline + (progn + (end-of-line) + (if (eobp) + (newline) + (forward-line 1)))) + t) + +(defun redraw-calendar () + "Redraw the calendar display." + (interactive) + (let ((cursor-date (calendar-cursor-to-date))) + (generate-calendar-window displayed-month displayed-year) + (calendar-cursor-to-visible-date cursor-date))) + +(defvar calendar-debug-sexp nil + "*Turn debugging on when evaluating a sexp in the diary or holiday list.") + +(defvar calendar-mode-map nil) +(if calendar-mode-map + nil + (setq calendar-mode-map (make-sparse-keymap)) + (calendar-for-loop i from 0 to 9 do + (define-key calendar-mode-map (int-to-string i) 'digit-argument)) + (let ((l (list 'narrow-to-region 'mark-word 'mark-sexp 'mark-paragraph + 'mark-defun 'mark-whole-buffer 'mark-page + 'downcase-region 'upcase-region 'kill-region + 'copy-region-as-kill 'capitalize-region 'write-region))) + (while l + (substitute-key-definition (car l) 'calendar-not-implemented + calendar-mode-map) + (setq l (cdr l)))) + (define-key calendar-mode-map "-" 'negative-argument) + (define-key calendar-mode-map "\C-x>" 'scroll-calendar-right) + (define-key calendar-mode-map '[prior] 'scroll-calendar-right-three-months) + (define-key calendar-mode-map "\M-v" 'scroll-calendar-right-three-months) + (define-key calendar-mode-map "\C-x<" 'scroll-calendar-left) + (define-key calendar-mode-map '[next] 'scroll-calendar-left-three-months) + (define-key calendar-mode-map "\C-v" 'scroll-calendar-left-three-months) + (define-key calendar-mode-map "\C-b" 'calendar-backward-day) + (define-key calendar-mode-map "\C-p" 'calendar-backward-week) + (define-key calendar-mode-map "\M-{" 'calendar-backward-month) + (define-key calendar-mode-map "\C-x[" 'calendar-backward-year) + (define-key calendar-mode-map "\C-f" 'calendar-forward-day) + (define-key calendar-mode-map "\C-n" 'calendar-forward-week) + (define-key calendar-mode-map '[left] 'calendar-backward-day) + (define-key calendar-mode-map '[up] 'calendar-backward-week) + (define-key calendar-mode-map '[right] 'calendar-forward-day) + (define-key calendar-mode-map '[down] 'calendar-forward-week) + (define-key calendar-mode-map "\M-}" 'calendar-forward-month) + (define-key calendar-mode-map "\C-x]" 'calendar-forward-year) + (define-key calendar-mode-map "\C-a" 'calendar-beginning-of-week) + (define-key calendar-mode-map "\C-e" 'calendar-end-of-week) + (define-key calendar-mode-map "\M-a" 'calendar-beginning-of-month) + (define-key calendar-mode-map "\M-e" 'calendar-end-of-month) + (define-key calendar-mode-map "\M-<" 'calendar-beginning-of-year) + (define-key calendar-mode-map "\M->" 'calendar-end-of-year) + (define-key calendar-mode-map "\C-@" 'calendar-set-mark) + ;; Many people are used to typing C-SPC and getting C-@. + (define-key calendar-mode-map "\C- " 'calendar-set-mark) + (define-key calendar-mode-map "\C-x\C-x" 'calendar-exchange-point-and-mark) + (define-key calendar-mode-map "\M-=" 'calendar-count-days-region) + (define-key calendar-mode-map "gd" 'calendar-goto-date) + (define-key calendar-mode-map "gj" 'calendar-goto-julian-date) + (define-key calendar-mode-map "ga" 'calendar-goto-astro-day-number) + (define-key calendar-mode-map "gh" 'calendar-goto-hebrew-date) + (define-key calendar-mode-map "gi" 'calendar-goto-islamic-date) + (define-key calendar-mode-map "gc" 'calendar-goto-iso-date) + (define-key calendar-mode-map "gf" 'calendar-goto-french-date) + (define-key calendar-mode-map "gml" 'calendar-goto-mayan-long-count-date) + (define-key calendar-mode-map "gmpc" 'calendar-previous-calendar-round-date) + (define-key calendar-mode-map "gmnc" 'calendar-next-calendar-round-date) + (define-key calendar-mode-map "gmph" 'calendar-previous-haab-date) + (define-key calendar-mode-map "gmnh" 'calendar-next-haab-date) + (define-key calendar-mode-map "gmpt" 'calendar-previous-tzolkin-date) + (define-key calendar-mode-map "gmnt" 'calendar-next-tzolkin-date) + (define-key calendar-mode-map "S" 'calendar-sunrise-sunset) + (define-key calendar-mode-map "M" 'calendar-phases-of-moon) + (define-key calendar-mode-map " " 'scroll-other-window) + (define-key calendar-mode-map "\C-c\C-l" 'redraw-calendar) + (define-key calendar-mode-map "." 'calendar-goto-today) + (define-key calendar-mode-map "o" 'calendar-other-month) + (define-key calendar-mode-map "q" 'exit-calendar) + (define-key calendar-mode-map "a" 'list-calendar-holidays) + (define-key calendar-mode-map "h" 'calendar-cursor-holidays) + (define-key calendar-mode-map "x" 'mark-calendar-holidays) + (define-key calendar-mode-map "u" 'calendar-unmark) + (define-key calendar-mode-map "m" 'mark-diary-entries) + (define-key calendar-mode-map "d" 'view-diary-entries) + (define-key calendar-mode-map "D" 'view-other-diary-entries) + (define-key calendar-mode-map "s" 'show-all-diary-entries) + (define-key calendar-mode-map "pd" 'calendar-print-day-of-year) + (define-key calendar-mode-map "pc" 'calendar-print-iso-date) + (define-key calendar-mode-map "pj" 'calendar-print-julian-date) + (define-key calendar-mode-map "pa" 'calendar-print-astro-day-number) + (define-key calendar-mode-map "ph" 'calendar-print-hebrew-date) + (define-key calendar-mode-map "pi" 'calendar-print-islamic-date) + (define-key calendar-mode-map "pf" 'calendar-print-french-date) + (define-key calendar-mode-map "pm" 'calendar-print-mayan-date) + (define-key calendar-mode-map "id" 'insert-diary-entry) + (define-key calendar-mode-map "iw" 'insert-weekly-diary-entry) + (define-key calendar-mode-map "im" 'insert-monthly-diary-entry) + (define-key calendar-mode-map "iy" 'insert-yearly-diary-entry) + (define-key calendar-mode-map "ia" 'insert-anniversary-diary-entry) + (define-key calendar-mode-map "ib" 'insert-block-diary-entry) + (define-key calendar-mode-map "ic" 'insert-cyclic-diary-entry) + (define-key calendar-mode-map "ihd" 'insert-hebrew-diary-entry) + (define-key calendar-mode-map "ihm" 'insert-monthly-hebrew-diary-entry) + (define-key calendar-mode-map "ihy" 'insert-yearly-hebrew-diary-entry) + (define-key calendar-mode-map "iid" 'insert-islamic-diary-entry) + (define-key calendar-mode-map "iim" 'insert-monthly-islamic-diary-entry) + (define-key calendar-mode-map "iiy" 'insert-yearly-islamic-diary-entry) + (define-key calendar-mode-map "?" 'calendar-goto-info-node)) + +(defun describe-calendar-mode () + "Create a help buffer with a brief description of the calendar-mode." + (interactive) + (with-output-to-temp-buffer "*Help*" + (princ + (format + "Calendar Mode:\nFor a complete description, type %s\n%s\n" + (substitute-command-keys + "\\<calendar-mode-map>\\[describe-mode] from within the calendar") + (substitute-command-keys "\\{calendar-mode-map}"))) + (save-excursion + (set-buffer standard-output) + (help-mode)) + (print-help-return-message))) + +;; Calendar mode is suitable only for specially formatted data. +(put 'calendar-mode 'mode-class 'special) + +(defvar calendar-mode-line-format + (list + (substitute-command-keys "\\<calendar-mode-map>\\[scroll-calendar-left]") + "Calendar" + (substitute-command-keys "\\<calendar-mode-map>\\[calendar-goto-info-node] info/\\[calendar-other-month] other/\\[calendar-goto-today] today") + '(calendar-date-string (calendar-current-date) t) + (substitute-command-keys "\\<calendar-mode-map>\\[scroll-calendar-right]")) + "The mode line of the calendar buffer.") + +(defun calendar-goto-info-node () + "Go to the info node for the calendar." + (interactive) + (require 'info) + (let ((where (Info-find-emacs-command-nodes 'calendar))) + (if (not where) + (error "Couldn't find documentation for the calendar.") + (save-window-excursion (info)) + (pop-to-buffer "*info*") + (Info-find-node (car (car where)) (car (cdr (car where))))))) + +(defun calendar-mode () + "A major mode for the calendar window. + +For a complete description, type \ +\\<calendar-mode-map>\\[calendar-goto-info-node] from within the calendar. + +\\<calendar-mode-map>\\{calendar-mode-map}" + + (kill-all-local-variables) + (setq major-mode 'calendar-mode) + (setq mode-name "Calendar") + (use-local-map calendar-mode-map) + (setq buffer-read-only t) + (setq indent-tabs-mode nil) + (update-calendar-mode-line) + (if (and (string-match "XEmacs" emacs-version) current-menubar) + (progn + (require 'cal-xemacs) + (calendar-add-menus) + (make-variable-buffer-local 'scroll-on-clipped-lines) + (setq scroll-on-clipped-lines nil))) + (make-local-variable 'calendar-mark-ring) + (make-local-variable 'displayed-month);; Month in middle of window. + (make-local-variable 'displayed-year));; Year in middle of window. + +(defun calendar-string-spread (strings char length) + "Concatenate list of STRINGS separated with copies of CHAR to fill LENGTH +There must be at least 2 strings. The effect is like mapconcat but the +separating pieces are as balanced as possible. Each item of STRINGS is +evaluated before concatenation so it can actually be an expression that +evaluates to a string. If LENGTH is too short, the STRINGS are just +concatenated and the result truncated." +;; The algorithm is based on equation (3.25) on page 85 of Concrete +;; Mathematics by Ronald L. Graham, Donald E. Knuth, and Oren Patashnik, +;; Addison-Wesley, Reading, MA, 1989 + (let* ((strings (mapcar 'eval strings)) + (n (- length (length (apply 'concat strings)))) + (m (1- (length strings))) + (s (car strings)) + (strings (cdr strings)) + (i 0)) + (while strings + (setq s (concat s + (make-string (max 0 (/ (+ n i) m)) char) + (car strings))) + (setq i (1+ i)) + (setq strings (cdr strings))) + (substring s 0 length))) + +(defun update-calendar-mode-line () + "Update the calendar mode line with the current date and date style." + (if (bufferp (get-buffer calendar-buffer)) + (save-excursion + (set-buffer calendar-buffer) + (setq mode-line-format + (calendar-string-spread + calendar-mode-line-format ? (frame-width)))))) + +(defun calendar-window-list () + "List of all calendar-related windows." + (let ((calendar-buffers (calendar-buffer-list)) + list) + (walk-windows '(lambda (w) + (if (memq (window-buffer w) calendar-buffers) + (setq list (cons w list)))) + nil t) + list)) + +(defun calendar-buffer-list () + "List of all calendar-related buffers." + (let* ((diary-buffer (get-file-buffer diary-file)) + (buffers (list "*Yahrzeits*" lunar-phases-buffer holiday-buffer + fancy-diary-buffer diary-buffer calendar-buffer)) + (buffer-list nil) + b) + (while buffers + (setq b (car buffers)) + (setq b (cond ((stringp b) (get-buffer b)) + ((bufferp b) b) + (t nil))) + (if b (setq buffer-list (cons b buffer-list))) + (setq buffers (cdr buffers))) + buffer-list)) + +(defun exit-calendar () + "Get out of the calendar window and hide it and related buffers." + (interactive) + (let* ((diary-buffer (get-file-buffer diary-file))) + (if (and diary-buffer (buffer-modified-p diary-buffer) + (not + (yes-or-no-p + "Diary modified; do you really want to exit the calendar? "))) + (error) + ;; Need to do this multiple times because one time can replace some + ;; calendar-related buffers with other calendar-related buffers + (mapcar (lambda (x) + (mapcar 'calendar-hide-window (calendar-window-list))) + (calendar-window-list))))) + +(defun calendar-hide-window (window) + "Hide WINDOW if it is calendar-related." + (let ((buffer (if (window-live-p window) (window-buffer window)))) + (if (memq buffer (calendar-buffer-list)) + (cond + ((and window-system + (eq 'icon (cdr (assoc 'visibility + (frame-parameters + (window-frame window)))))) + nil) + ((and window-system (window-dedicated-p window)) + (iconify-frame (window-frame window))) + ((not (and (select-window window) (one-window-p window))) + (delete-window window)) + (t (set-buffer buffer) + (bury-buffer)))))) + +(defun calendar-goto-today () + "Reposition the calendar window so the current date is visible." + (interactive) + (let ((today (calendar-current-date)));; The date might have changed. + (if (not (calendar-date-is-visible-p today)) + (generate-calendar-window) + (update-calendar-mode-line) + (calendar-cursor-to-visible-date today)))) + +(defun calendar-forward-month (arg) + "Move the cursor forward ARG months. +Movement is backward if ARG is negative." + (interactive "p") + (calendar-cursor-to-nearest-date) + (let* ((cursor-date (calendar-cursor-to-date t)) + (month (extract-calendar-month cursor-date)) + (day (extract-calendar-day cursor-date)) + (year (extract-calendar-year cursor-date))) + (increment-calendar-month month year arg) + (let ((last (calendar-last-day-of-month month year))) + (if (< last day) + (setq day last))) + ;; Put the new month on the screen, if needed, and go to the new date. + (let ((new-cursor-date (list month day year))) + (if (not (calendar-date-is-visible-p new-cursor-date)) + (calendar-other-month month year)) + (calendar-cursor-to-visible-date new-cursor-date)))) + +(defun calendar-forward-year (arg) + "Move the cursor forward by ARG years. +Movement is backward if ARG is negative." + (interactive "p") + (calendar-forward-month (* 12 arg))) + +(defun calendar-backward-month (arg) + "Move the cursor backward by ARG months. +Movement is forward if ARG is negative." + (interactive "p") + (calendar-forward-month (- arg))) + +(defun calendar-backward-year (arg) + "Move the cursor backward ARG years. +Movement is forward is ARG is negative." + (interactive "p") + (calendar-forward-month (* -12 arg))) + +(defun scroll-calendar-left (arg) + "Scroll the displayed calendar left by ARG months. +If ARG is negative the calendar is scrolled right. Maintains the relative +position of the cursor with respect to the calendar as well as possible." + (interactive "p") + (calendar-cursor-to-nearest-date) + (let ((old-date (calendar-cursor-to-date)) + (today (calendar-current-date))) + (if (/= arg 0) + (progn + (increment-calendar-month displayed-month displayed-year arg) + (generate-calendar-window displayed-month displayed-year) + (calendar-cursor-to-visible-date + (cond + ((calendar-date-is-visible-p old-date) old-date) + ((calendar-date-is-visible-p today) today) + (t (list displayed-month 1 displayed-year)))))))) + +(defun scroll-calendar-right (arg) + "Scroll the displayed calendar window right by ARG months. +If ARG is negative the calendar is scrolled left. Maintains the relative +position of the cursor with respect to the calendar as well as possible." + (interactive "p") + (scroll-calendar-left (- arg))) + +(defun scroll-calendar-left-three-months (arg) + "Scroll the displayed calendar window left by 3*ARG months. +If ARG is negative the calendar is scrolled right. Maintains the relative +position of the cursor with respect to the calendar as well as possible." + (interactive "p") + (scroll-calendar-left (* 3 arg))) + +(defun scroll-calendar-right-three-months (arg) + "Scroll the displayed calendar window right by 3*ARG months. +If ARG is negative the calendar is scrolled left. Maintains the relative +position of the cursor with respect to the calendar as well as possible." + (interactive "p") + (scroll-calendar-left (* -3 arg))) + +(defun calendar-current-date () + "Returns the current date in a list (month day year)." + (let ((s (current-time-string))) + (list (length (member (substring s 4 7) + '("Dec" "Nov" "Oct" "Sep" "Aug" "Jul" + "Jun" "May" "Apr" "Mar" "Feb" "Jan"))) + (string-to-number (substring s 8 10)) + (string-to-number (substring s 20 24))))) + +(defun calendar-cursor-to-date (&optional error) + "Returns a list (month day year) of current cursor position. +If cursor is not on a specific date, signals an error if optional parameter +ERROR is t, otherwise just returns nil." + ;; #### This check is to avoid a race condition created by + ;; pop-to-buffer's call to other-window interacting with the 19.13 + ;; changes allowing that to be in another frame. + (if (not (number-or-marker-p displayed-month)) + nil + (let* ((segment (/ (current-column) 25)) + (month (% (+ displayed-month segment -1) 12)) + (month (if (= 0 month) 12 month)) + (year + (cond + ((and (= 12 month) (= segment 0)) (1- displayed-year)) + ((and (= 1 month) (= segment 2)) (1+ displayed-year)) + (t displayed-year)))) + (if (and (looking-at "[0-9]") + (< 2 (count-lines (point-min) (point)))) + (save-excursion + (re-search-backward "[^0-9]") + (list month + (string-to-int (buffer-substring (1+ (point)) (+ 4 (point)))) + year)) + (if (looking-at "\\*") + (save-excursion + (re-search-backward "[^*]") + (if (looking-at ".\\*\\*") + (list month calendar-starred-day year) + (if error (error "Not on a date!")))) + (if error (error "Not on a date!"))))))) + +(defun calendar-cursor-to-nearest-date () + "Move the cursor to the closest date. +The position of the cursor is unchanged if it is already on a date. +Returns the list (month day year) giving the cursor position." + (let ((date (calendar-cursor-to-date)) + (column (current-column))) + (if date + date + (if (> 3 (count-lines (point-min) (point))) + (progn + (goto-line 3) + (move-to-column column))) + (if (not (looking-at "[0-9]")) + (if (and (not (looking-at " *$")) + (or (< column 25) + (and (> column 27) + (< column 50)) + (and (> column 52) + (< column 75)))) + (progn + (re-search-forward "[0-9]" nil t) + (backward-char 1)) + (re-search-backward "[0-9]" nil t))) + (calendar-cursor-to-date)))) + +(defun calendar-forward-day (arg) + "Move the cursor forward ARG days. +Moves backward if ARG is negative." + (interactive "p") + (if (/= 0 arg) + (let* + ((cursor-date (calendar-cursor-to-date)) + (cursor-date (if cursor-date + cursor-date + (if (> arg 0) (setq arg (1- arg))) + (calendar-cursor-to-nearest-date))) + (new-cursor-date + (calendar-gregorian-from-absolute + (+ (calendar-absolute-from-gregorian cursor-date) arg))) + (new-display-month (extract-calendar-month new-cursor-date)) + (new-display-year (extract-calendar-year new-cursor-date))) + ;; Put the new month on the screen, if needed, and go to the new date. + (if (not (calendar-date-is-visible-p new-cursor-date)) + (calendar-other-month new-display-month new-display-year)) + (calendar-cursor-to-visible-date new-cursor-date)))) + +(defun calendar-backward-day (arg) + "Move the cursor back ARG days. +Moves forward if ARG is negative." + (interactive "p") + (calendar-forward-day (- arg))) + +(defun calendar-forward-week (arg) + "Move the cursor forward ARG weeks. +Moves backward if ARG is negative." + (interactive "p") + (calendar-forward-day (* arg 7))) + +(defun calendar-backward-week (arg) + "Move the cursor back ARG weeks. +Moves forward if ARG is negative." + (interactive "p") + (calendar-forward-day (* arg -7))) + +(defun calendar-beginning-of-week (arg) + "Move the cursor back ARG calendar-week-start-day's." + (interactive "p") + (calendar-cursor-to-nearest-date) + (let ((day (calendar-day-of-week (calendar-cursor-to-date)))) + (calendar-backward-day + (if (= day calendar-week-start-day) + (* 7 arg) + (+ (mod (- day calendar-week-start-day) 7) + (* 7 (1- arg))))))) + +(defun calendar-end-of-week (arg) + "Move the cursor forward ARG calendar-week-start-day+6's." + (interactive "p") + (calendar-cursor-to-nearest-date) + (let ((day (calendar-day-of-week (calendar-cursor-to-date)))) + (calendar-forward-day + (if (= day (mod (1- calendar-week-start-day) 7)) + (* 7 arg) + (+ (- 6 (mod (- day calendar-week-start-day) 7)) + (* 7 (1- arg))))))) + +(defun calendar-beginning-of-month (arg) + "Move the cursor backward ARG month beginnings." + (interactive "p") + (calendar-cursor-to-nearest-date) + (let* ((date (calendar-cursor-to-date)) + (month (extract-calendar-month date)) + (day (extract-calendar-day date)) + (year (extract-calendar-year date))) + (if (= day 1) + (calendar-backward-month arg) + (calendar-cursor-to-visible-date (list month 1 year)) + (calendar-backward-month (1- arg))))) + +(defun calendar-end-of-month (arg) + "Move the cursor forward ARG month ends." + (interactive "p") + (calendar-cursor-to-nearest-date) + (let* ((date (calendar-cursor-to-date)) + (month (extract-calendar-month date)) + (day (extract-calendar-day date)) + (year (extract-calendar-year date)) + (last-day (calendar-last-day-of-month month year))) + (if (/= day last-day) + (progn + (calendar-cursor-to-visible-date (list month last-day year)) + (setq arg (1- arg)))) + (increment-calendar-month month year arg) + (let ((last-day (list + month + (calendar-last-day-of-month month year) + year))) + (if (not (calendar-date-is-visible-p last-day)) + (calendar-other-month month year) + (calendar-cursor-to-visible-date last-day))))) + +(defun calendar-beginning-of-year (arg) + "Move the cursor backward ARG year beginnings." + (interactive "p") + (calendar-cursor-to-nearest-date) + (let* ((date (calendar-cursor-to-date)) + (month (extract-calendar-month date)) + (day (extract-calendar-day date)) + (year (extract-calendar-year date)) + (jan-first (list 1 1 year))) + (if (and (= day 1) (= 1 month)) + (calendar-backward-month (* 12 arg)) + (if (and (= arg 1) + (calendar-date-is-visible-p jan-first)) + (calendar-cursor-to-visible-date jan-first) + (calendar-other-month 1 (- year (1- arg))))))) + +(defun calendar-end-of-year (arg) + "Move the cursor forward ARG year beginnings." + (interactive "p") + (calendar-cursor-to-nearest-date) + (let* ((date (calendar-cursor-to-date)) + (month (extract-calendar-month date)) + (day (extract-calendar-day date)) + (year (extract-calendar-year date)) + (dec-31 (list 12 31 year))) + (if (and (= day 31) (= 12 month)) + (calendar-forward-month (* 12 arg)) + (if (and (= arg 1) + (calendar-date-is-visible-p dec-31)) + (calendar-cursor-to-visible-date dec-31) + (calendar-other-month 12 (- year (1- arg))) + (calendar-cursor-to-visible-date (list 12 31 displayed-year)))))) + +;; The following version of calendar-gregorian-from-absolute is preferred for +;; reasons of clarity, BUT it's much slower than the version that follows it. + +;;(defun calendar-gregorian-from-absolute (date) +;; "Compute the list (month day year) corresponding to the absolute DATE. +;;The absolute date is the number of days elapsed since the (imaginary) +;;Gregorian date Sunday, December 31, 1 BC." +;; (let* ((approx (/ date 366));; Approximation from below. +;; (year ;; Search forward from the approximation. +;; (+ approx +;; (calendar-sum y approx +;; (>= date (calendar-absolute-from-gregorian (list 1 1 (1+ y)))) +;; 1))) +;; (month ;; Search forward from January. +;; (1+ (calendar-sum m 1 +;; (> date +;; (calendar-absolute-from-gregorian +;; (list m (calendar-last-day-of-month m year) year))) +;; 1))) +;; (day ;; Calculate the day by subtraction. +;; (- date +;; (1- (calendar-absolute-from-gregorian (list month 1 year)))))) +;; (list month day year))) + +(defun calendar-gregorian-from-absolute (date) + "Compute the list (month day year) corresponding to the absolute DATE. +The absolute date is the number of days elapsed since the (imaginary) +Gregorian date Sunday, December 31, 1 BC." +;; See the footnote on page 384 of ``Calendrical Calculations, Part II: +;; Three Historical Calendars'' by E. M. Reingold, N. Dershowitz, and S. M. +;; Clamen, Software--Practice and Experience, Volume 23, Number 4 +;; (April, 1993), pages 383-404 for an explanation. + (let* ((d0 (1- date)) + (n400 (/ d0 146097)) + (d1 (% d0 146097)) + (n100 (/ d1 36524)) + (d2 (% d1 36524)) + (n4 (/ d2 1461)) + (d3 (% d2 1461)) + (n1 (/ d3 365)) + (day (1+ (% d3 365))) + (year (+ (* 400 n400) (* 100 n100) (* n4 4) n1))) + (if (or (= n100 4) (= n1 4)) + (list 12 31 year) + (let ((year (1+ year)) + (month 1)) + (while (let ((mdays (calendar-last-day-of-month month year))) + (and (< mdays day) + (setq day (- day mdays)))) + (setq month (1+ month))) + (list month day year))))) + +(defun calendar-cursor-to-visible-date (date) + "Move the cursor to DATE that is on the screen." + (let* ((month (extract-calendar-month date)) + (day (extract-calendar-day date)) + (year (extract-calendar-year date)) + (first-of-month-weekday (calendar-day-of-week (list month 1 year)))) + (goto-line (+ 3 + (/ (+ day -1 + (mod + (- (calendar-day-of-week (list month 1 year)) + calendar-week-start-day) + 7)) + 7))) + (move-to-column (+ 6 + (* 25 + (1+ (calendar-interval + displayed-month displayed-year month year))) + (* 3 (mod + (- (calendar-day-of-week date) + calendar-week-start-day) + 7)))))) + +(defun calendar-other-month (month year) + "Display a three-month calendar centered around MONTH and YEAR." + (interactive (calendar-read-date 'noday)) + (if (and (= month displayed-month) + (= year displayed-year)) + nil + (let ((old-date (calendar-cursor-to-date)) + (today (calendar-current-date))) + (generate-calendar-window month year) + (calendar-cursor-to-visible-date + (cond + ((calendar-date-is-visible-p old-date) old-date) + ((calendar-date-is-visible-p today) today) + (t (list month 1 year))))))) + +(defun calendar-set-mark (arg) + "Mark the date under the cursor, or jump to marked date. +With no prefix argument, push current date onto marked date ring. +With argument, jump to mark, pop it, and put point at end of ring." + (interactive "P") + (let ((date (calendar-cursor-to-date t))) + (if (null arg) + (progn + (setq calendar-mark-ring (cons date calendar-mark-ring)) + ;; Since the top of the mark ring is the marked date in the + ;; calendar, the mark ring in the calendar is one longer than + ;; in other buffers to get the same effect. + (if (> (length calendar-mark-ring) (1+ mark-ring-max)) + (setcdr (nthcdr mark-ring-max calendar-mark-ring) nil)) + (message "Mark set")) + (if (null calendar-mark-ring) + (error "No mark set in this buffer") + (calendar-goto-date (car calendar-mark-ring)) + (setq calendar-mark-ring + (cdr (nconc calendar-mark-ring (list date)))))))) + +(defun calendar-exchange-point-and-mark () + "Exchange the current cursor position with the marked date." + (interactive) + (let ((mark (car calendar-mark-ring)) + (date (calendar-cursor-to-date t))) + (if (null mark) + (error "No mark set in this buffer") + (setq calendar-mark-ring (cons date (cdr calendar-mark-ring))) + (calendar-goto-date mark)))) + +(defun calendar-count-days-region () + "Count the number of days (inclusive) between point and the mark." + (interactive) + (let* ((days (- (calendar-absolute-from-gregorian + (calendar-cursor-to-date t)) + (calendar-absolute-from-gregorian + (or (car calendar-mark-ring) + (error "No mark set in this buffer"))))) + (days (1+ (if (> days 0) days (- days))))) + (message "Region has %d day%s (inclusive)" + days (if (> days 1) "s" "")))) + +(defun calendar-not-implemented () + "Not implemented." + (interactive) + (error "%s not available in the calendar" + (global-key-binding (this-command-keys)))) + +(defun calendar-read (prompt acceptable &optional initial-contents) + "Return an object read from the minibuffer. +Prompt with the string PROMPT and use the function ACCEPTABLE to decide if +entered item is acceptable. If non-nil, optional third arg INITIAL-CONTENTS +is a string to insert in the minibuffer before reading." + (let ((value (read-minibuffer prompt initial-contents))) + (while (not (funcall acceptable value)) + (setq value (read-minibuffer prompt initial-contents))) + value)) + +(defun calendar-read-date (&optional noday) + "Prompt for Gregorian date. Returns a list (month day year). +If optional NODAY is t, does not ask for day, but just returns +(month nil year); if NODAY is any other non-nil value the value returned is +(month year) " + (let* ((year (calendar-read + "Year (>0): " + '(lambda (x) (> x 0)) + (int-to-string (extract-calendar-year + (calendar-current-date))))) + (month-array calendar-month-name-array) + (completion-ignore-case t) + (month (cdr (assoc + (capitalize + (completing-read + "Month name: " + (mapcar 'list (append month-array nil)) + nil t)) + (calendar-make-alist month-array 1 'capitalize)))) + (last (calendar-last-day-of-month month year))) + (if noday + (if (eq noday t) + (list month nil year) + (list month year)) + (list month + (calendar-read (format "Day (1-%d): " last) + '(lambda (x) (and (< 0 x) (<= x last)))) + year)))) + +(defun calendar-goto-date (date) + "Move cursor to DATE." + (interactive (list (calendar-read-date))) + (let ((month (extract-calendar-month date)) + (year (extract-calendar-year date))) + (if (not (calendar-date-is-visible-p date)) + (calendar-other-month + (if (and (= month 1) (= year 1)) + 2 + month) + year))) + (calendar-cursor-to-visible-date date)) + +(defun calendar-goto-julian-date (date &optional noecho) + "Move cursor to Julian DATE; echo Julian date unless NOECHO is t." + (interactive + (let* ((today (calendar-current-date)) + (year (calendar-read + "Julian calendar year (>0): " + '(lambda (x) (> x 0)) + (int-to-string + (extract-calendar-year + (calendar-julian-from-absolute + (calendar-absolute-from-gregorian + today)))))) + (month-array calendar-month-name-array) + (completion-ignore-case t) + (month (cdr (assoc + (capitalize + (completing-read + "Julian calendar month name: " + (mapcar 'list (append month-array nil)) + nil t)) + (calendar-make-alist month-array 1 'capitalize)))) + (last + (if (and (zerop (% year 4)) (= month 2)) + 29 + (aref [31 28 31 30 31 30 31 31 30 31 30 31] (1- month)))) + (day (calendar-read + (format "Julian calendar day (%d-%d): " + (if (and (= year 1) (= month 1)) 3 1) last) + '(lambda (x) + (and (< (if (and (= year 1) (= month 1)) 2 0) x) + (<= x last)))))) + (list (list month day year)))) + (calendar-goto-date (calendar-gregorian-from-absolute + (calendar-absolute-from-julian date))) + (or noecho (calendar-print-julian-date))) + +(defun calendar-goto-hebrew-date (date &optional noecho) + "Move cursor to Hebrew DATE; echo Hebrew date unless NOECHO is t." + (interactive + (let* ((today (calendar-current-date)) + (year (calendar-read + "Hebrew calendar year (>3760): " + '(lambda (x) (> x 3760)) + (int-to-string + (extract-calendar-year + (calendar-hebrew-from-absolute + (calendar-absolute-from-gregorian today)))))) + (month-array (if (hebrew-calendar-leap-year-p year) + calendar-hebrew-month-name-array-leap-year + calendar-hebrew-month-name-array-common-year)) + (completion-ignore-case t) + (month (cdr (assoc + (capitalize + (completing-read + "Hebrew calendar month name: " + (mapcar 'list (append month-array nil)) + (if (= year 3761) + '(lambda (x) + (let ((m (cdr + (assoc + (car x) + (calendar-make-alist + month-array))))) + (< 0 + (calendar-absolute-from-hebrew + (list m + (hebrew-calendar-last-day-of-month + m year) + year)))))) + + t)) + (calendar-make-alist month-array 1 'capitalize)))) + (last (hebrew-calendar-last-day-of-month month year)) + (first (if (and (= year 3761) (= month 10)) + 18 1)) + (day (calendar-read + (format "Hebrew calendar day (%d-%d): " + first last) + '(lambda (x) (and (<= first x) (<= x last)))))) + (list (list month day year)))) + (calendar-goto-date (calendar-gregorian-from-absolute + (calendar-absolute-from-hebrew date))) + (or noecho (calendar-print-hebrew-date))) + +(defun calendar-goto-islamic-date (date &optional noecho) + "Move cursor to Islamic DATE; echo Islamic date unless NOECHO is t." + (interactive + (let* ((today (calendar-current-date)) + (year (calendar-read + "Islamic calendar year (>0): " + '(lambda (x) (> x 0)) + (int-to-string + (extract-calendar-year + (calendar-islamic-from-absolute + (calendar-absolute-from-gregorian today)))))) + (month-array calendar-islamic-month-name-array) + (completion-ignore-case t) + (month (cdr (assoc + (capitalize + (completing-read + "Islamic calendar month name: " + (mapcar 'list (append month-array nil)) + nil t)) + (calendar-make-alist month-array 1 'capitalize)))) + (last (islamic-calendar-last-day-of-month month year)) + (day (calendar-read + (format "Islamic calendar day (1-%d): " last) + '(lambda (x) (and (< 0 x) (<= x last)))))) + (list (list month day year)))) + (calendar-goto-date (calendar-gregorian-from-absolute + (calendar-absolute-from-islamic date))) + (or noecho (calendar-print-islamic-date))) + +(defun calendar-goto-iso-date (date &optional noecho) + "Move cursor to ISO DATE; echo ISO date unless NOECHO is t." + (interactive + (let* ((today (calendar-current-date)) + (year (calendar-read + "ISO calendar year (>0): " + '(lambda (x) (> x 0)) + (int-to-string (extract-calendar-year today)))) + (no-weeks (extract-calendar-month + (calendar-iso-from-absolute + (1- + (calendar-dayname-on-or-before + 1 (calendar-absolute-from-gregorian + (list 1 4 (1+ year)))))))) + (week (calendar-read + (format "ISO calendar week (1-%d): " no-weeks) + '(lambda (x) (and (> x 0) (<= x no-weeks))))) + (day (calendar-read + "ISO day (1-7): " + '(lambda (x) (and (<= 1 x) (<= x 7)))))) + (list (list week day year)))) + (calendar-goto-date (calendar-gregorian-from-absolute + (calendar-absolute-from-iso date))) + (or noecho (calendar-print-iso-date))) + +(defun calendar-interval (mon1 yr1 mon2 yr2) + "The number of months difference between MON1, YR1 and MON2, YR2." + (+ (* 12 (- yr2 yr1)) + (- mon2 mon1))) + +(defun calendar-day-name (date) + "Returns a string with the name of the day of the week of DATE." + (aref calendar-day-name-array (calendar-day-of-week date))) + +(defvar calendar-day-name-array + ["Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"]) + +(defvar calendar-month-name-array + ["January" "February" "March" "April" "May" "June" + "July" "August" "September" "October" "November" "December"]) + +(defun calendar-make-alist (sequence &optional start-index filter) + "Make an assoc list corresponding to SEQUENCE. +Start at index 1, unless optional START-INDEX is provided. +If FILTER is provided, apply it to each item in the list." + (let ((index (if start-index (1- start-index) 0))) + (mapcar + '(lambda (x) + (setq index (1+ index)) + (cons (if filter (funcall filter x) x) + index)) + (append sequence nil)))) + +(defun calendar-month-name (month) + "The name of MONTH." + (aref calendar-month-name-array (1- month))) + +(defun calendar-day-of-week (date) + "Returns the day-of-the-week index of DATE, 0 for Sunday, 1 for Monday, etc." + (% (calendar-absolute-from-gregorian date) 7)) + +(defun calendar-unmark () + "Delete all diary/holiday marks/highlighting from the calendar." + (interactive) + (setq mark-holidays-in-calendar nil) + (setq mark-diary-entries-in-calendar nil) + (redraw-calendar)) + +(defun calendar-date-is-visible-p (date) + "Returns t if DATE is legal and is visible in the calendar window." + (let ((gap (calendar-interval + displayed-month displayed-year + (extract-calendar-month date) (extract-calendar-year date)))) + (and (calendar-date-is-legal-p date) (> 2 gap) (< -2 gap)))) + +(defun calendar-date-is-legal-p (date) + "Returns t if DATE is a legal date." + (let ((month (extract-calendar-month date)) + (day (extract-calendar-day date)) + (year (extract-calendar-year date))) + (and (<= 1 month) (<= month 12) + (<= 1 day) (<= day (calendar-last-day-of-month month year)) + (<= 1 year)))) + +(defun calendar-date-equal (date1 date2) + "Returns t if the DATE1 and DATE2 are the same." + (and + (= (extract-calendar-month date1) (extract-calendar-month date2)) + (= (extract-calendar-day date1) (extract-calendar-day date2)) + (= (extract-calendar-year date1) (extract-calendar-year date2)))) + +(defun mark-visible-calendar-date (date &optional mark) + "Mark DATE in the calendar window with MARK. +MARK is either a single-character string or a face. +MARK defaults to diary-entry-marker." + (if (calendar-date-is-legal-p date) + (save-excursion + (set-buffer calendar-buffer) + (calendar-cursor-to-visible-date date) + (let ((mark (or mark diary-entry-marker))) + (if (stringp mark) + (let ((buffer-read-only nil)) + (forward-char 1) + (delete-char 1) + (insert mark) + (forward-char -2)) + + (set-extent-property (make-extent (1- (point)) (1+ (point))) + 'face mark)))))) + +(defun calendar-star-date () + "Replace the date under the cursor in the calendar window with asterisks. +This function can be used with the today-visible-calendar-hook run after the +calendar window has been prepared." + (let ((buffer-read-only nil)) + (make-variable-buffer-local 'calendar-starred-day) + (forward-char 1) + (setq calendar-starred-day + (string-to-int + (buffer-substring (point) (- (point) 2)))) + (delete-char -2) + (insert "**") + (backward-char 1) + (set-buffer-modified-p nil))) + +(defun calendar-mark-today () + "Mark the date under the cursor in the calendar window. +The date is marked with calendar-today-marker. This function can be used with +the today-visible-calendar-hook run after the calendar window has been +prepared." + (mark-visible-calendar-date + (calendar-cursor-to-date) + calendar-today-marker)) + +(defun calendar-date-compare (date1 date2) + "Returns t if DATE1 is before DATE2, nil otherwise. +The actual dates are in the car of DATE1 and DATE2." + (< (calendar-absolute-from-gregorian (car date1)) + (calendar-absolute-from-gregorian (car date2)))) + +(defun calendar-date-string (date &optional abbreviate nodayname) + "A string form of DATE, driven by the variable `calendar-date-display-form'. +An optional parameter ABBREVIATE, when t, causes the month and day names to be +abbreviated to three characters. An optional parameter NODAYNAME, when t, +omits the name of the day of the week." + (let* ((dayname + (if nodayname + nil + (if abbreviate + (substring (calendar-day-name date) 0 3) + (calendar-day-name date)))) + (month (extract-calendar-month date)) + (monthname + (if abbreviate + (substring + (calendar-month-name month) 0 3) + (calendar-month-name month))) + (day (int-to-string (extract-calendar-day date))) + (month (int-to-string month)) + (year (int-to-string (extract-calendar-year date)))) + (mapconcat 'eval calendar-date-display-form ""))) + +(defun calendar-dayname-on-or-before (dayname date) + "Returns the absolute date of the DAYNAME on or before absolute DATE. +DAYNAME=0 means Sunday, DAYNAME=1 means Monday, and so on. + +Note: Applying this function to d+6 gives us the DAYNAME on or after an +absolute day d. Similarly, applying it to d+3 gives the DAYNAME nearest to +absolute date d, applying it to d-1 gives the DAYNAME previous to absolute +date d, and applying it to d+7 gives the DAYNAME following absolute date d." + (- date (% (- date dayname) 7))) + +(defun calendar-nth-named-absday (n dayname month year &optional day) + "The absolute date of Nth DAYNAME in MONTH, YEAR before/after optional DAY. +A DAYNAME of 0 means Sunday, 1 means Monday, and so on. If N<0, +return the Nth DAYNAME before MONTH DAY, YEAR (inclusive). +If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive). + +If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise." + (if (> n 0) + (+ (* 7 (1- n)) + (calendar-dayname-on-or-before + dayname + (+ 6 (calendar-absolute-from-gregorian + (list month (or day 1) year))))) + (+ (* 7 (1+ n)) + (calendar-dayname-on-or-before + dayname + (calendar-absolute-from-gregorian + (list month + (or day (calendar-last-day-of-month month year)) + year)))))) + +(defun calendar-nth-named-day (n dayname month year &optional day) + "The date of Nth DAYNAME in MONTH, YEAR before/after optional DAY. +A DAYNAME of 0 means Sunday, 1 means Monday, and so on. If N<0, +return the Nth DAYNAME before MONTH DAY, YEAR (inclusive). +If N>0, return the Nth DAYNAME after MONTH DAY, YEAR (inclusive). + +If DAY is omitted, it defaults to 1 if N>0, and MONTH's last day otherwise." + (calendar-gregorian-from-absolute + (calendar-nth-named-absday n dayname month year day))) + +(defun calendar-day-of-year-string (&optional date) + "String of day number of year of Gregorian DATE. +Defaults to today's date if DATE is not given." + (let* ((d (or date (calendar-current-date))) + (year (extract-calendar-year d)) + (day (calendar-day-number d)) + (days-remaining (- (calendar-day-number (list 12 31 year)) day))) + (format "Day %d of %d; %d day%s remaining in the year" + day year days-remaining (if (= days-remaining 1) "" "s")))) + +(defun calendar-print-day-of-year () + "Show day number in year/days remaining in year for date under the cursor." + (interactive) + (message (calendar-day-of-year-string (calendar-cursor-to-date t)))) + +(defun calendar-absolute-from-iso (date) + "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. +The `ISO year' corresponds approximately to the Gregorian year, but +weeks start on Monday and end on Sunday. The first week of the ISO year is +the first such week in which at least 4 days are in a year. The ISO +commercial DATE has the form (week day year) in which week is in the range +1..52 and day is in the range 0..6 (1 = Monday, 2 = Tuesday, ..., 0 = +Sunday). The Gregorian date Sunday, December 31, 1 BC is imaginary." + (let* ((week (extract-calendar-month date)) + (day (extract-calendar-day date)) + (year (extract-calendar-year date))) + (+ (calendar-dayname-on-or-before + 1 (+ 3 (calendar-absolute-from-gregorian (list 1 1 year)))) + (* 7 (1- week)) + (if (= day 0) 6 (1- day))))) + +(defun calendar-iso-from-absolute (date) + "Compute the `ISO commercial date' corresponding to the absolute DATE. +The ISO year corresponds approximately to the Gregorian year, but weeks +start on Monday and end on Sunday. The first week of the ISO year is the +first such week in which at least 4 days are in a year. The ISO commercial +date has the form (week day year) in which week is in the range 1..52 and +day is in the range 0..6 (1 = Monday, 2 = Tuesday, ..., 0 = Sunday). The +absolute date is the number of days elapsed since the (imaginary) Gregorian +date Sunday, December 31, 1 BC." + (let* ((approx (extract-calendar-year + (calendar-gregorian-from-absolute (- date 3)))) + (year (+ approx + (calendar-sum y approx + (>= date (calendar-absolute-from-iso (list 1 1 (1+ y)))) + 1)))) + (list + (1+ (/ (- date (calendar-absolute-from-iso (list 1 1 year))) 7)) + (% date 7) + year))) + +(defun calendar-iso-date-string (&optional date) + "String of ISO date of Gregorian DATE. +Defaults to today's date if DATE is not given." + (let* ((d (calendar-absolute-from-gregorian + (or date (calendar-current-date)))) + (day (% d 7)) + (iso-date (calendar-iso-from-absolute d))) + (format "Day %s of week %d of %d" + (if (zerop day) 7 day) + (extract-calendar-month iso-date) + (extract-calendar-year iso-date)))) + +(defun calendar-print-iso-date () + "Show equivalent ISO date for the date under the cursor." + (interactive) + (message "ISO date: %s" + (calendar-iso-date-string (calendar-cursor-to-date t)))) + +(defun calendar-julian-from-absolute (date) + "Compute the Julian (month day year) corresponding to the absolute DATE. +The absolute date is the number of days elapsed since the (imaginary) +Gregorian date Sunday, December 31, 1 BC." + (let* ((approx (/ (+ date 2) 366));; Approximation from below. + (year ;; Search forward from the approximation. + (+ approx + (calendar-sum y approx + (>= date (calendar-absolute-from-julian (list 1 1 (1+ y)))) + 1))) + (month ;; Search forward from January. + (1+ (calendar-sum m 1 + (> date + (calendar-absolute-from-julian + (list m + (if (and (= m 2) (= (% year 4) 0)) + 29 + (aref [31 28 31 30 31 30 31 31 30 31 30 31] + (1- m))) + year))) + 1))) + (day ;; Calculate the day by subtraction. + (- date (1- (calendar-absolute-from-julian (list month 1 year)))))) + (list month day year))) + +(defun calendar-absolute-from-julian (date) + "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. +The Gregorian date Sunday, December 31, 1 BC is imaginary." + (let ((month (extract-calendar-month date)) + (day (extract-calendar-day date)) + (year (extract-calendar-year date))) + (+ (calendar-day-number date) + (if (and (= (% year 100) 0) + (/= (% year 400) 0) + (> month 2)) + 1 0);; Correct for Julian but not Gregorian leap year. + (* 365 (1- year)) + (/ (1- year) 4) + -2))) + +(defun calendar-julian-date-string (&optional date) + "String of Julian date of Gregorian DATE. +Defaults to today's date if DATE is not given. +Driven by the variable `calendar-date-display-form'." + (calendar-date-string + (calendar-julian-from-absolute + (calendar-absolute-from-gregorian + (or date (calendar-current-date)))) + nil t)) + +(defun calendar-print-julian-date () + "Show the Julian calendar equivalent of the date under the cursor." + (interactive) + (message "Julian date: %s" + (calendar-julian-date-string (calendar-cursor-to-date t)))) + +(defun islamic-calendar-leap-year-p (year) + "Returns t if YEAR is a leap year on the Islamic calendar." + (memq (% year 30) + (list 2 5 7 10 13 16 18 21 24 26 29))) + +(defun islamic-calendar-last-day-of-month (month year) + "The last day in MONTH during YEAR on the Islamic calendar." + (cond + ((memq month (list 1 3 5 7 9 11)) 30) + ((memq month (list 2 4 6 8 10)) 29) + (t (if (islamic-calendar-leap-year-p year) 30 29)))) + +(defun islamic-calendar-day-number (date) + "Return the day number within the year of the Islamic date DATE." + (let* ((month (extract-calendar-month date)) + (day (extract-calendar-day date))) + (+ (* 30 (/ month 2)) + (* 29 (/ (1- month) 2)) + day))) + +(defun calendar-absolute-from-islamic (date) + "Absolute date of Islamic DATE. +The absolute date is the number of days elapsed since the (imaginary) +Gregorian date Sunday, December 31, 1 BC." + (let* ((month (extract-calendar-month date)) + (day (extract-calendar-day date)) + (year (extract-calendar-year date)) + (y (% year 30)) + (leap-years-in-cycle + (cond + ((< y 3) 0) ((< y 6) 1) ((< y 8) 2) ((< y 11) 3) ((< y 14) 4) + ((< y 17) 5) ((< y 19) 6) ((< y 22) 7) ((< y 25) 8) ((< y 27) 9) + (t 10)))) + (+ (islamic-calendar-day-number date);; days so far this year + (* (1- year) 354) ;; days in all non-leap years + (* 11 (/ year 30)) ;; leap days in complete cycles + leap-years-in-cycle ;; leap days this cycle + 227014))) ;; days before start of calendar + +(defun calendar-islamic-from-absolute (date) + "Compute the Islamic date (month day year) corresponding to absolute DATE. +The absolute date is the number of days elapsed since the (imaginary) +Gregorian date Sunday, December 31, 1 BC." + (if (< date 227015) + (list 0 0 0);; pre-Islamic date + (let* ((approx (/ (- date 227014) 355));; Approximation from below. + (year ;; Search forward from the approximation. + (+ approx + (calendar-sum y approx + (>= date (calendar-absolute-from-islamic + (list 1 1 (1+ y)))) + 1))) + (month ;; Search forward from Muharram. + (1+ (calendar-sum m 1 + (> date + (calendar-absolute-from-islamic + (list m + (islamic-calendar-last-day-of-month + m year) + year))) + 1))) + (day ;; Calculate the day by subtraction. + (- date + (1- (calendar-absolute-from-islamic (list month 1 year)))))) + (list month day year)))) + +(defvar calendar-islamic-month-name-array + ["Muharram" "Safar" "Rabi I" "Rabi II" "Jumada I" "Jumada II" + "Rajab" "Sha'ban" "Ramadan" "Shawwal" "Dhu al-Qada" "Dhu al-Hijjah"]) + +(defun calendar-islamic-date-string (&optional date) + "String of Islamic date before sunset of Gregorian DATE. +Returns the empty string if DATE is pre-Islamic. +Defaults to today's date if DATE is not given. +Driven by the variable `calendar-date-display-form'." + (let ((calendar-month-name-array calendar-islamic-month-name-array) + (islamic-date (calendar-islamic-from-absolute + (calendar-absolute-from-gregorian + (or date (calendar-current-date)))))) + (if (< (extract-calendar-year islamic-date) 1) + "" + (calendar-date-string islamic-date nil t)))) + +(defun calendar-print-islamic-date () + "Show the Islamic calendar equivalent of the date under the cursor." + (interactive) + (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t)))) + (if (string-equal i "") + (message "Date is pre-Islamic") + (message "Islamic date (until sunset): %s" i)))) + +(defun calendar-hebrew-from-absolute (date) + "Compute the Hebrew date (month day year) corresponding to absolute DATE. +The absolute date is the number of days elapsed since the (imaginary) +Gregorian date Sunday, December 31, 1 BC." + (let* ((greg-date (calendar-gregorian-from-absolute date)) + (month (aref [9 10 11 12 1 2 3 4 7 7 7 8] + (1- (extract-calendar-month greg-date)))) + (day) + (year (+ 3760 (extract-calendar-year greg-date)))) + (while (>= date (calendar-absolute-from-hebrew (list 7 1 (1+ year)))) + (setq year (1+ year))) + (let ((length (hebrew-calendar-last-month-of-year year))) + (while (> date + (calendar-absolute-from-hebrew + (list month + (hebrew-calendar-last-day-of-month month year) + year))) + (setq month (1+ (% month length))))) + (setq day (1+ + (- date (calendar-absolute-from-hebrew (list month 1 year))))) + (list month day year))) + +(defun hebrew-calendar-leap-year-p (year) + "t if YEAR is a Hebrew calendar leap year." + (< (% (1+ (* 7 year)) 19) 7)) + +(defun hebrew-calendar-last-month-of-year (year) + "The last month of the Hebrew calendar YEAR." + (if (hebrew-calendar-leap-year-p year) + 13 + 12)) + +(defun hebrew-calendar-last-day-of-month (month year) + "The last day of MONTH in YEAR." + (if (or (memq month (list 2 4 6 10 13)) + (and (= month 12) (not (hebrew-calendar-leap-year-p year))) + (and (= month 8) (not (hebrew-calendar-long-heshvan-p year))) + (and (= month 9) (hebrew-calendar-short-kislev-p year))) + 29 + 30)) + +(defun hebrew-calendar-elapsed-days (year) + "Days from Sun. prior to start of Hebrew calendar to mean conjunction of Tishri of Hebrew YEAR." + (let* ((months-elapsed + (+ (* 235 (/ (1- year) 19));; Months in complete cycles so far. + (* 12 (% (1- year) 19)) ;; Regular months in this cycle + (/ (1+ (* 7 (% (1- year) 19))) 19)));; Leap months this cycle + (parts-elapsed (+ 204 (* 793 (% months-elapsed 1080)))) + (hours-elapsed (+ 5 + (* 12 months-elapsed) + (* 793 (/ months-elapsed 1080)) + (/ parts-elapsed 1080))) + (parts ;; Conjunction parts + (+ (* 1080 (% hours-elapsed 24)) (% parts-elapsed 1080))) + (day ;; Conjunction day + (+ 1 (* 29 months-elapsed) (/ hours-elapsed 24))) + (alternative-day + (if (or (>= parts 19440) ;; If the new moon is at or after midday, + (and (= (% day 7) 2);; ...or is on a Tuesday... + (>= parts 9924) ;; at 9 hours, 204 parts or later... + (not (hebrew-calendar-leap-year-p year)));; of a + ;; common year, + (and (= (% day 7) 1);; ...or is on a Monday... + (>= parts 16789) ;; at 15 hours, 589 parts or later... + (hebrew-calendar-leap-year-p (1- year))));; at the end + ;; of a leap year + ;; Then postpone Rosh HaShanah one day + (1+ day) + ;; Else + day))) + (if ;; If Rosh HaShanah would occur on Sunday, Wednesday, or Friday + (memq (% alternative-day 7) (list 0 3 5)) + ;; Then postpone it one (more) day and return + (1+ alternative-day) + ;; Else return + alternative-day))) + +(defun hebrew-calendar-days-in-year (year) + "Number of days in Hebrew YEAR." + (- (hebrew-calendar-elapsed-days (1+ year)) + (hebrew-calendar-elapsed-days year))) + +(defun hebrew-calendar-long-heshvan-p (year) + "t if Heshvan is long in Hebrew YEAR." + (= (% (hebrew-calendar-days-in-year year) 10) 5)) + +(defun hebrew-calendar-short-kislev-p (year) + "t if Kislev is short in Hebrew YEAR." + (= (% (hebrew-calendar-days-in-year year) 10) 3)) + +(defun calendar-absolute-from-hebrew (date) + "Absolute date of Hebrew DATE. +The absolute date is the number of days elapsed since the (imaginary) +Gregorian date Sunday, December 31, 1 BC." + (let* ((month (extract-calendar-month date)) + (day (extract-calendar-day date)) + (year (extract-calendar-year date))) + (+ day ;; Days so far this month. + (if (< month 7);; before Tishri + ;; Then add days in prior months this year before and after Nisan + (+ (calendar-sum + m 7 (<= m (hebrew-calendar-last-month-of-year year)) + (hebrew-calendar-last-day-of-month m year)) + (calendar-sum + m 1 (< m month) + (hebrew-calendar-last-day-of-month m year))) + ;; Else add days in prior months this year + (calendar-sum + m 7 (< m month) + (hebrew-calendar-last-day-of-month m year))) + (hebrew-calendar-elapsed-days year);; Days in prior years. + -1373429))) ;; Days elapsed before absolute date 1. + +(defvar calendar-hebrew-month-name-array-common-year + ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri" + "Heshvan" "Kislev" "Teveth" "Shevat" "Adar"]) + +(defvar calendar-hebrew-month-name-array-leap-year + ["Nisan" "Iyar" "Sivan" "Tammuz" "Av" "Elul" "Tishri" + "Heshvan" "Kislev" "Teveth" "Shevat" "Adar I" "Adar II"]) + +(defun calendar-hebrew-date-string (&optional date) + "String of Hebrew date before sunset of Gregorian DATE. +Defaults to today's date if DATE is not given. +Driven by the variable `calendar-date-display-form'." + (let* ((hebrew-date (calendar-hebrew-from-absolute + (calendar-absolute-from-gregorian + (or date (calendar-current-date))))) + (calendar-month-name-array + (if (hebrew-calendar-leap-year-p (extract-calendar-year hebrew-date)) + calendar-hebrew-month-name-array-leap-year + calendar-hebrew-month-name-array-common-year))) + (calendar-date-string hebrew-date nil t))) + +(defun calendar-print-hebrew-date () + "Show the Hebrew calendar equivalent of the date under the cursor." + (interactive) + (message "Hebrew date (until sunset): %s" + (calendar-hebrew-date-string (calendar-cursor-to-date t)))) + +(defun hebrew-calendar-yahrzeit (death-date year) + "Absolute date of the anniversary of Hebrew DEATH-DATE in Hebrew YEAR." + (let* ((death-day (extract-calendar-day death-date)) + (death-month (extract-calendar-month death-date)) + (death-year (extract-calendar-year death-date))) + (cond + ;; If it's Heshvan 30 it depends on the first anniversary; if + ;; that was not Heshvan 30, use the day before Kislev 1. + ((and (= death-month 8) + (= death-day 30) + (not (hebrew-calendar-long-heshvan-p (1+ death-year)))) + (1- (calendar-absolute-from-hebrew (list 9 1 year)))) + ;; If it's Kislev 30 it depends on the first anniversary; if + ;; that was not Kislev 30, use the day before Teveth 1. + ((and (= death-month 9) + (= death-day 30) + (hebrew-calendar-short-kislev-p (1+ death-year))) + (1- (calendar-absolute-from-hebrew (list 10 1 year)))) + ;; If it's Adar II, use the same day in last month of + ;; year (Adar or Adar II). + ((= death-month 13) + (calendar-absolute-from-hebrew + (list (hebrew-calendar-last-month-of-year year) death-day year))) + ;; If it's the 30th in Adar I and year is not a leap year + ;; (so Adar has only 29 days), use the last day in Shevat. + ((and (= death-day 30) + (= death-month 12) + (not (hebrew-calendar-leap-year-p year))) + (calendar-absolute-from-hebrew (list 11 30 year))) + ;; In all other cases, use the normal anniversary of the date of death. + (t (calendar-absolute-from-hebrew + (list death-month death-day year)))))) + +(defun calendar-set-mode-line (str) + "Set mode line to STR, centered, surrounded by dashes." + (setq mode-line-format + (calendar-string-spread (list "" str "") ?- (frame-width)))) + +;;;###autoload +(defun list-yahrzeit-dates (death-date start-year end-year) + "List Yahrzeit dates for *Gregorian* DEATH-DATE from START-YEAR to END-YEAR. +When called interactively from the calendar window, the date of death is taken +from the cursor position." + (interactive + (let* ((death-date + (if (equal (current-buffer) (get-buffer calendar-buffer)) + (calendar-cursor-to-date) + (let* ((today (calendar-current-date)) + (year (calendar-read + "Year of death (>0): " + '(lambda (x) (> x 0)) + (int-to-string (extract-calendar-year today)))) + (month-array calendar-month-name-array) + (completion-ignore-case t) + (month (cdr (assoc + (capitalize + (completing-read + "Month of death (name): " + (mapcar 'list (append month-array nil)) + nil t)) + (calendar-make-alist + month-array 1 'capitalize)))) + (last (calendar-last-day-of-month month year)) + (day (calendar-read + (format "Day of death (1-%d): " last) + '(lambda (x) (and (< 0 x) (<= x last)))))) + (list month day year)))) + (death-year (extract-calendar-year death-date)) + (start-year (calendar-read + (format "Starting year of Yahrzeit table (>%d): " + death-year) + '(lambda (x) (> x death-year)) + (int-to-string (1+ death-year)))) + (end-year (calendar-read + (format "Ending year of Yahrzeit table (>=%d): " + start-year) + '(lambda (x) (>= x start-year))))) + (list death-date start-year end-year))) + (message "Computing yahrzeits...") + (let* ((yahrzeit-buffer "*Yahrzeits*") + (h-date (calendar-hebrew-from-absolute + (calendar-absolute-from-gregorian death-date))) + (h-month (extract-calendar-month h-date)) + (h-day (extract-calendar-day h-date)) + (h-year (extract-calendar-year h-date))) + (set-buffer (get-buffer-create yahrzeit-buffer)) + (setq buffer-read-only nil) + (calendar-set-mode-line + (format "Yahrzeit dates for %s = %s" + (calendar-date-string death-date) + (let ((calendar-month-name-array + (if (hebrew-calendar-leap-year-p h-year) + calendar-hebrew-month-name-array-leap-year + calendar-hebrew-month-name-array-common-year))) + (calendar-date-string h-date nil t)))) + (erase-buffer) + (goto-char (point-min)) + (calendar-for-loop i from start-year to end-year do + (insert + (calendar-date-string + (calendar-gregorian-from-absolute + (hebrew-calendar-yahrzeit + h-date + (extract-calendar-year + (calendar-hebrew-from-absolute + (calendar-absolute-from-gregorian (list 1 1 i))))))) "\n")) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (setq buffer-read-only t) + (display-buffer yahrzeit-buffer) + (message "Computing yahrzeits...done"))) + +(defun calendar-astro-date-string (&optional date) + "String of astronomical (Julian) day number of afternoon of Gregorian DATE. +Defaults to today's date if DATE is not given." + (int-to-string + (+ 1721425 (calendar-absolute-from-gregorian + (or date (calendar-current-date)))))) + +(defun calendar-print-astro-day-number () + "Show astronomical (Julian) day number of afternoon on date shown by cursor." + (interactive) + (message + "Astronomical (Julian) day number after noon UTC: %s" + (calendar-astro-date-string (calendar-cursor-to-date t)))) + +(defun calendar-goto-astro-day-number (daynumber &optional noecho) + "Move cursor to astronomical (Julian) DAYNUMBER. +Echo astronomical (Julian) day number unless NOECHO is t." + (interactive (list (calendar-read + "Astronomical (Julian) day number (>1721425): " + '(lambda (x) (> x 1721425))))) + (calendar-goto-date (calendar-gregorian-from-absolute (- daynumber 1721425))) + (or noecho (calendar-print-astro-day-number))) + +(run-hooks 'calendar-load-hook) + +(provide 'calendar) + +;;; calendar.el ends here