diff options
| author | Ulrich Drepper <drepper@redhat.com> | 1997-04-18 00:57:04 +0000 |
|---|---|---|
| committer | Ulrich Drepper <drepper@redhat.com> | 1997-04-18 00:57:04 +0000 |
| commit | f0a39e37f1bd7bcc8d6988345df5870d91c92cce (patch) | |
| tree | 063fa517655b571179bcd74d8719409852b25477 /lisp/calendar | |
| parent | 2b385e3555b76372ce8e19020673854a46a5ac63 (diff) | |
| download | emacs-f0a39e37f1bd7bcc8d6988345df5870d91c92cce.tar.gz | |
update from main archive 970417libc20x-970417glibc-2_0_4
Diffstat (limited to 'lisp/calendar')
| -rw-r--r-- | lisp/calendar/appt.el | 600 | ||||
| -rw-r--r-- | lisp/calendar/cal-china.el | 455 | ||||
| -rw-r--r-- | lisp/calendar/cal-coptic.el | 234 | ||||
| -rw-r--r-- | lisp/calendar/cal-dst.el | 397 | ||||
| -rw-r--r-- | lisp/calendar/cal-french.el | 244 | ||||
| -rw-r--r-- | lisp/calendar/cal-hebrew.el | 1180 | ||||
| -rw-r--r-- | lisp/calendar/cal-islam.el | 492 | ||||
| -rw-r--r-- | lisp/calendar/cal-iso.el | 126 | ||||
| -rw-r--r-- | lisp/calendar/cal-julian.el | 207 | ||||
| -rw-r--r-- | lisp/calendar/cal-mayan.el | 382 | ||||
| -rw-r--r-- | lisp/calendar/cal-menu.el | 523 | ||||
| -rw-r--r-- | lisp/calendar/cal-move.el | 315 | ||||
| -rw-r--r-- | lisp/calendar/cal-persia.el | 206 | ||||
| -rw-r--r-- | lisp/calendar/cal-tex.el | 1608 | ||||
| -rw-r--r-- | lisp/calendar/cal-x.el | 143 | ||||
| -rw-r--r-- | lisp/calendar/calendar.el | 2336 | ||||
| -rw-r--r-- | lisp/calendar/diary-lib.el | 1392 | ||||
| -rw-r--r-- | lisp/calendar/holidays.el | 384 | ||||
| -rw-r--r-- | lisp/calendar/lunar.el | 391 | ||||
| -rw-r--r-- | lisp/calendar/solar.el | 1045 |
20 files changed, 0 insertions, 12660 deletions
diff --git a/lisp/calendar/appt.el b/lisp/calendar/appt.el deleted file mode 100644 index e5fe7d05428..00000000000 --- a/lisp/calendar/appt.el +++ /dev/null @@ -1,600 +0,0 @@ -;;; appt.el --- appointment notification functions. - -;; Copyright (C) 1989, 1990, 1994 Free Software Foundation, Inc. - -;; Author: Neil Mager <neilm@juliet.ll.mit.edu> -;; Maintainer: FSF -;; Keywords: calendar - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; -;; appt.el - visible and/or audible notification of -;; appointments from ~/diary file generated from -;; Edward M. Reingold's calendar.el. -;; -;; -;; Comments, corrections, and improvements should be sent to -;; Neil M. Mager -;; Net <neilm@juliet.ll.mit.edu> -;; Voice (617) 981-4803 -;;; -;;; Thanks to Edward M. Reingold for much help and many suggestions, -;;; And to many others for bug fixes and suggestions. -;;; -;;; -;;; This functions in this file will alert the user of a -;;; pending appointment based on their diary file. -;;; -;;; -;;; ******* It is necessary to invoke 'display-time' ******** -;;; ******* and 'diary' for this to work properly. ******** -;;; -;;; A message will be displayed in the mode line of the emacs buffer -;;; and (if the user desires) the terminal will beep and display a message -;;; from the diary in the mini-buffer, or the user may select to -;;; have a message displayed in a new buffer. -;;; -;;; The variable 'appt-message-warning-time' allows the -;;; user to specify how much notice they want before the appointment. The -;;; variable 'appt-issue-message' specifies whether the user wants -;;; to to be notified of a pending appointment. -;;; -;;; In order to use, the following should be in your .emacs file in addition to -;;; creating a diary file and invoking calendar: -;;; -;;; Set some options -;;; (setq view-diary-entries-initially t) -;;; (setq appt-issue-message t) -;;; -;;; The following three lines are required: -;;; (display-time) -;;; (add-hook 'diary-hook 'appt-make-list) -;;; -;;; -;;; This is an example of what can be in your diary file: -;;; Monday -;;; 9:30am Coffee break -;;; 12:00pm Lunch -;;; -;;; Based upon the above lines in your .emacs and diary files, -;;; the calendar and diary will be displayed when you enter -;;; emacs and your appointments list will automatically be created. -;;; You will then be reminded at 9:20am about your coffee break -;;; and at 11:50am to go to lunch. -;;; -;;; Use describe-function on appt-check for a description of other variables -;;; that can be used to personalize the notification system. -;;; -;;; In order to add or delete items from todays list, use appt-add -;;; and appt-delete. -;;; -;;; Additionally, the appointments list is recreated automatically -;;; at 12:01am for those who do not logout every day or are programming -;;; late. -;;; -;;; Brief internal description - Skip this if your not interested! -;;; -;;; The function appt-check is run from the 'loadst' process which is started -;;; by invoking (display-time). A temporary function below modifies -;;; display-time-filter -;;; (from original time.el) to include a hook which will invoke appt-check. -;;; This will not be necessary in the next version of gnuemacs. -;;; -;;; -;;; The function appt-make-list creates the appointments list which appt-check -;;; reads. This is all done automatically. -;;; It is invoked from the function list-diary-entries. -;;; -;;; You can change the way the appointment window is created/deleted by -;;; setting the variables -;;; -;;; appt-disp-window-function -;;; and -;;; appt-delete-window-function -;;; -;;; For instance, these variables can be set to functions that display -;;; appointments in pop-up frames, which are lowered or iconified after -;;; appt-display-interval seconds. -;;; - -;;; Code: - -;; Make sure calendar is loaded when we compile this. -(require 'calendar) - -(provide 'appt) - -;;;###autoload -(defvar appt-issue-message t - "*Non-nil means check for appointments in the diary buffer. -To be detected, the diary entry must have the time -as the first thing on a line.") - -;;;###autoload -(defvar appt-message-warning-time 12 - "*Time in minutes before an appointment that the warning begins.") - -;;;###autoload -(defvar appt-audible t - "*Non-nil means beep to indicate appointment.") - -;;;###autoload -(defvar appt-visible t - "*Non-nil means display appointment message in echo area.") - -;;;###autoload -(defvar appt-display-mode-line t - "*Non-nil means display minutes to appointment and time on the mode line.") - -;;;###autoload -(defvar appt-msg-window t - "*Non-nil means display appointment message in another window.") - -;;;###autoload -(defvar appt-display-duration 10 - "*The number of seconds an appointment message is displayed.") - -;;;###autoload -(defvar appt-display-diary t - "*Non-nil means to display the next days diary on the screen. -This will occur at midnight when the appointment list is updated.") - -(defvar appt-time-msg-list nil - "The list of appointments for today. -Use `appt-add' and `appt-delete' to add and delete appointments from list. -The original list is generated from the today's `diary-entries-list'. -The number before each time/message is the time in minutes from midnight.") - -(defconst max-time 1439 - "11:59pm in minutes - number of minutes in a day minus 1.") - -(defvar appt-display-interval 3 - "*Number of minutes to wait between checking the appointment list.") - -(defvar appt-buffer-name " *appt-buf*" - "Name of the appointments buffer.") - -(defvar appt-disp-window-function 'appt-disp-window - "Function called to display appointment window.") - -(defvar appt-delete-window-function 'appt-delete-window - "Function called to remove appointment window and buffer.") - -(defun appt-check () - "Check for an appointment and update the mode line. -Note: the time must be the first thing in the line in the diary -for a warning to be issued. - -The format of the time can be either 24 hour or am/pm. -Example: - - 02/23/89 - 18:00 Dinner - - Thursday - 11:45am Lunch meeting. - -The following variables control the action of the notification: - -appt-issue-message - If T, the diary buffer is checked for appointments. - -appt-message-warning-time - Variable used to determine if appointment message - should be displayed. - -appt-audible - Variable used to determine if appointment is audible. - Default is t. - -appt-visible - Variable used to determine if appointment message should be - displayed in the mini-buffer. Default is t. - -appt-msg-window - Variable used to determine if appointment message - should temporarily appear in another window. Mutually exclusive - to appt-visible. - -appt-display-duration - The number of seconds an appointment message - is displayed in another window. - -appt-display-interval - The number of minutes to wait between checking the appointments - list. - -appt-disp-window-function - Function called to display appointment window. You can customize - appt.el by setting this variable to a function different from the - one provided with this package. - -appt-delete-window-function - Function called to remove appointment window and buffer. You can - customize appt.el by setting this variable to a function different - from the one provided with this package. - -This function is run from the loadst process for display time. -Therefore, you need to have `(display-time)' in your .emacs file." - - - (if (or (= appt-display-interval 1) - ;; This is true every appt-display-interval minutes. - (= 0 (mod (/ (nth 1 (current-time)) 60) appt-display-interval))) - (let ((min-to-app -1) - (new-time "")) - (save-excursion - - ;; Get the current time and convert it to minutes - ;; from midnight. ie. 12:01am = 1, midnight = 0. - - (let* ((now (decode-time)) - (cur-hour (nth 2 now)) - (cur-min (nth 1 now)) - (cur-comp-time (+ (* cur-hour 60) cur-min))) - - ;; At the first check after 12:01am, we should update our - ;; appointments to today's list. - - (if (and (>= cur-comp-time 1) - (<= cur-comp-time appt-display-interval)) - (if (and view-diary-entries-initially appt-display-diary) - (diary) - (let ((diary-display-hook 'appt-make-list)) - (diary)))) - - ;; If there are entries in the list, and the - ;; user wants a message issued - ;; get the first time off of the list - ;; and calculate the number of minutes until - ;; the appointment. - - (if (and appt-issue-message appt-time-msg-list) - (let ((appt-comp-time (car (car (car appt-time-msg-list))))) - (setq min-to-app (- appt-comp-time cur-comp-time)) - - (while (and appt-time-msg-list - (< appt-comp-time cur-comp-time)) - (setq appt-time-msg-list (cdr appt-time-msg-list)) - (if appt-time-msg-list - (setq appt-comp-time - (car (car (car appt-time-msg-list)))))) - - ;; If we have an appointment between midnight and - ;; 'appt-message-warning-time' minutes after midnight, - ;; we must begin to issue a message before midnight. - ;; Midnight is considered 0 minutes and 11:59pm is - ;; 1439 minutes. Therefore we must recalculate the minutes - ;; to appointment variable. It is equal to the number of - ;; minutes before midnight plus the number of - ;; minutes after midnight our appointment is. - - (if (and (< appt-comp-time appt-message-warning-time) - (> (+ cur-comp-time appt-message-warning-time) - max-time)) - (setq min-to-app (+ (- (1+ max-time) cur-comp-time)) - appt-comp-time)) - - ;; issue warning if the appointment time is - ;; within appt-message-warning time - - (if (and (<= min-to-app appt-message-warning-time) - (>= min-to-app 0)) - (progn - (if appt-msg-window - (progn - (string-match - "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?" - display-time-string) - - (setq new-time (substring display-time-string - (match-beginning 0) - (match-end 0))) - (funcall - appt-disp-window-function - min-to-app new-time - (car (cdr (car appt-time-msg-list)))) - - (run-at-time - (format "%d sec" appt-display-duration) - nil - appt-delete-window-function)) - ;;; else - - (if appt-visible - (message "%s" - (car (cdr (car appt-time-msg-list))))) - - (if appt-audible - (beep 1))) - - (if appt-display-mode-line - (progn - (string-match - "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?" - display-time-string) - - (setq new-time (substring display-time-string - (match-beginning 0) - (match-end 0))) - (setq display-time-string - (concat "App't in " - min-to-app " min. " new-time " ")) - - (force-mode-line-update t) - (sit-for 0))) - - (if (= min-to-app 0) - (setq appt-time-msg-list - (cdr appt-time-msg-list)))))))))))) - - -;; Display appointment message in a separate buffer. -(defun appt-disp-window (min-to-app new-time appt-msg) - (require 'electric) - - ;; Make sure we're not in the minibuffer - ;; before splitting the window. - - (if (equal (selected-window) (minibuffer-window)) - (if (other-window 1) - (select-window (other-window 1)) - (if window-system - (select-frame (other-frame 1))))) - - (let* ((this-buffer (current-buffer)) - (this-window (selected-window)) - (appt-disp-buf (set-buffer (get-buffer-create appt-buffer-name)))) - - (appt-select-lowest-window) - (if (cdr (assq 'unsplittable (frame-parameters))) - ;; In an unsplittable frame, use something somewhere else. - (display-buffer appt-disp-buf) - ;; Otherwise, split the bottom window and use the lower part. - (split-window) - (pop-to-buffer appt-disp-buf)) - (setq mode-line-format - (concat "-------------------- Appointment in " - min-to-app " minutes. " new-time " %-")) - (insert-string appt-msg) - (shrink-window-if-larger-than-buffer (get-buffer-window appt-disp-buf t)) - (set-buffer-modified-p nil) - (raise-frame (selected-frame)) - (select-window this-window) - (if appt-audible - (beep 1)))) - -(defun appt-delete-window () - "Function called to undisplay appointment messages. -Usually just deletes the appointment buffer." - (let ((window (get-buffer-window appt-buffer-name t))) - (and window - (or (and (fboundp 'frame-root-window) - (eq window (frame-root-window (window-frame window)))) - (delete-window window)))) - (kill-buffer appt-buffer-name) - (if appt-audible - (beep 1))) - -;; Select the lowest window on the frame. -(defun appt-select-lowest-window () - (let* ((lowest-window (selected-window)) - (bottom-edge (car (cdr (cdr (cdr (window-edges)))))) - (last-window (previous-window)) - (window-search t)) - (while window-search - (let* ((this-window (next-window)) - (next-bottom-edge (car (cdr (cdr (cdr - (window-edges this-window))))))) - (if (< bottom-edge next-bottom-edge) - (progn - (setq bottom-edge next-bottom-edge) - (setq lowest-window this-window))) - - (select-window this-window) - (if (eq last-window this-window) - (progn - (select-window lowest-window) - (setq window-search nil))))))) - - -(defun appt-add (new-appt-time new-appt-msg) - "Add an appointment for the day at TIME and issue MESSAGE. -The time should be in either 24 hour format or am/pm format." - - (interactive "sTime (hh:mm[am/pm]): \nsMessage: ") - (if (string-match "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?" new-appt-time) - nil - (error "Unacceptable time-string")) - - (let* ((appt-time-string (concat new-appt-time " " new-appt-msg)) - (appt-time (list (appt-convert-time new-appt-time))) - (time-msg (cons appt-time (list appt-time-string)))) - (setq appt-time-msg-list (append appt-time-msg-list - (list time-msg))) - (setq appt-time-msg-list (appt-sort-list appt-time-msg-list)))) - -(defun appt-delete () - "Delete an appointment from the list of appointments." - (interactive) - (let* ((tmp-msg-list appt-time-msg-list)) - (while tmp-msg-list - (let* ((element (car tmp-msg-list)) - (prompt-string (concat "Delete " - (prin1-to-string (car (cdr element))) - " from list? ")) - (test-input (y-or-n-p prompt-string))) - (setq tmp-msg-list (cdr tmp-msg-list)) - (if test-input - (setq appt-time-msg-list (delq element appt-time-msg-list))))) - (message ""))) - - -;; Create the appointments list from todays diary buffer. -;; The time must be at the beginning of a line for it to be -;; put in the appointments list. -;; 02/23/89 -;; 12:00pm lunch -;; Wednesday -;; 10:00am group meeting -;; We assume that the variables DATE and NUMBER -;; hold the arguments that list-diary-entries received. -;; They specify the range of dates that the diary is being processed for. - -;;;###autoload -(defun appt-make-list () - ;; We have something to do if the range of dates that the diary is - ;; considering includes the current date. - (if (and (not (calendar-date-compare - (list (calendar-current-date)) - (list original-date))) - (calendar-date-compare - (list (calendar-current-date)) - (list (calendar-gregorian-from-absolute - (+ (calendar-absolute-from-gregorian original-date) - number))))) - (save-excursion - ;; Clear the appointments list, then fill it in from the diary. - (setq appt-time-msg-list nil) - (if diary-entries-list - - ;; Cycle through the entry-list (diary-entries-list) - ;; looking for entries beginning with a time. If - ;; the entry begins with a time, add it to the - ;; appt-time-msg-list. Then sort the list. - - (let ((entry-list diary-entries-list) - (new-time-string "")) - ;; Skip diary entries for dates before today. - (while (and entry-list - (calendar-date-compare - (car entry-list) (list (calendar-current-date)))) - (setq entry-list (cdr entry-list))) - ;; Parse the entries for today. - (while (and entry-list - (calendar-date-equal - (calendar-current-date) (car (car entry-list)))) - (let ((time-string (substring (prin1-to-string - (cdr (car entry-list))) 2 -2))) - - (while (string-match - "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?.*" - time-string) - (let* ((appt-time-string (substring time-string - (match-beginning 0) - (match-end 0)))) - - (if (< (match-end 0) (length time-string)) - (setq new-time-string (substring time-string - (+ (match-end 0) 1) - nil)) - (setq new-time-string "")) - - (string-match "[0-9]?[0-9]:[0-9][0-9]\\(am\\|pm\\)?" - time-string) - - (let* ((appt-time (list (appt-convert-time - (substring time-string - (match-beginning 0) - (match-end 0))))) - (time-msg (cons appt-time - (list appt-time-string)))) - (setq time-string new-time-string) - (setq appt-time-msg-list (append appt-time-msg-list - (list time-msg))))))) - (setq entry-list (cdr entry-list))))) - (setq appt-time-msg-list (appt-sort-list appt-time-msg-list)) - - ;; Get the current time and convert it to minutes - ;; from midnight. ie. 12:01am = 1, midnight = 0, - ;; so that the elements in the list - ;; that are earlier than the present time can - ;; be removed. - - (let* ((now (decode-time)) - (cur-hour (nth 2 now)) - (cur-min (nth 1 now)) - (cur-comp-time (+ (* cur-hour 60) cur-min)) - (appt-comp-time (car (car (car appt-time-msg-list))))) - - (while (and appt-time-msg-list (< appt-comp-time cur-comp-time)) - (setq appt-time-msg-list (cdr appt-time-msg-list)) - (if appt-time-msg-list - (setq appt-comp-time (car (car (car appt-time-msg-list)))))))))) - - -;;Simple sort to put the appointments list in order. -;;Scan the list for the smallest element left in the list. -;;Append the smallest element left into the new list, and remove -;;it from the original list. -(defun appt-sort-list (appt-list) - (let ((order-list nil)) - (while appt-list - (let* ((element (car appt-list)) - (element-time (car (car element))) - (tmp-list (cdr appt-list))) - (while tmp-list - (if (< element-time (car (car (car tmp-list)))) - nil - (setq element (car tmp-list)) - (setq element-time (car (car element)))) - (setq tmp-list (cdr tmp-list))) - (setq order-list (append order-list (list element))) - (setq appt-list (delq element appt-list)))) - order-list)) - - -(defun appt-convert-time (time2conv) - "Convert hour:min[am/pm] format to minutes from midnight." - - (let ((conv-time 0) - (hr 0) - (min 0)) - - (string-match ":[0-9][0-9]" time2conv) - (setq min (string-to-int - (substring time2conv - (+ (match-beginning 0) 1) (match-end 0)))) - - (string-match "[0-9]?[0-9]:" time2conv) - (setq hr (string-to-int - (substring time2conv - (match-beginning 0) - (match-end 0)))) - - ;; convert the time appointment time into 24 hour time - - (if (and (string-match "[p][m]" time2conv) (< hr 12)) - (progn - (string-match "[0-9]?[0-9]:" time2conv) - (setq hr (+ 12 hr)))) - - ;; convert the actual time - ;; into minutes for comparison - ;; against the actual time. - - (setq conv-time (+ (* hr 60) min)) - conv-time)) - -(add-hook 'display-time-hook 'appt-check) - -;;; appt.el ends here - diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el deleted file mode 100644 index c15f4511c48..00000000000 --- a/lisp/calendar/cal-china.el +++ /dev/null @@ -1,455 +0,0 @@ -;;; cal-china.el --- calendar functions for the Chinese calendar. - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: Chinese calendar, calendar, holidays, diary - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el, -;; diary.el, and holidays.el that deal with the Chinese calendar. The rules -;; used for the Chinese calendar are those of Baolin Liu (see L. E. Doggett's -;; article "Calendars" in the Explanatory Supplement to the Astronomical -;; Almanac, second edition, 1992) for the calendar as revised at the beginning -;; of the Qing dynasty in 1644. The nature of the astronomical calculations -;; is such that precise calculations cannot be made without great expense in -;; time, so that the calendars produced may not agree perfectly with published -;; tables--but no two pairs of published tables agree perfectly either! Liu's -;; rules produce a calendar for 2033 which is not accepted by all authorities. -;; The date of Chinese New Year is correct from 1644-2051. - -;; 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 - -;;; Code: - -(require 'lunar) - -(defvar chinese-calendar-celestial-stem - ["Jia" "Yi" "Bing" "Ding" "Wu" "Ji" "Geng" "Xin" "Ren" "Gui"]) - -(defvar chinese-calendar-terrestrial-branch - ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"]) - -(defvar chinese-calendar-time-zone - '(if (< year 1928) - (+ 465 (/ 40.0 60.0)) - 480) - "*Number of minutes difference between local standard time for Chinese -calendar and Coordinated Universal (Greenwich) Time. Default is for Beijing. -This is an expression in `year' since it changed at 1928-01-01 00:00:00 from -UT+7:45:40 to UT+8.") - -(defvar chinese-calendar-location-name "Beijing" - "*Name of location used for calculation of Chinese calendar.") - -(defvar chinese-calendar-daylight-time-offset 0 -; The correct value is as follows, but the Chinese calendrical -; authorities do NOT use DST in determining astronomical events: -; 60 - "*Number of minutes difference between daylight savings and standard time -for Chinese calendar. Default is for no daylight savings time.") - -(defvar chinese-calendar-standard-time-zone-name - '(if (< year 1928) - "PMT" - "CST") - "*Abbreviated name of standard time zone used for Chinese calendar.") - -(defvar chinese-calendar-daylight-time-zone-name "CDT" - "*Abbreviated name of daylight-savings time zone used for Chinese calendar.") - -(defvar chinese-calendar-daylight-savings-starts nil -; The correct value is as follows, but the Chinese calendrical -; authorities do NOT use DST in determining astronomical events: -; '(cond ((< 1986 year) (calendar-nth-named-day 1 0 4 year 10)) -; ((= 1986 year) '(5 4 1986)) -; (t nil)) - "*Sexp giving the date on which daylight savings time starts for Chinese -calendar. Default is for no daylight savings time. See documentation of -`calendar-daylight-savings-starts'.") - -(defvar chinese-calendar-daylight-savings-ends nil -; The correct value is as follows, but the Chinese calendrical -; authorities do NOT use DST in determining astronomical events: -; '(if (<= 1986 year) (calendar-nth-named-day 1 0 9 year 11)) - "*Sexp giving the date on which daylight savings time ends for Chinese -calendar. Default is for no daylight savings time. See documentation of -`calendar-daylight-savings-ends'.") - -(defvar chinese-calendar-daylight-savings-starts-time 0 - "*Number of minutes after midnight that daylight savings time starts for -Chinese calendar. Default is for no daylight savings time.") - -(defvar chinese-calendar-daylight-savings-ends-time 0 - "*Number of minutes after midnight that daylight savings time ends for -Chinese calendar. Default is for no daylight savings time.") - -(defun chinese-zodiac-sign-on-or-after (d) - "Absolute date of first new Zodiac sign on or after absolute date d. -The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." - (let* ((year (extract-calendar-year - (calendar-gregorian-from-absolute d))) - (calendar-time-zone (eval chinese-calendar-time-zone)) - (calendar-daylight-time-offset - chinese-calendar-daylight-time-offset) - (calendar-standard-time-zone-name - chinese-calendar-standard-time-zone-name) - (calendar-daylight-time-zone-name - chinese-calendar-daylight-time-zone-name) - (calendar-calendar-daylight-savings-starts - chinese-calendar-daylight-savings-starts) - (calendar-daylight-savings-ends - chinese-calendar-daylight-savings-ends) - (calendar-daylight-savings-starts-time - chinese-calendar-daylight-savings-starts-time) - (calendar-daylight-savings-ends-time - chinese-calendar-daylight-savings-ends-time)) - (floor - (calendar-absolute-from-astro - (solar-date-next-longitude - (calendar-astro-from-absolute d) - 30))))) - -(defun chinese-new-moon-on-or-after (d) - "Absolute date of first new moon on or after absolute date d." - (let* ((year (extract-calendar-year - (calendar-gregorian-from-absolute d))) - (calendar-time-zone (eval chinese-calendar-time-zone)) - (calendar-daylight-time-offset - chinese-calendar-daylight-time-offset) - (calendar-standard-time-zone-name - chinese-calendar-standard-time-zone-name) - (calendar-daylight-time-zone-name - chinese-calendar-daylight-time-zone-name) - (calendar-calendar-daylight-savings-starts - chinese-calendar-daylight-savings-starts) - (calendar-daylight-savings-ends - chinese-calendar-daylight-savings-ends) - (calendar-daylight-savings-starts-time - chinese-calendar-daylight-savings-starts-time) - (calendar-daylight-savings-ends-time - chinese-calendar-daylight-savings-ends-time)) - (floor - (calendar-absolute-from-astro - (lunar-new-moon-on-or-after - (calendar-astro-from-absolute d)))))) - -(defvar chinese-year-cache - '((1989 (12 726110) (1 726139) (2 726169) (3 726198) (4 726227) (5 726257) - (6 726286) (7 726316) (8 726345) (9 726375) (10 726404) (11 726434)) - (1990 (12 726464) (1 726494) (2 726523) (3 726553) (4 726582) (5 726611) - (5.5 726641) (6 726670) (7 726699) (8 726729) (9 726758) (10 726788) - (11 726818)) - (1991 (12 726848) (1 726878) (2 726907) (3 726937) (4 726966) (5 726995) - (6 727025) (7 727054) (8 727083) (9 727113) (10 727142) (11 727172)) - (1992 (12 727202) (1 727232) (2 727261) (3 727291) (4 727321) (5 727350) - (6 727379) (7 727409) (8 727438) (9 727467) (10 727497) (11 727526)) - (1993 (12 727556) (1 727586) (2 727615) (3 727645) (3.5 727675) (4 727704) - (5 727734) (6 727763) (7 727793) (8 727822) (9 727851) (10 727881) - (11 727910)) - (1994 (12 727940) (1 727969) (2 727999) (3 728029) (4 728059) (5 728088) - (6 728118) (7 728147) (8 728177) (9 728206) (10 728235) (11 728265)) - (1995 (12 728294) (1 728324) (2 728353) (3 728383) (4 728413) (5 728442) - (6 728472) (7 728501) (8 728531) (8.5 728561) (9 728590) (10 728619) - (11 728649)) - (1996 (12 728678) (1 728708) (2 728737) (3 728767) (4 728796) (5 728826) - (6 728856) (7 728885) (8 728915) (9 728944) (10 728974) (11 729004)) - (1997 (12 729033) (1 729062) (2 729092) (3 729121) (4 729151) (5 729180) - (6 729210) (7 729239) (8 729269) (9 729299) (10 729328) (11 729358)) - (1998 (12 729388) (1 729417) (2 729447) (3 729476) (4 729505) (5 729535) - (5.5 729564) (6 729593) (7 729623) (8 729653) (9 729682) (10 729712) - (11 729742)) - (1999 (12 729771) (1 729801) (2 729831) (3 729860) (4 729889) (5 729919) - (6 729948) (7 729977) (8 730007) (9 730036) (10 730066) (11 730096)) - (2000 (12 730126) (1 730155) (2 730185) (3 730215) (4 730244) (5 730273) - (6 730303) (7 730332) (8 730361) (9 730391) (10 730420) (11 730450))) - "An assoc list of Chinese year structures as determined by `chinese-year'. - -Values are computed as needed, but to save time, the initial value consists -of the precomputed years 1989-2000. The code works just as well with this -set to nil initially (which is how the value for 1989-2000 was computed).") - -(defun chinese-year (y) - "The structure of the Chinese year for Gregorian year Y. -The result is a list of pairs (i d), where month i begins on absolute date d, -of the Chinese months from the Chinese month following the solstice in -Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y. - -The list is cached for further use." - (let ((list (cdr (assoc y chinese-year-cache)))) - (if (not list) - (progn - (setq list (compute-chinese-year y)) - (setq chinese-year-cache - (append chinese-year-cache (list (cons y list)))))) - list)) - -(defun number-chinese-months (list start) - "Assign month numbers to the lunar months in LIST, starting with START. -Numbers are assigned sequentially, START, START+1, ..., 11, with half -numbers used for leap months. - -First month of list will never be a leap month, nor will the last." - (if list - (if (zerop (- 12 start (length list))) - ;; List is too short for a leap month - (cons (list start (car list)) - (number-chinese-months (cdr list) (1+ start))) - (cons - ;; First month - (list start (car list)) - ;; Remaining months - (if (and (cdr (cdr list));; at least two more months... - (<= (car (cdr (cdr list))) - (chinese-zodiac-sign-on-or-after (car (cdr list))))) - ;; Next month is a leap month - (cons (list (+ start 0.5) (car (cdr list))) - (number-chinese-months (cdr (cdr list)) (1+ start))) - ;; Next month is not a leap month - (number-chinese-months (cdr list) (1+ start))))))) - -(defun chinese-month-list (start end) - "List of starting dates of Chinese months from START to END." - (if (<= start end) - (let ((new-moon (chinese-new-moon-on-or-after start))) - (if (<= new-moon end) - (cons new-moon - (chinese-month-list (1+ new-moon) end)))))) - -(defun compute-chinese-year (y) - "Compute the structure of the Chinese year for Gregorian year Y. -The result is a list of pairs (i d), where month i begins on absolute date d, -of the Chinese months from the Chinese month following the solstice in -Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y." - (let* ((next-solstice (chinese-zodiac-sign-on-or-after - (calendar-absolute-from-gregorian - (list 12 15 y)))) - (list (chinese-month-list (1+ (chinese-zodiac-sign-on-or-after - (calendar-absolute-from-gregorian - (list 12 15 (1- y))))) - next-solstice)) - (next-sign (chinese-zodiac-sign-on-or-after (car list)))) - (if (= (length list) 12) - ;; No room for a leap month, just number them 12, 1, 2, ..., 11 - (cons (list 12 (car list)) - (number-chinese-months (cdr list) 1)) - ;; Now we can assign numbers to the list for y - ;; The first month or two are special - (if (or (> (car list) next-sign) (>= next-sign (car (cdr list)))) - ;; First month on list is a leap month, second is not - (append (list (list 11.5 (car list)) - (list 12 (car (cdr list)))) - (number-chinese-months (cdr (cdr list)) 1)) - ;; First month on list is not a leap month - (append (list (list 12 (car list))) - (if (>= (chinese-zodiac-sign-on-or-after (car (cdr list))) - (car (cdr (cdr list)))) - ;; Second month on list is a leap month - (cons (list 12.5 (car (cdr list))) - (number-chinese-months (cdr (cdr list)) 1)) - ;; Second month on list is not a leap month - (number-chinese-months (cdr list) 1))))))) - -(defun calendar-absolute-from-chinese (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* ((cycle (car date)) - (year (car (cdr date))) - (month (car (cdr (cdr date)))) - (day (car (cdr (cdr (cdr date))))) - (g-year (+ (* (1- cycle) 60);; years in prior cycles - (1- year) ;; prior years this cycle - -2636))) ;; years before absolute date 0 - (+ (1- day);; prior days this month - (car - (cdr ;; absolute date of start of this month - (assoc month (append (memq (assoc 1 (chinese-year g-year)) - (chinese-year g-year)) - (chinese-year (1+ g-year))))))))) - -(defun calendar-chinese-from-absolute (date) - "Compute Chinese date (cycle year month day) corresponding to absolute DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let* ((g-year (extract-calendar-year - (calendar-gregorian-from-absolute date))) - (c-year (+ g-year 2695)) - (list (append (chinese-year (1- g-year)) - (chinese-year g-year) - (chinese-year (1+ g-year))))) - (while (<= (car (cdr (car (cdr list)))) date) - ;; the first month on the list is in Chinese year c-year - ;; date is on or after start of second month on list... - (if (= 1 (car (car (cdr list)))) - ;; second month on list is a new Chinese year - (setq c-year (1+ c-year))) - ;; ...so first month on list is of no interest - (setq list (cdr list))) - (list (/ (1- c-year) 60) - (calendar-mod c-year 60) - (car (car list)) - (1+ (- date (car (cdr (car list)))))))) - -(defun holiday-chinese-new-year () - "Date of Chinese New Year." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y 1) - (if (< m 5) - (let ((chinese-new-year - (calendar-gregorian-from-absolute - (car (cdr (assoc 1 (chinese-year y))))))) - (if (calendar-date-is-visible-p chinese-new-year) - (list - (list chinese-new-year - (format "Chinese New Year (%s)" - (calendar-chinese-sexagesimal-name (+ y 57)))))))))) - -(defun calendar-chinese-date-string (&optional date) - "String of Chinese date of Gregorian DATE. -Defaults to today's date if DATE is not given." - (let* ((a-date (calendar-absolute-from-gregorian - (or date (calendar-current-date)))) - (c-date (calendar-chinese-from-absolute a-date)) - (cycle (car c-date)) - (year (car (cdr c-date))) - (month (car (cdr (cdr c-date)))) - (day (car (cdr (cdr (cdr c-date))))) - (this-month (calendar-absolute-from-chinese - (list cycle year month 1))) - (next-month (calendar-absolute-from-chinese - (list (if (= year 60) (1+ cycle) cycle) - (if (= (floor month) 12) (1+ year) year) - (calendar-mod (1+ (floor month)) 12) - 1))) - (m-cycle (% (+ (* year 5) (floor month)) 60))) - (format "Cycle %s, year %s (%s), %smonth %s%s, day %s (%s)" - cycle - year (calendar-chinese-sexagesimal-name year) - (if (not (integerp month)) - "second " - (if (< 30 (- next-month this-month)) - "first " - "")) - (floor month) - (if (integerp month) - (format " (%s)" (calendar-chinese-sexagesimal-name - (+ (* 5 year) month 44))) - "") - day (calendar-chinese-sexagesimal-name (+ a-date 15))))) - -(defun calendar-chinese-sexagesimal-name (n) - "The N-th name of the Chinese sexagesimal cycle. -N congruent to 1 gives the first name, N congruent to 2 gives the second name, -..., N congruent to 60 gives the sixtieth name." - (format "%s-%s" - (aref chinese-calendar-celestial-stem (% (1- n) 10)) - (aref chinese-calendar-terrestrial-branch (% (1- n) 12)))) - -(defun calendar-print-chinese-date () - "Show the Chinese date equivalents of date." - (interactive) - (message "Computing Chinese date...") - (message "Chinese date: %s" - (calendar-chinese-date-string (calendar-cursor-to-date t)))) - -(defun calendar-goto-chinese-date (date &optional noecho) - "Move cursor to Chinese date DATE. -Echo Chinese date unless NOECHO is t." - (interactive - (let* ((c (calendar-chinese-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date)))) - (cycle (calendar-read - "Chinese calendar cycle number (>44): " - '(lambda (x) (> x 44)) - (int-to-string (car c)))) - (year (calendar-read - "Year in Chinese cycle (1..60): " - '(lambda (x) (and (<= 1 x) (<= x 60))) - (int-to-string (car (cdr c))))) - (month-list (make-chinese-month-assoc-list - (chinese-months cycle year))) - (month (cdr (assoc - (completing-read "Chinese calendar month: " - month-list nil t) - month-list))) - (last (if (= month - (car (cdr (cdr - (calendar-chinese-from-absolute - (+ 29 - (calendar-absolute-from-chinese - (list cycle year month 1)))))))) - 30 - 29)) - (day (calendar-read - (format "Chinese calendar day (1-%d): " last) - '(lambda (x) (and (<= 1 x) (<= x last)))))) - (list (list cycle year month day)))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-chinese date))) - (or noecho (calendar-print-chinese-date))) - -(defun chinese-months (c y) - "A list of the months in cycle C, year Y of the Chinese calendar." - (let* ((l (memq 1 (append - (mapcar '(lambda (x) - (car x)) - (chinese-year (extract-calendar-year - (calendar-gregorian-from-absolute - (calendar-absolute-from-chinese - (list c y 1 1)))))) - (mapcar '(lambda (x) - (if (> (car x) 11) (car x))) - (chinese-year (extract-calendar-year - (calendar-gregorian-from-absolute - (calendar-absolute-from-chinese - (list (if (= y 60) (1+ c) c) - (if (= y 60) 1 y) - 1 1)))))))))) - l)) - -(defun make-chinese-month-assoc-list (l) - "Make list of months L into an assoc list." - (if (and l (car l)) - (if (and (cdr l) (car (cdr l))) - (if (= (car l) (floor (car (cdr l)))) - (append - (list (cons (format "%s (first)" (car l)) (car l)) - (cons (format "%s (second)" (car l)) (car (cdr l)))) - (make-chinese-month-assoc-list (cdr (cdr l)))) - (append - (list (cons (int-to-string (car l)) (car l))) - (make-chinese-month-assoc-list (cdr l)))) - (list (cons (int-to-string (car l)) (car l)))))) - -(defun diary-chinese-date () - "Chinese calendar equivalent of date diary entry." - (format "Chinese date: %s" (calendar-chinese-date-string date))) - -(provide 'cal-china) - -;;; cal-china.el ends here diff --git a/lisp/calendar/cal-coptic.el b/lisp/calendar/cal-coptic.el deleted file mode 100644 index 6fce26c5013..00000000000 --- a/lisp/calendar/cal-coptic.el +++ /dev/null @@ -1,234 +0,0 @@ -;;; cal-coptic.el --- calendar functions for the Coptic/Ethiopic calendars. - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: Coptic calendar, Ethiopic calendar, calendar, diary - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; diary.el that deal with the Coptic and Ethiopic calendars. - -;; 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 - -;;; Code: - -(require 'cal-julian) - -(defvar coptic-calendar-month-name-array - ["Tut" "Babah" "Hatur" "Kiyahk" "Tubah" "Amshir" "Baramhat" "Barmundah" - "Bashans" "Baunah" "Abib" "Misra" "al-Nasi"]) - -(defvar coptic-calendar-epoch (calendar-absolute-from-julian '(8 29 284)) - "Absolute date of start of Coptic calendar = August 29, 284 A.D. (Julian).") - -(defconst coptic-name "Coptic") - -(defun coptic-calendar-leap-year-p (year) - "True if YEAR is a leap year on the Coptic calendar." - (zerop (mod (1+ year) 4))) - -(defun coptic-calendar-last-day-of-month (month year) - "Return last day of MONTH, YEAR on the Coptic calendar. -The 13th month is not really a month, but the 5 (6 in leap years) day period of -Nisi (Kebus) at the end of the year." - (if (< month 13) - 30 - (if (coptic-calendar-leap-year-p year) - 6 - 5))) - -(defun calendar-absolute-from-coptic (date) - "Compute absolute date from Coptic date 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))) - (+ (1- coptic-calendar-epoch);; Days before start of calendar - (* 365 (1- year)) ;; Days in prior years - (/ year 4) ;; Leap days in prior years - (* 30 (1- month)) ;; Days in prior months this year - day))) ;; Days so far this month - - -(defun calendar-coptic-from-absolute (date) - "Compute the Coptic equivalent for absolute date DATE. -The result is a list of the form (MONTH DAY YEAR). -The absolute date is the number of days elapsed since the imaginary -Gregorian date Sunday, December 31, 1 BC." - (if (< date coptic-calendar-epoch) - (list 0 0 0);; pre-Coptic date - (let* ((approx (/ (- date coptic-calendar-epoch) - 366)) ;; Approximation from below. - (year ;; Search forward from the approximation. - (+ approx - (calendar-sum y approx - (>= date (calendar-absolute-from-coptic (list 1 1 (1+ y)))) - 1))) - (month ;; Search forward from Tot. - (1+ (calendar-sum m 1 - (> date - (calendar-absolute-from-coptic - (list m - (coptic-calendar-last-day-of-month m year) - year))) - 1))) - (day ;; Calculate the day by subtraction. - (- date - (1- (calendar-absolute-from-coptic (list month 1 year)))))) - (list month day year)))) - -(defun calendar-coptic-date-string (&optional date) - "String of Coptic date of Gregorian DATE. -Returns the empty string if DATE is pre-Coptic calendar. -Defaults to today's date if DATE is not given." - (let* ((coptic-date (calendar-coptic-from-absolute - (calendar-absolute-from-gregorian - (or date (calendar-current-date))))) - (y (extract-calendar-year coptic-date)) - (m (extract-calendar-month coptic-date))) - (if (< y 1) - "" - (let ((monthname (aref coptic-calendar-month-name-array (1- m))) - (day (int-to-string (extract-calendar-day coptic-date))) - (dayname nil) - (month (int-to-string m)) - (year (int-to-string y))) - (mapconcat 'eval calendar-date-display-form ""))))) - -(defun calendar-print-coptic-date () - "Show the Coptic calendar equivalent of the selected date." - (interactive) - (let ((f (calendar-coptic-date-string (calendar-cursor-to-date t)))) - (if (string-equal f "") - (message "Date is pre-%s calendar" coptic-name) - (message f)))) - -(defun calendar-goto-coptic-date (date &optional noecho) - "Move cursor to Coptic date DATE. -Echo Coptic date unless NOECHO is t." - (interactive (coptic-prompt-for-date)) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-coptic date))) - (or noecho (calendar-print-coptic-date))) - -(defun coptic-prompt-for-date () - "Ask for a Coptic date." - (let* ((today (calendar-current-date)) - (year (calendar-read - (format "%s calendar year (>0): " coptic-name) - '(lambda (x) (> x 0)) - (int-to-string - (extract-calendar-year - (calendar-coptic-from-absolute - (calendar-absolute-from-gregorian today)))))) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - (format "%s calendar month name: " coptic-name) - (mapcar 'list - (append coptic-calendar-month-name-array nil)) - nil t)) - (calendar-make-alist coptic-calendar-month-name-array - 1 'capitalize)))) - (last (coptic-calendar-last-day-of-month month year)) - (day (calendar-read - (format "%s calendar day (1-%d): " coptic-name last) - '(lambda (x) (and (< 0 x) (<= x last)))))) - (list (list month day year)))) - -(defun diary-coptic-date () - "Coptic calendar equivalent of date diary entry." - (let ((f (calendar-coptic-date-string (calendar-cursor-to-date t)))) - (if (string-equal f "") - (format "Date is pre-%s calendar" coptic-name) - f))) - -(defconst ethiopic-calendar-month-name-array - ["Maskaram" "Teqemt" "Khedar" "Takhsas" "Ter" "Yakatit" "Magabit" "Miyazya" - "Genbot" "Sane" "Hamle" "Nahas" "Paguem"]) - -(defconst ethiopic-calendar-epoch 2430 - "Absolute date of start of Ethiopic calendar = August 29, 7 C.E. (Julian).") - -(defconst ethiopic-name "Ethiopic") - -(defun calendar-absolute-from-ethiopic (date) - "Compute absolute date from Ethiopic date DATE. -The absolute date is the number of days elapsed since the (imaginary) -Gregorian date Sunday, December 31, 1 BC." - (let ((coptic-calendar-epoch ethiopic-calendar-epoch)) - (calendar-absolute-from-coptic date))) - -(defun calendar-ethiopic-from-absolute (date) - "Compute the Ethiopic equivalent for absolute date DATE. -The result is a list of the form (MONTH DAY YEAR). -The absolute date is the number of days elapsed since the imaginary -Gregorian date Sunday, December 31, 1 BC." - (let ((coptic-calendar-epoch ethiopic-calendar-epoch)) - (calendar-coptic-from-absolute date))) - -(defun calendar-ethiopic-date-string (&optional date) - "String of Ethiopic date of Gregorian DATE. -Returns the empty string if DATE is pre-Ethiopic calendar. -Defaults to today's date if DATE is not given." - (let ((coptic-calendar-epoch ethiopic-calendar-epoch) - (coptic-name ethiopic-name) - (coptic-calendar-month-name-array ethiopic-calendar-month-name-array)) - (calendar-coptic-date-string date))) - -(defun calendar-print-ethiopic-date () - "Show the Ethiopic calendar equivalent of the selected date." - (interactive) - (let ((coptic-calendar-epoch ethiopic-calendar-epoch) - (coptic-name ethiopic-name) - (coptic-calendar-month-name-array ethiopic-calendar-month-name-array)) - (call-interactively 'calendar-print-coptic-date))) - -(defun calendar-goto-ethiopic-date (date &optional noecho) - "Move cursor to Ethiopic date DATE. -Echo Ethiopic date unless NOECHO is t." - (interactive - (let ((coptic-calendar-epoch ethiopic-calendar-epoch) - (coptic-name ethiopic-name) - (coptic-calendar-month-name-array ethiopic-calendar-month-name-array)) - (coptic-prompt-for-date))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-ethiopic date))) - (or noecho (calendar-print-ethiopic-date))) - -(defun diary-ethiopic-date () - "Ethiopic calendar equivalent of date diary entry." - (let ((coptic-calendar-epoch ethiopic-calendar-epoch) - (coptic-name ethiopic-name) - (coptic-calendar-month-name-array ethiopic-calendar-month-name-array)) - (diary-coptic-date))) - -(provide 'cal-coptic) - -;;; cal-coptic.el ends here diff --git a/lisp/calendar/cal-dst.el b/lisp/calendar/cal-dst.el deleted file mode 100644 index 3e33f6cb9f3..00000000000 --- a/lisp/calendar/cal-dst.el +++ /dev/null @@ -1,397 +0,0 @@ -;;; cal-dst.el --- calendar functions for daylight savings rules. - -;; Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc. - -;; Author: Paul Eggert <eggert@twinsun.com> -;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: daylight savings time, calendar, diary, holidays - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; holiday.el that deal with daylight savings time. - -;; 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 - -;;; Code: - -(require 'calendar) -(require 'cal-persia) - -(defvar calendar-current-time-zone-cache nil - "Cache for result of calendar-current-time-zone.") - -(defvar calendar-system-time-basis - (calendar-absolute-from-gregorian '(1 1 1970)) - "Absolute date of starting date of system clock.") - -(defun calendar-absolute-from-time (x utc-diff) - "Absolute local date of time X; local time is UTC-DIFF seconds from UTC. - -X is (HIGH . LOW) or (HIGH LOW . IGNORED) where HIGH and LOW are the -high and low 16 bits, respectively, of the number of seconds since -1970-01-01 00:00:00 UTC, ignoring leap seconds. - -Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on -absolute date ABS-DATE is the equivalent moment to X." - (let* ((h (car x)) - (xtail (cdr x)) - (l (+ utc-diff (if (numberp xtail) xtail (car xtail)))) - (u (+ (* 512 (mod h 675)) (floor l 128)))) - ;; Overflow is a terrible thing! - (cons (+ calendar-system-time-basis - ;; floor((2^16 h +l) / (60*60*24)) - (* 512 (floor h 675)) (floor u 675)) - ;; (2^16 h +l) mod (60*60*24) - (+ (* (mod u 675) 128) (mod l 128))))) - -(defun calendar-time-from-absolute (abs-date s) - "Time of absolute date ABS-DATE, S seconds after midnight. - -Returns the pair (HIGH . LOW) where HIGH and LOW are the high and low -16 bits, respectively, of the number of seconds 1970-01-01 00:00:00 UTC, -ignoring leap seconds, that is the equivalent moment to S seconds after -midnight UTC on absolute date ABS-DATE." - (let* ((a (- abs-date calendar-system-time-basis)) - (u (+ (* 163 (mod a 512)) (floor s 128)))) - ;; Overflow is a terrible thing! - (cons - ;; floor((60*60*24*a + s) / 2^16) - (+ a (* 163 (floor a 512)) (floor u 512)) - ;; (60*60*24*a + s) mod 2^16 - (+ (* 128 (mod u 512)) (mod s 128))))) - -(defun calendar-next-time-zone-transition (time) - "Return the time of the next time zone transition after TIME. -Both TIME and the result are acceptable arguments to current-time-zone. -Return nil if no such transition can be found." - (let* ((base 65536);; 2^16 = base of current-time output - (quarter-multiple 120);; approx = (seconds per quarter year) / base - (time-zone (current-time-zone time)) - (time-utc-diff (car time-zone)) - hi - hi-zone - (hi-utc-diff time-utc-diff) - (quarters '(2 1 3))) - ;; Heuristic: probe the time zone offset in the next three calendar - ;; quarters, looking for a time zone offset different from TIME. - (while (and quarters (eq time-utc-diff hi-utc-diff)) - (setq hi (cons (+ (car time) (* (car quarters) quarter-multiple)) 0)) - (setq hi-zone (current-time-zone hi)) - (setq hi-utc-diff (car hi-zone)) - (setq quarters (cdr quarters))) - (and - time-utc-diff - hi-utc-diff - (not (eq time-utc-diff hi-utc-diff)) - ;; Now HI is after the next time zone transition. - ;; Set LO to TIME, and then binary search to increase LO and decrease HI - ;; until LO is just before and HI is just after the time zone transition. - (let* ((tail (cdr time)) - (lo (cons (car time) (if (numberp tail) tail (car tail)))) - probe) - (while - ;; Set PROBE to halfway between LO and HI, rounding down. - ;; If PROBE equals LO, we are done. - (let* ((lsum (+ (cdr lo) (cdr hi))) - (hsum (+ (car lo) (car hi) (/ lsum base))) - (hsumodd (logand 1 hsum))) - (setq probe (cons (/ (- hsum hsumodd) 2) - (/ (+ (* hsumodd base) (% lsum base)) 2))) - (not (equal lo probe))) - ;; Set either LO or HI to PROBE, depending on probe results. - (if (eq (car (current-time-zone probe)) hi-utc-diff) - (setq hi probe) - (setq lo probe))) - hi)))) - -(defun calendar-time-zone-daylight-rules (abs-date utc-diff) - "Return daylight transition rule for ABS-DATE, UTC-DIFF sec offset from UTC. -ABS-DATE must specify a day that contains a daylight savings transition. -The result has the proper form for calendar-daylight-savings-starts'." - (let* ((date (calendar-gregorian-from-absolute abs-date)) - (weekday (% abs-date 7)) - (m (extract-calendar-month date)) - (d (extract-calendar-day date)) - (y (extract-calendar-year date)) - (last (calendar-last-day-of-month m y)) - (candidate-rules - (append - ;; Day D of month M. - (list (list 'list m d 'year)) - ;; The first WEEKDAY of month M. - (if (< d 8) - (list (list 'calendar-nth-named-day 1 weekday m 'year))) - ;; The last WEEKDAY of month M. - (if (> d (- last 7)) - (list (list 'calendar-nth-named-day -1 weekday m 'year))) - ;; The first WEEKDAY after day J of month M, for D-6 < J <= D. - (let (l) - (calendar-for-loop j from (max 2 (- d 6)) to (min d (- last 8)) do - (setq l - (cons - (list 'calendar-nth-named-day 1 weekday m 'year j) - l))) - l) - ;; 01-01 and 07-01 for this year's Persian calendar. - (if (and (= m 3) (<= 20 d) (<= d 21)) - '((calendar-gregorian-from-absolute - (calendar-absolute-from-persian - (list 1 1 (- year 621)))))) - (if (and (= m 9) (<= 22 d) (<= d 23)) - '((calendar-gregorian-from-absolute - (calendar-absolute-from-persian - (list 7 1 (- year 621)))))))) - (prevday-sec (- -1 utc-diff)) ;; last sec of previous local day - (year (1+ y))) - ;; Scan through the next few years until only one rule remains. - (while - (let ((rules candidate-rules) - new-rules) - (while - (let* - ((rule (car rules)) - (date - ;; The following is much faster than - ;; (calendar-absolute-from-gregorian (eval rule)). - (cond ((eq (car rule) 'calendar-nth-named-day) - (eval (cons 'calendar-nth-named-absday (cdr rule)))) - ((eq (car rule) 'calendar-gregorian-from-absolute) - (eval (car (cdr rule)))) - (t (let ((g (eval rule))) - (calendar-absolute-from-gregorian g)))))) - (or (equal - (current-time-zone - (calendar-time-from-absolute date prevday-sec)) - (current-time-zone - (calendar-time-from-absolute (1+ date) prevday-sec))) - (setq new-rules (cons rule new-rules))) - (setq rules (cdr rules)))) - ;; If no rules remain, just use the first candidate rule; - ;; it's wrong in general, but it's right for at least one year. - (setq candidate-rules (if new-rules (nreverse new-rules) - (list (car candidate-rules)))) - (setq year (1+ year)) - (cdr candidate-rules))) - (car candidate-rules))) - -(defun calendar-current-time-zone () - "Return UTC difference, dst offset, names and rules for current time zone. - -Returns (UTC-DIFF DST-OFFSET STD-ZONE DST-ZONE DST-STARTS DST-ENDS -DST-STARTS-TIME DST-ENDS-TIME), based on a heuristic probing of what the -system knows: - -UTC-DIFF is an integer specifying the number of minutes difference between - standard time in the current time zone and Coordinated Universal Time - (Greenwich Mean Time). A negative value means west of Greenwich. -DST-OFFSET is an integer giving the daylight savings time offset in minutes. -STD-ZONE is a string giving the name of the time zone when no seasonal time - adjustment is in effect. -DST-ZONE is a string giving the name of the time zone when there is a seasonal - time adjustment in effect. -DST-STARTS and DST-ENDS are sexps in the variable `year' giving the daylight - savings time start and end rules, in the form expected by - `calendar-daylight-savings-starts'. -DST-STARTS-TIME and DST-ENDS-TIME are integers giving the number of minutes - after midnight that daylight savings time starts and ends. - -If the local area does not use a seasonal time adjustment, STD-ZONE and -DST-ZONE are equal, and all the DST-* integer variables are 0. - -Some operating systems cannot provide all this information to Emacs; in this -case, `calendar-current-time-zone' returns a list containing nil for the data -it can't find." - (or - calendar-current-time-zone-cache - (setq - calendar-current-time-zone-cache - (let* ((t0 (current-time)) - (t0-zone (current-time-zone t0)) - (t0-utc-diff (car t0-zone)) - (t0-name (car (cdr t0-zone)))) - (if (not t0-utc-diff) - ;; Little or no time zone information is available. - (list nil nil t0-name t0-name nil nil nil nil) - (let* ((t1 (calendar-next-time-zone-transition t0)) - (t2 (and t1 (calendar-next-time-zone-transition t1)))) - (if (not t2) - ;; This locale does not have daylight savings time. - (list (/ t0-utc-diff 60) 0 t0-name t0-name nil nil 0 0) - ;; Use heuristics to find daylight savings parameters. - (let* ((t1-zone (current-time-zone t1)) - (t1-utc-diff (car t1-zone)) - (t1-name (car (cdr t1-zone))) - (t1-date-sec (calendar-absolute-from-time t1 t0-utc-diff)) - (t2-date-sec (calendar-absolute-from-time t2 t1-utc-diff)) - (t1-rules (calendar-time-zone-daylight-rules - (car t1-date-sec) t0-utc-diff)) - (t2-rules (calendar-time-zone-daylight-rules - (car t2-date-sec) t1-utc-diff)) - (t1-time (/ (cdr t1-date-sec) 60)) - (t2-time (/ (cdr t2-date-sec) 60))) - (cons - (/ (min t0-utc-diff t1-utc-diff) 60) - (cons - (/ (abs (- t0-utc-diff t1-utc-diff)) 60) - (if (< t0-utc-diff t1-utc-diff) - (list t0-name t1-name t1-rules t2-rules t1-time t2-time) - (list t1-name t0-name t2-rules t1-rules t2-time t1-time) - ))))))))))) - -;;; The following eight defvars relating to daylight savings time should NOT be -;;; marked to go into loaddefs.el where they would be evaluated when Emacs is -;;; dumped. These variables' appropriate values depend on the conditions under -;;; which the code is INVOKED; so it's inappropriate to initialize them when -;;; Emacs is dumped---they should be initialized when calendar.el is loaded. -;;; They default to US Eastern time if time zone info is not available. - -(calendar-current-time-zone) - -(defvar calendar-time-zone (or (car calendar-current-time-zone-cache) -300) - "*Number of minutes difference between local standard time at -`calendar-location-name' and Coordinated Universal (Greenwich) Time. For -example, -300 for New York City, -480 for Los Angeles.") - -(defvar calendar-daylight-time-offset - (or (car (cdr calendar-current-time-zone-cache)) 60) - "*Number of minutes difference between daylight savings and standard time. - -If the locale never uses daylight savings time, set this to 0.") - -(defvar calendar-standard-time-zone-name - (or (car (nthcdr 2 calendar-current-time-zone-cache)) "EST") - "*Abbreviated name of standard time zone at `calendar-location-name'. -For example, \"EST\" in New York City, \"PST\" for Los Angeles.") - -(defvar calendar-daylight-time-zone-name - (or (car (nthcdr 3 calendar-current-time-zone-cache)) "EDT") - "*Abbreviated name of daylight-savings time zone at `calendar-location-name'. -For example, \"EDT\" in New York City, \"PDT\" for Los Angeles.") - -;;;###autoload -(put 'calendar-daylight-savings-starts 'risky-local-variable t) -(defvar calendar-daylight-savings-starts - (or (car (nthcdr 4 calendar-current-time-zone-cache)) - (and (not (zerop calendar-daylight-time-offset)) - '(calendar-nth-named-day 1 0 4 year))) - "*Sexp giving the date on which daylight savings time starts. -This is an expression in the variable `year' whose value gives the Gregorian -date in the form (month day year) on which daylight savings time starts. It is -used to determine the starting date of daylight savings time for the holiday -list and for correcting times of day in the solar and lunar calculations. - -For example, if daylight savings time is mandated to start on October 1, -you would set `calendar-daylight-savings-starts' to - - '(10 1 year) - -If it starts on the first Sunday in April, you would set it to - - '(calendar-nth-named-day 1 0 4 year) - -If the locale never uses daylight savings time, set this to nil.") - -;;;###autoload -(put 'calendar-daylight-savings-ends 'risky-local-variable t) -(defvar calendar-daylight-savings-ends - (or (car (nthcdr 5 calendar-current-time-zone-cache)) - (and (not (zerop calendar-daylight-time-offset)) - '(calendar-nth-named-day -1 0 10 year))) - "*Sexp giving the date on which daylight savings time ends. -This is an expression in the variable `year' whose value gives the Gregorian -date in the form (month day year) on which daylight savings time ends. It is -used to determine the starting date of daylight savings time for the holiday -list and for correcting times of day in the solar and lunar calculations. - -For example, if daylight savings time ends on the last Sunday in October: - - '(calendar-nth-named-day -1 0 10 year) - -If the locale never uses daylight savings time, set this to nil.") - -(defvar calendar-daylight-savings-starts-time - (or (car (nthcdr 6 calendar-current-time-zone-cache)) 120) - "*Number of minutes after midnight that daylight savings time starts.") - -(defvar calendar-daylight-savings-ends-time - (or (car (nthcdr 7 calendar-current-time-zone-cache)) - calendar-daylight-savings-starts-time) - "*Number of minutes after midnight that daylight savings time ends.") - -(defun dst-in-effect (date) - "True if on absolute DATE daylight savings time is in effect. -Fractional part of DATE is local standard time of day." - (let* ((year (extract-calendar-year - (calendar-gregorian-from-absolute (floor date)))) - (dst-starts-gregorian (eval calendar-daylight-savings-starts)) - (dst-ends-gregorian (eval calendar-daylight-savings-ends)) - (dst-starts (and dst-starts-gregorian - (+ (calendar-absolute-from-gregorian - dst-starts-gregorian) - (/ calendar-daylight-savings-starts-time - 60.0 24.0)))) - (dst-ends (and dst-ends-gregorian - (+ (calendar-absolute-from-gregorian - dst-ends-gregorian) - (/ (- calendar-daylight-savings-ends-time - calendar-daylight-time-offset) - 60.0 24.0))))) - (and dst-starts dst-ends - (if (< dst-starts dst-ends) - (and (<= dst-starts date) (< date dst-ends)) - (or (<= dst-starts date) (< date dst-ends)))))) - -(defun dst-adjust-time (date time &optional style) - "Adjust, to account for dst on DATE, decimal fraction standard TIME. -Returns a list (date adj-time zone) where `date' and `adj-time' are the values -adjusted for `zone'; here `date' is a list (month day year), `adj-time' is a -decimal fraction time, and `zone' is a string. - -Optional parameter STYLE forces the result time to be standard time when its -value is 'standard and daylight savings time (if available) when its value is -'daylight. - -Conversion to daylight savings time is done according to -`calendar-daylight-savings-starts', `calendar-daylight-savings-ends', -`calendar-daylight-savings-starts-time', -`calendar-daylight-savings-ends-time', and -`calendar-daylight-savings-offset'." - - (let* ((rounded-abs-date (+ (calendar-absolute-from-gregorian date) - (/ (round (* 60 time)) 60.0 24.0))) - (dst (dst-in-effect rounded-abs-date)) - (time-zone (if dst - calendar-daylight-time-zone-name - calendar-standard-time-zone-name)) - (time (+ rounded-abs-date - (if dst (/ calendar-daylight-time-offset 24.0 60.0) 0)))) - (list (calendar-gregorian-from-absolute (truncate time)) - (* 24.0 (- time (truncate time))) - time-zone))) - -(provide 'cal-dst) - -;;; cal-dst.el ends here diff --git a/lisp/calendar/cal-french.el b/lisp/calendar/cal-french.el deleted file mode 100644 index 8f68841d229..00000000000 --- a/lisp/calendar/cal-french.el +++ /dev/null @@ -1,244 +0,0 @@ -;;; cal-french.el --- calendar functions for the French Revolutionary calendar. - -;; Copyright (C) 1988, 1989, 1992, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: French Revolutionary calendar, calendar, diary - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; diary.el that deal with the French Revolutionary calendar. - -;; Technical details of the French Revolutionary calendar can be found in -;; ``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. - -;; 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 - -;;; Code: - -(require 'calendar) - -(defvar french-calendar-accents - (and (char-table-p standard-display-table) - (equal (aref standard-display-table 161) [161])) - "True if diacritical marks are available.") - -(defconst french-calendar-epoch (calendar-absolute-from-gregorian '(9 22 1792)) - "Absolute date of start of French Revolutionary calendar = September 22, 1792.") - -(defconst french-calendar-month-name-array - (if french-calendar-accents - ["Vendémiaire" "Brumaire" "Frimaire" "Nivôse" "Pluviôse" "Ventôse" - "Germinal" "Floréal" "Prairial" "Messidor" "Thermidor" "Fructidor"] - ["Vende'miaire" "Brumaire" "Frimaire" "Nivo^se" "Pluvio^se" "Vento^se" - "Germinal" "Flore'al" "Prairial" "Messidor" "Thermidor" "Fructidor"])) - -(defconst french-calendar-day-name-array - ["Primidi" "Duodi" "Tridi" "Quartidi" "Quintidi" "Sextidi" "Septidi" - "Octidi" "Nonidi" "Decadi"]) - -(defconst french-calendar-special-days-array - (if french-calendar-accents - ["de la Vertu" "du Genie" "du Labour" "de la Raison" - "de la Récompense" "de la Révolution"] - ["de la Vertu" "du Genie" "du Labour" "de la Raison" "de la Re'compense" - "de la Re'volution"])) - -(defun french-calendar-leap-year-p (year) - "True if YEAR is a leap year on the French Revolutionary calendar. -For Gregorian years 1793 to 1805, the years of actual operation of the -calendar, uses historical practice based on equinoxes is followed (years 3, 7, -and 11 were leap years; 15 and 20 would have been leap years). For later -years uses the proposed rule of Romme (never adopted)--leap years fall every -four years except century years not divisible 400 and century years that are -multiples of 4000." - (or (memq year '(3 7 11));; Actual practice--based on equinoxes - (memq year '(15 20)) ;; Anticipated practice--based on equinoxes - (and (> year 20) ;; Romme's proposal--never adopted - (zerop (% year 4)) - (not (memq (% year 400) '(100 200 300))) - (not (zerop (% year 4000)))))) - -(defun french-calendar-last-day-of-month (month year) - "Return last day of MONTH, YEAR on the French Revolutionary calendar. -The 13th month is not really a month, but the 5 (6 in leap years) day period of -`sansculottides' at the end of the year." - (if (< month 13) - 30 - (if (french-calendar-leap-year-p year) - 6 - 5))) - -(defun calendar-absolute-from-french (date) - "Compute absolute date from French Revolutionary date 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))) - (+ (* 365 (1- year));; Days in prior years - ;; Leap days in prior years - (if (< year 20) - (/ year 4);; Actual and anticipated practice (years 3, 7, 11, 15) - ;; Romme's proposed rule (using the Principle of Inclusion/Exclusion) - (+ (/ (1- year) 4);; Luckily, there were 4 leap years before year 20 - (- (/ (1- year) 100)) - (/ (1- year) 400) - (- (/ (1- year) 4000)))) - (* 30 (1- month));; Days in prior months this year - day;; Days so far this month - (1- french-calendar-epoch))));; Days before start of calendar - -(defun calendar-french-from-absolute (date) - "Compute the French Revolutionary equivalent for absolute date DATE. -The result is a list of the form (MONTH DAY YEAR). -The absolute date is the number of days elapsed since the -\(imaginary) Gregorian date Sunday, December 31, 1 BC." - (if (< date french-calendar-epoch) - (list 0 0 0);; pre-French Revolutionary date - (let* ((approx ;; Approximation from below. - (/ (- date french-calendar-epoch) 366)) - (year ;; Search forward from the approximation. - (+ approx - (calendar-sum y approx - (>= date (calendar-absolute-from-french (list 1 1 (1+ y)))) - 1))) - (month ;; Search forward from Vendemiaire. - (1+ (calendar-sum m 1 - (> date - (calendar-absolute-from-french - (list m - (french-calendar-last-day-of-month m year) - year))) - 1))) - (day ;; Calculate the day by subtraction. - (- date - (1- (calendar-absolute-from-french (list month 1 year)))))) - (list month day year)))) - -(defun calendar-french-date-string (&optional date) - "String of French Revolutionary date of Gregorian DATE. -Returns the empty string if DATE is pre-French Revolutionary. -Defaults to today's date if DATE is not given." - (let* ((french-date (calendar-french-from-absolute - (calendar-absolute-from-gregorian - (or date (calendar-current-date))))) - (y (extract-calendar-year french-date)) - (m (extract-calendar-month french-date)) - (d (extract-calendar-day french-date))) - (cond - ((< y 1) "") - ((= m 13) (format (if french-calendar-accents - "Jour %s de l'Année %d de la Révolution" - "Jour %s de l'Anne'e %d de la Re'volution") - (aref french-calendar-special-days-array (1- d)) - y)) - (t (format - (if french-calendar-accents - "Décade %s, %s de %s de l'Année %d de la Révolution" - "De'cade %s, %s de %s de l'Anne'e %d de la Re'volution") - (make-string (1+ (/ (1- d) 10)) ?I) - (aref french-calendar-day-name-array (% (1- d) 10)) - (aref french-calendar-month-name-array (1- m)) - y))))) - -(defun calendar-print-french-date () - "Show the French Revolutionary calendar equivalent of the selected date." - (interactive) - (let ((f (calendar-french-date-string (calendar-cursor-to-date t)))) - (if (string-equal f "") - (message "Date is pre-French Revolution") - (message f)))) - -(defun calendar-goto-french-date (date &optional noecho) - "Move cursor to French Revolutionary date DATE. -Echo French Revolutionary date unless NOECHO is t." - (interactive - (let* ((year (calendar-read - (if french-calendar-accents - "Année de la Révolution (>0): " - "Anne'e de la Re'volution (>0): ") - '(lambda (x) (> x 0)) - (int-to-string - (extract-calendar-year - (calendar-french-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))))) - (month-list - (mapcar 'list - (append french-calendar-month-name-array - (if (french-calendar-leap-year-p year) - (mapcar - '(lambda (x) (concat "Jour " x)) - french-calendar-special-days-array) - (reverse - (cdr;; we don't want rev. day in a non-leap yr. - (reverse - (mapcar - '(lambda (x) (concat "Jour " x)) - french-calendar-special-days-array)))))))) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Mois ou Sansculottide: " - month-list - nil t)) - (calendar-make-alist - month-list - 1 - '(lambda (x) (capitalize (car x))))))) - (decade (if (> month 12) - 1 - (calendar-read - (if french-calendar-accents - "Décade (1-3): " - "De'cade (1-3): ") - '(lambda (x) (memq x '(1 2 3)))))) - (day (if (> month 12) - (- month 12) - (calendar-read - "Jour (1-10): " - '(lambda (x) (and (<= 1 x) (<= x 10)))))) - (month (if (> month 12) 13 month)) - (day (+ day (* 10 (1- decade))))) - (list (list month day year)))) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-french date))) - (or noecho (calendar-print-french-date))) - -(defun diary-french-date () - "French calendar equivalent of date diary entry." - (let ((f (calendar-french-date-string (calendar-cursor-to-date t)))) - (if (string-equal f "") - "Date is pre-French Revolution" - f))) - -(provide 'cal-french) - -;;; cal-french.el ends here diff --git a/lisp/calendar/cal-hebrew.el b/lisp/calendar/cal-hebrew.el deleted file mode 100644 index 23e6d694b08..00000000000 --- a/lisp/calendar/cal-hebrew.el +++ /dev/null @@ -1,1180 +0,0 @@ -;;; cal-hebrew.el --- calendar functions for the Hebrew calendar. - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: Nachum Dershowitz <nachum@cs.uiuc.edu> -;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: Hebrew calendar, calendar, diary - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; diary.el that deal with the Hebrew calendar. - -;; 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 - -;;; Code: - -(require 'calendar) - -(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-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 holiday-hebrew (month day string) - "Holiday on MONTH, DAY (Hebrew) called STRING. -If MONTH, DAY (Hebrew) is visible, the value returned is corresponding -Gregorian date in the form of the list (((month day year) STRING)). Returns -nil if it is not visible in the current calendar window." - (if (memq displayed-month;; This test is only to speed things up a bit; - (list ;; it works fine without the test too. - (if (< 11 month) (- month 11) (+ month 1)) - (if (< 10 month) (- month 10) (+ month 2)) - (if (< 9 month) (- month 9) (+ month 3)) - (if (< 8 month) (- month 8) (+ month 4)) - (if (< 7 month) (- month 7) (+ month 5)))) - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (let* ((start-date (calendar-absolute-from-gregorian - (list m1 1 y1))) - (end-date (calendar-absolute-from-gregorian - (list m2 (calendar-last-day-of-month m2 y2) y2))) - (hebrew-start (calendar-hebrew-from-absolute start-date)) - (hebrew-end (calendar-hebrew-from-absolute end-date)) - (hebrew-y1 (extract-calendar-year hebrew-start)) - (hebrew-y2 (extract-calendar-year hebrew-end))) - (setq year (if (< 6 month) hebrew-y2 hebrew-y1)) - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (list (list date string)))))))) - -(defun holiday-rosh-hashanah-etc () - "List of dates related to Rosh Hashanah, as visible in calendar window." - (if (or (< displayed-month 8) - (> displayed-month 11)) - nil;; None of the dates is visible - (let* ((abs-r-h (calendar-absolute-from-hebrew - (list 7 1 (+ displayed-year 3761)))) - (mandatory - (list - (list (calendar-gregorian-from-absolute abs-r-h) - (format "Rosh HaShanah %d" (+ 3761 displayed-year))) - (list (calendar-gregorian-from-absolute (+ abs-r-h 9)) - "Yom Kippur") - (list (calendar-gregorian-from-absolute (+ abs-r-h 14)) - "Sukkot") - (list (calendar-gregorian-from-absolute (+ abs-r-h 21)) - "Shemini Atzeret") - (list (calendar-gregorian-from-absolute (+ abs-r-h 22)) - "Simchat Torah"))) - (optional - (list - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-r-h 4))) - "Selichot (night)") - (list (calendar-gregorian-from-absolute (1- abs-r-h)) - "Erev Rosh HaShanah") - (list (calendar-gregorian-from-absolute (1+ abs-r-h)) - "Rosh HaShanah (second day)") - (list (calendar-gregorian-from-absolute - (if (= (% abs-r-h 7) 4) (+ abs-r-h 3) (+ abs-r-h 2))) - "Tzom Gedaliah") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (+ 7 abs-r-h))) - "Shabbat Shuvah") - (list (calendar-gregorian-from-absolute (+ abs-r-h 8)) - "Erev Yom Kippur") - (list (calendar-gregorian-from-absolute (+ abs-r-h 13)) - "Erev Sukkot") - (list (calendar-gregorian-from-absolute (+ abs-r-h 15)) - "Sukkot (second day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 16)) - "Hol Hamoed Sukkot (first day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 17)) - "Hol Hamoed Sukkot (second day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 18)) - "Hol Hamoed Sukkot (third day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 19)) - "Hol Hamoed Sukkot (fourth day)") - (list (calendar-gregorian-from-absolute (+ abs-r-h 20)) - "Hoshannah Rabbah"))) - (output-list - (filter-visible-calendar-holidays mandatory))) - (if all-hebrew-calendar-holidays - (setq output-list - (append - (filter-visible-calendar-holidays optional) - output-list))) - output-list))) - -(defun holiday-hanukkah () - "List of dates related to Hanukkah, as visible in calendar window." - (if (memq displayed-month;; This test is only to speed things up a bit; - '(10 11 12 1 2));; it works fine without the test too. - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y 1) - (let* ((h-y (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))))) - (abs-h (calendar-absolute-from-hebrew (list 9 25 h-y)))) - (filter-visible-calendar-holidays - (list - (list (calendar-gregorian-from-absolute (1- abs-h)) - "Erev Hanukkah") - (list (calendar-gregorian-from-absolute abs-h) - "Hanukkah (first day)") - (list (calendar-gregorian-from-absolute (1+ abs-h)) - "Hanukkah (second day)") - (list (calendar-gregorian-from-absolute (+ abs-h 2)) - "Hanukkah (third day)") - (list (calendar-gregorian-from-absolute (+ abs-h 3)) - "Hanukkah (fourth day)") - (list (calendar-gregorian-from-absolute (+ abs-h 4)) - "Hanukkah (fifth day)") - (list (calendar-gregorian-from-absolute (+ abs-h 5)) - "Hanukkah (sixth day)") - (list (calendar-gregorian-from-absolute (+ abs-h 6)) - "Hanukkah (seventh day)") - (list (calendar-gregorian-from-absolute (+ abs-h 7)) - "Hanukkah (eighth day)"))))))) - -(defun holiday-passover-etc () - "List of dates related to Passover, as visible in calendar window." - (if (< 7 displayed-month) - nil;; None of the dates is visible - (let* ((abs-p (calendar-absolute-from-hebrew - (list 1 15 (+ displayed-year 3760)))) - (mandatory - (list - (list (calendar-gregorian-from-absolute abs-p) - "Passover") - (list (calendar-gregorian-from-absolute (+ abs-p 50)) - "Shavuot"))) - (optional - (list - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-p 43))) - "Shabbat Shekalim") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-p 30))) - "Shabbat Zachor") - (list (calendar-gregorian-from-absolute - (if (= (% abs-p 7) 2) (- abs-p 33) (- abs-p 31))) - "Fast of Esther") - (list (calendar-gregorian-from-absolute (- abs-p 31)) - "Erev Purim") - (list (calendar-gregorian-from-absolute (- abs-p 30)) - "Purim") - (list (calendar-gregorian-from-absolute - (if (zerop (% abs-p 7)) (- abs-p 28) (- abs-p 29))) - "Shushan Purim") - (list (calendar-gregorian-from-absolute - (- (calendar-dayname-on-or-before 6 (- abs-p 14)) 7)) - "Shabbat Parah") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (- abs-p 14))) - "Shabbat HaHodesh") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (1- abs-p))) - "Shabbat HaGadol") - (list (calendar-gregorian-from-absolute (1- abs-p)) - "Erev Passover") - (list (calendar-gregorian-from-absolute (1+ abs-p)) - "Passover (second day)") - (list (calendar-gregorian-from-absolute (+ abs-p 2)) - "Hol Hamoed Passover (first day)") - (list (calendar-gregorian-from-absolute (+ abs-p 3)) - "Hol Hamoed Passover (second day)") - (list (calendar-gregorian-from-absolute (+ abs-p 4)) - "Hol Hamoed Passover (third day)") - (list (calendar-gregorian-from-absolute (+ abs-p 5)) - "Hol Hamoed Passover (fourth day)") - (list (calendar-gregorian-from-absolute (+ abs-p 6)) - "Passover (seventh day)") - (list (calendar-gregorian-from-absolute (+ abs-p 7)) - "Passover (eighth day)") - (list (calendar-gregorian-from-absolute (+ abs-p 12)) - "Yom HaShoah") - (list (calendar-gregorian-from-absolute - (if (zerop (% abs-p 7)) - (+ abs-p 18) - (if (= (% abs-p 7) 6) - (+ abs-p 19) - (+ abs-p 20)))) - "Yom HaAtzma'ut") - (list (calendar-gregorian-from-absolute (+ abs-p 33)) - "Lag BaOmer") - (list (calendar-gregorian-from-absolute (+ abs-p 43)) - "Yom Yerushalim") - (list (calendar-gregorian-from-absolute (+ abs-p 49)) - "Erev Shavuot") - (list (calendar-gregorian-from-absolute (+ abs-p 51)) - "Shavuot (second day)"))) - (output-list - (filter-visible-calendar-holidays mandatory))) - (if all-hebrew-calendar-holidays - (setq output-list - (append - (filter-visible-calendar-holidays optional) - output-list))) - output-list))) - -(defun holiday-tisha-b-av-etc () - "List of dates around Tisha B'Av, as visible in calendar window." - (if (or (< displayed-month 5) - (> displayed-month 9)) - nil;; None of the dates is visible - (let* ((abs-t-a (calendar-absolute-from-hebrew - (list 5 9 (+ displayed-year 3760))))) - - (filter-visible-calendar-holidays - (list - (list (calendar-gregorian-from-absolute - (if (= (% abs-t-a 7) 6) (- abs-t-a 20) (- abs-t-a 21))) - "Tzom Tammuz") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 abs-t-a)) - "Shabbat Hazon") - (list (calendar-gregorian-from-absolute - (if (= (% abs-t-a 7) 6) (1+ abs-t-a) abs-t-a)) - "Tisha B'Av") - (list (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 6 (+ abs-t-a 7))) - "Shabbat Nahamu")))))) - -(defun list-hebrew-diary-entries () - "Add any Hebrew date entries from the diary file to `diary-entries-list'. -Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol' -\(normally an `H'). The same diary date forms govern the style of the Hebrew -calendar entries, except that the Hebrew month names must be spelled in full. -The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being -Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a -common Hebrew year. If a Hebrew date diary entry begins with a -`diary-nonmarking-symbol', the entry will appear in the diary listing, but will -not be marked in the calendar. This function is provided for use with the -`nongregorian-diary-listing-hook'." - (if (< 0 number) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (gdate original-date) - (mark (regexp-quote diary-nonmarking-symbol))) - (calendar-for-loop i from 1 to number do - (let* ((d diary-date-forms) - (hdate (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian gdate))) - (month (extract-calendar-month hdate)) - (day (extract-calendar-day hdate)) - (year (extract-calendar-year hdate))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name gdate) "\\|" - (substring (calendar-day-name gdate) 0 3) ".?")) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year) - (monthname - (concat - "\\*\\|" - (calendar-month-name month))) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?" - (regexp-quote hebrew-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start (point) ?\^M ?\n t) - (add-to-diary-list - gdate (buffer-substring entry-start (point))))))) - (setq d (cdr d)))) - (setq gdate - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian gdate))))) - (set-buffer-modified-p diary-modified)) - (goto-char (point-min)))) - -(defun mark-hebrew-diary-entries () - "Mark days in the calendar window that have Hebrew date diary entries. -Each entry in diary-file (or included files) visible in the calendar window -is marked. Hebrew date entries are prefaced by a hebrew-diary-entry-symbol -\(normally an `H'). The same diary-date-forms govern the style of the Hebrew -calendar entries, except that the Hebrew month names must be spelled in full. -The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being -Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a -common Hebrew year. Hebrew date diary entries that begin with a -diary-nonmarking symbol will not be marked in the calendar. This function -is provided for use as part of the nongregorian-diary-marking-hook." - (let ((d diary-date-forms)) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-hebrew-month-name-array-leap-year t) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote hebrew-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))) - (y (+ (string-to-int y-str) - (* 100 (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq - mm - (cdr - (assoc - (capitalize mm-name) - (calendar-make-alist - calendar-hebrew-month-name-array-leap-year)))))) - (mark-hebrew-calendar-date-pattern mm dd yy))))) - (setq d (cdr d))))) - -(defun mark-hebrew-calendar-date-pattern (month day year) - "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (if (and (/= 0 month) (/= 0 day)) - (if (/= 0 year) - ;; Fully specified Hebrew date. - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))) - ;; Month and day in any year--this taken from the holiday stuff. - (if (memq displayed-month;; This test is only to speed things up a - (list ;; bit; it works fine without the test too. - (if (< 11 month) (- month 11) (+ month 1)) - (if (< 10 month) (- month 10) (+ month 2)) - (if (< 9 month) (- month 9) (+ month 3)) - (if (< 8 month) (- month 8) (+ month 4)) - (if (< 7 month) (- month 7) (+ month 5)))) - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (let* ((start-date (calendar-absolute-from-gregorian - (list m1 1 y1))) - (end-date (calendar-absolute-from-gregorian - (list m2 - (calendar-last-day-of-month m2 y2) - y2))) - (hebrew-start - (calendar-hebrew-from-absolute start-date)) - (hebrew-end (calendar-hebrew-from-absolute end-date)) - (hebrew-y1 (extract-calendar-year hebrew-start)) - (hebrew-y2 (extract-calendar-year hebrew-end))) - (setq year (if (< 6 month) hebrew-y2 hebrew-y1)) - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-hebrew - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))))))) - ;; Not one of the simple cases--check all visible dates for match. - ;; Actually, the following code takes care of ALL of the cases, but - ;; it's much too slow to be used for the simple (common) cases. - (let ((m displayed-month) - (y displayed-year) - (first-date) - (last-date)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian - (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (calendar-for-loop date from first-date to last-date do - (let* ((h-date (calendar-hebrew-from-absolute date)) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date))) - (and (or (zerop month) - (= month h-month)) - (or (zerop day) - (= day h-day)) - (or (zerop year) - (= year h-year)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date))))))))) - -(defun insert-hebrew-diary-entry (arg) - "Insert a diary entry. -For the Hebrew date corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))) - nil t)) - arg))) - -(defun insert-monthly-hebrew-diary-entry (arg) - "Insert a monthly diary entry. -For the day of the Hebrew month corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style '(day " * ") '("* " day ))) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-yearly-hebrew-diary-entry (arg) - "Insert an annual diary entry. -For the day of the Hebrew year corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day))) - (calendar-month-name-array - calendar-hebrew-month-name-array-leap-year)) - (make-diary-entry - (concat - hebrew-diary-entry-symbol - (calendar-date-string - (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -;;;###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 diary-hebrew-date () - "Hebrew calendar equivalent of date diary entry." - (format "Hebrew date (until sunset): %s" (calendar-hebrew-date-string date))) - -(defun diary-omer () - "Omer count diary entry. -Entry applies if date is within 50 days after Passover." - (let* ((passover - (calendar-absolute-from-hebrew - (list 1 15 (+ (extract-calendar-year date) 3760)))) - (omer (- (calendar-absolute-from-gregorian date) passover)) - (week (/ omer 7)) - (day (% omer 7))) - (if (and (> omer 0) (< omer 50)) - (format "Day %d%s of the omer (until sunset)" - omer - (if (zerop week) - "" - (format ", that is, %d week%s%s" - week - (if (= week 1) "" "s") - (if (zerop day) - "" - (format " and %d day%s" - day (if (= day 1) "" "s"))))))))) - -(defun diary-yahrzeit (death-month death-day death-year) - "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before. -Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed -to be the name of the person. Date of death is on the *civil* calendar; -although the date of death is specified by the civil calendar, the proper -Hebrew calendar yahrzeit is determined. If `european-calendar-style' is t, the -order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR." - (let* ((h-date (calendar-hebrew-from-absolute - (calendar-absolute-from-gregorian - (if european-calendar-style - (list death-day death-month death-year) - (list death-month death-day death-year))))) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date)) - (d (calendar-absolute-from-gregorian date)) - (yr (extract-calendar-year (calendar-hebrew-from-absolute d))) - (diff (- yr h-year)) - (y (hebrew-calendar-yahrzeit h-date yr))) - (if (and (> diff 0) (or (= y d) (= y (1+ d)))) - (format "Yahrzeit of %s%s: %d%s anniversary" - entry - (if (= y d) "" " (evening)") - diff - (cond ((= (% diff 10) 1) "st") - ((= (% diff 10) 2) "nd") - ((= (% diff 10) 3) "rd") - (t "th")))))) - -(defun diary-rosh-hodesh () - "Rosh Hodesh diary entry. -Entry applies if date is Rosh Hodesh, the day before, or the Saturday before." - (let* ((d (calendar-absolute-from-gregorian date)) - (h-date (calendar-hebrew-from-absolute d)) - (h-month (extract-calendar-month h-date)) - (h-day (extract-calendar-day h-date)) - (h-year (extract-calendar-year h-date)) - (leap-year (hebrew-calendar-leap-year-p h-year)) - (last-day (hebrew-calendar-last-day-of-month h-month h-year)) - (h-month-names - (if leap-year - calendar-hebrew-month-name-array-leap-year - calendar-hebrew-month-name-array-common-year)) - (this-month (aref h-month-names (1- h-month))) - (h-yesterday (extract-calendar-day - (calendar-hebrew-from-absolute (1- d))))) - (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7))) - (format - "Rosh Hodesh %s" - (if (= h-day 30) - (format - "%s (first day)" - ;; next month must be in the same year since this - ;; month can't be the last month of the year since - ;; it has 30 days - (aref h-month-names h-month)) - (if (= h-yesterday 30) - (format "%s (second day)" this-month) - this-month))) - (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarhim - (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day)) - (format "Mevarhim Rosh Hodesh %s (%s)" - (aref h-month-names - (if (= h-month - (hebrew-calendar-last-month-of-year - h-year)) - 0 h-month)) - (aref calendar-day-name-array (- 29 h-day)))) - ((and (< h-day 30) (> h-day 22) (= 30 last-day)) - (format "Mevarhim Rosh Hodesh %s (%s-%s)" - (aref h-month-names h-month) - (if (= h-day 29) - "tomorrow" - (aref calendar-day-name-array (- 29 h-day))) - (aref calendar-day-name-array - (% (- 30 h-day) 7))))) - (if (and (= h-day 29) (/= h-month 6)) - (format "Erev Rosh Hodesh %s" - (aref h-month-names - (if (= h-month - (hebrew-calendar-last-month-of-year - h-year)) - 0 h-month)))))))) - -(defun diary-parasha () - "Parasha diary entry--entry applies if date is a Saturday." - (let ((d (calendar-absolute-from-gregorian date))) - (if (= (% d 7) 6);; Saturday - (let* - ((h-year (extract-calendar-year - (calendar-hebrew-from-absolute d))) - (rosh-hashanah - (calendar-absolute-from-hebrew (list 7 1 h-year))) - (passover - (calendar-absolute-from-hebrew (list 1 15 h-year))) - (rosh-hashanah-day - (aref calendar-day-name-array (% rosh-hashanah 7))) - (passover-day - (aref calendar-day-name-array (% passover 7))) - (long-h (hebrew-calendar-long-heshvan-p h-year)) - (short-k (hebrew-calendar-short-kislev-p h-year)) - (type (cond ((and long-h (not short-k)) "complete") - ((and (not long-h) short-k) "incomplete") - (t "regular"))) - (year-format - (symbol-value - (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah - rosh-hashanah-day type passover-day)))) - (first-saturday;; of Hebrew year - (calendar-dayname-on-or-before 6 (+ 6 rosh-hashanah))) - (saturday;; which Saturday of the Hebrew year - (/ (- d first-saturday) 7)) - (parasha (aref year-format saturday))) - (if parasha - (format - "Parashat %s" - (if (listp parasha);; Israel differs from diaspora - (if (car parasha) - (format "%s (diaspora), %s (Israel)" - (hebrew-calendar-parasha-name (car parasha)) - (hebrew-calendar-parasha-name (cdr parasha))) - (format "%s (Israel)" - (hebrew-calendar-parasha-name (cdr parasha)))) - (hebrew-calendar-parasha-name parasha)))))))) - -(defvar hebrew-calendar-parashiot-names -["Bereshith" "Noah" "Lech L'cha" "Vayera" "Hayei Sarah" "Toledoth" - "Vayetze" "Vayishlah" "Vayeshev" "Mikketz" "Vayiggash" "Vayhi" - "Shemoth" "Vaera" "Bo" "Beshallah" "Yithro" "Mishpatim" - "Terumah" "Tetzavveh" "Ki Tissa" "Vayakhel" "Pekudei" "Vayikra" - "Tzav" "Shemini" "Tazria" "Metzora" "Aharei Moth" "Kedoshim" - "Emor" "Behar" "Behukkotai" "Bemidbar" "Naso" "Behaalot'cha" - "Shelah L'cha" "Korah" "Hukkath" "Balak" "Pinhas" "Mattoth" - "Masei" "Devarim" "Vaethanan" "Ekev" "Reeh" "Shofetim" - "Ki Tetze" "Ki Tavo" "Nitzavim" "Vayelech" "Haazinu"] - "The names of the parashiot in the Torah.") - -;; The seven ordinary year types (keviot) - -(defconst hebrew-calendar-year-Saturday-incomplete-Sunday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have -29 days), and has Passover start on Sunday.") - -(defconst hebrew-calendar-year-Saturday-complete-Tuesday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Monday-incomplete-Tuesday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Monday-complete-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have -30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Tuesday-regular-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Thursday-regular-Saturday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23 - 24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30) - (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48 - 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Thursday-complete-Sunday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Sunday.") - -;; The seven leap year types (keviot) - -(defconst hebrew-calendar-year-Saturday-incomplete-Tuesday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42] - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Tuesday.") - -(defconst hebrew-calendar-year-Saturday-complete-Thursday - [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each -have 30 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Monday-incomplete-Thursday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36) - (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each -have 29 days), and has Passover start on Thursday.") - -(defconst hebrew-calendar-year-Monday-complete-Saturday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32) - (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39) - (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have -30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Tuesday-regular-Saturday - [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32) - (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39) - (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and -Kislev has 30 days), and has Passover start on Saturday.") - -(defconst hebrew-calendar-year-Thursday-incomplete-Sunday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42 - 43 44 45 46 47 48 49 50] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both -have 29 days), and has Passover start on Sunday.") - -(defconst hebrew-calendar-year-Thursday-complete-Tuesday - [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 - 23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42 - 43 44 45 46 47 48 49 [50 51]] - "The structure of the parashiot. -Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both -have 30 days), and has Passover start on Tuesday.") - -(defun hebrew-calendar-parasha-name (p) - "Name(s) corresponding to parasha P." - (if (arrayp p);; combined parasha - (format "%s/%s" - (aref hebrew-calendar-parashiot-names (aref p 0)) - (aref hebrew-calendar-parashiot-names (aref p 1))) - (aref hebrew-calendar-parashiot-names p))) - -(provide 'cal-hebrew) - -;;; cal-hebrew.el ends here diff --git a/lisp/calendar/cal-islam.el b/lisp/calendar/cal-islam.el deleted file mode 100644 index a8e038e52eb..00000000000 --- a/lisp/calendar/cal-islam.el +++ /dev/null @@ -1,492 +0,0 @@ -;;; cal-islam.el --- calendar functions for the Islamic calendar. - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: Islamic calendar, calendar, diary - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; diary.el that deal with the Islamic calendar. - -;; 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 - -;;; Code: - -(require 'cal-julian) - -(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"]) - -(defvar calendar-islamic-epoch (calendar-absolute-from-julian '(7 16 622)) - "Absolute date of start of Islamic calendar = August 29, 284 A.D. (Julian).") - -(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 - (1- calendar-islamic-epoch)))) ;; 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 calendar-islamic-epoch) - (list 0 0 0);; pre-Islamic date - (let* ((approx (/ (- date calendar-islamic-epoch) - 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)))) - -(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-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 diary-islamic-date () - "Islamic calendar equivalent of date diary entry." - (let ((i (calendar-islamic-date-string (calendar-cursor-to-date t)))) - (if (string-equal i "") - "Date is pre-Islamic" - (format "Islamic date (until sunset): %s" i)))) - -(defun holiday-islamic (month day string) - "Holiday on MONTH, DAY (Islamic) called STRING. -If MONTH, DAY (Islamic) is visible, the value returned is corresponding -Gregorian date in the form of the list (((month day year) STRING)). Returns -nil if it is not visible in the current calendar window." - (let* ((islamic-date (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 15 displayed-year)))) - (m (extract-calendar-month islamic-date)) - (y (extract-calendar-year islamic-date)) - (date)) - (if (< m 1) - nil;; Islamic calendar doesn't apply. - (increment-calendar-month m y (- 10 month)) - (if (> m 7);; Islamic date might be visible - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic (list month day y))))) - (if (calendar-date-is-visible-p date) - (list (list date string)))))))) - -(defun list-islamic-diary-entries () - "Add any Islamic date entries from the diary file to `diary-entries-list'. -Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol' -\(normally an `I'). The same diary date forms govern the style of the Islamic -calendar entries, except that the Islamic month names must be spelled in full. -The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being -Dhu al-Hijjah. If an Islamic date diary entry begins with a -`diary-nonmarking-symbol', the entry will appear in the diary listing, but will -not be marked in the calendar. This function is provided for use with the -`nongregorian-diary-listing-hook'." - (if (< 0 number) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (gdate original-date) - (mark (regexp-quote diary-nonmarking-symbol))) - (calendar-for-loop i from 1 to number do - (let* ((d diary-date-forms) - (idate (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian gdate))) - (month (extract-calendar-month idate)) - (day (extract-calendar-day idate)) - (year (extract-calendar-year idate))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name gdate) "\\|" - (substring (calendar-day-name gdate) 0 3) ".?")) - (calendar-month-name-array - calendar-islamic-month-name-array) - (monthname - (concat - "\\*\\|" - (calendar-month-name month))) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?" - (regexp-quote islamic-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start (point) ?\^M ?\n t) - (add-to-diary-list - gdate (buffer-substring entry-start (point))))))) - (setq d (cdr d)))) - (setq gdate - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian gdate))))) - (set-buffer-modified-p diary-modified)) - (goto-char (point-min)))) - -(defun mark-islamic-diary-entries () - "Mark days in the calendar window that have Islamic date diary entries. -Each entry in diary-file (or included files) visible in the calendar window -is marked. Islamic date entries are prefaced by a islamic-diary-entry-symbol -\(normally an `I'). The same diary-date-forms govern the style of the Islamic -calendar entries, except that the Islamic month names must be spelled in full. -The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being -Dhu al-Hijjah. Islamic date diary entries that begin with a -diary-nonmarking-symbol will not be marked in the calendar. This function is -provided for use as part of the nongregorian-diary-marking-hook." - (let ((d diary-date-forms)) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-islamic-month-name-array t) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote islamic-diary-entry-symbol) - "\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date))))) - (y (+ (string-to-int y-str) - (* 100 (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq mm - (cdr (assoc - (capitalize mm-name) - (calendar-make-alist - calendar-islamic-month-name-array)))))) - (mark-islamic-calendar-date-pattern mm dd yy))))) - (setq d (cdr d))))) - -(defun mark-islamic-calendar-date-pattern (month day year) - "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (if (and (/= 0 month) (/= 0 day)) - (if (/= 0 year) - ;; Fully specified Islamic date. - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic - (list month day year))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))) - ;; Month and day in any year--this taken from the holiday stuff. - (let* ((islamic-date (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (list displayed-month 15 displayed-year)))) - (m (extract-calendar-month islamic-date)) - (y (extract-calendar-year islamic-date)) - (date)) - (if (< m 1) - nil;; Islamic calendar doesn't apply. - (increment-calendar-month m y (- 10 month)) - (if (> m 7);; Islamic date might be visible - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-islamic - (list month day y))))) - (if (calendar-date-is-visible-p date) - (mark-visible-calendar-date date))))))) - ;; Not one of the simple cases--check all visible dates for match. - ;; Actually, the following code takes care of ALL of the cases, but - ;; it's much too slow to be used for the simple (common) cases. - (let ((m displayed-month) - (y displayed-year) - (first-date) - (last-date)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian - (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (calendar-for-loop date from first-date to last-date do - (let* ((i-date (calendar-islamic-from-absolute date)) - (i-month (extract-calendar-month i-date)) - (i-day (extract-calendar-day i-date)) - (i-year (extract-calendar-year i-date))) - (and (or (zerop month) - (= month i-month)) - (or (zerop day) - (= day i-day)) - (or (zerop year) - (= year i-year)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date))))))))) - -(defun insert-islamic-diary-entry (arg) - "Insert a diary entry. -For the Islamic date corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))) - nil t)) - arg))) - -(defun insert-monthly-islamic-diary-entry (arg) - "Insert a monthly diary entry. -For the day of the Islamic month corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style '(day " * ") '("* " day ))) - (calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(defun insert-yearly-islamic-diary-entry (arg) - "Insert an annual diary entry. -For the day of the Islamic year corresponding to the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day))) - (calendar-month-name-array calendar-islamic-month-name-array)) - (make-diary-entry - (concat - islamic-diary-entry-symbol - (calendar-date-string - (calendar-islamic-from-absolute - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - arg))) - -(provide 'cal-islam) - -;;; cal-islam.el ends here diff --git a/lisp/calendar/cal-iso.el b/lisp/calendar/cal-iso.el deleted file mode 100644 index 130f5bc97d8..00000000000 --- a/lisp/calendar/cal-iso.el +++ /dev/null @@ -1,126 +0,0 @@ -;;; cal-iso.el --- calendar functions for the ISO calendar. - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: ISO calendar, calendar, diary - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; diary.el that deal with the ISO calendar. - -;; 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 - -;;; Code: - -(require 'calendar) - -(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-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 diary-iso-date () - "ISO calendar equivalent of date diary entry." - (format "ISO date: %s" (calendar-iso-date-string date))) - -(provide 'cal-iso) - -;;; cal-iso.el ends here diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el deleted file mode 100644 index 4437789e7fe..00000000000 --- a/lisp/calendar/cal-julian.el +++ /dev/null @@ -1,207 +0,0 @@ -;;; cal-julian.el --- calendar functions for the Julian calendar. - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: Julian calendar, Julian day number, calendar, diary - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; diary.el that deal with the Julian calendar. - -;; 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 - -;;; Code: - -(require 'calendar) - -(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 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 holiday-julian (month day string) - "Holiday on MONTH, DAY (Julian) called STRING. -If MONTH, DAY (Julian) is visible, the value returned is corresponding -Gregorian date in the form of the list (((month day year) STRING)). Returns -nil if it is not visible in the current calendar window." - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year) - (year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (let* ((start-date (calendar-absolute-from-gregorian - (list m1 1 y1))) - (end-date (calendar-absolute-from-gregorian - (list m2 (calendar-last-day-of-month m2 y2) y2))) - (julian-start (calendar-julian-from-absolute start-date)) - (julian-end (calendar-julian-from-absolute end-date)) - (julian-y1 (extract-calendar-year julian-start)) - (julian-y2 (extract-calendar-year julian-end))) - (setq year (if (< 10 month) julian-y1 julian-y2)) - (let ((date (calendar-gregorian-from-absolute - (calendar-absolute-from-julian - (list month day year))))) - (if (calendar-date-is-visible-p date) - (list (list date string))))))) - -(defun diary-julian-date () - "Julian calendar equivalent of date diary entry." - (format "Julian date: %s" (calendar-julian-date-string date))) - -(defun calendar-absolute-from-astro (d) - "Absolute date of astronomical (Julian) day number D." - (- d 1721424.5)) - -(defun calendar-astro-from-absolute (d) - "Astronomical (Julian) day number of absolute date D." - (+ d 1721424.5)) - -(defun calendar-astro-date-string (&optional date) - "String of astronomical (Julian) day number after noon UTC of Gregorian DATE. -Defaults to today's date if DATE is not given." - (int-to-string - (ceiling - (calendar-astro-from-absolute - (calendar-absolute-from-gregorian - (or date (calendar-current-date))))))) - -(defun calendar-print-astro-day-number () - "Show astronomical (Julian) day number after noon UTC on date shown by cursor." - (interactive) - (message - "Astronomical (Julian) day number (at noon UTC): %s.0" - (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 - (floor - (calendar-absolute-from-astro daynumber)))) - (or noecho (calendar-print-astro-day-number))) - -(defun diary-astro-day-number () - "Astronomical (Julian) day number diary entry." - (format "Astronomical (Julian) day number %s" - (calendar-astro-date-string date))) - -(provide 'cal-julian) - -;;; cal-julian.el ends here diff --git a/lisp/calendar/cal-mayan.el b/lisp/calendar/cal-mayan.el deleted file mode 100644 index 6b7b1b70027..00000000000 --- a/lisp/calendar/cal-mayan.el +++ /dev/null @@ -1,382 +0,0 @@ -;;; cal-mayan.el --- calendar functions for the Mayan calendars. - -;; Copyright (C) 1992, 1993, 1995 Free Software Foundation, Inc. - -;; Author: Stewart M. Clamen <clamen@cs.cmu.edu> -;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: Mayan calendar, Maya, calendar, diary - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; diary.el that deal with the Mayan calendar. It was written jointly by - -;; Stewart M. Clamen School of Computer Science -;; clamen@cs.cmu.edu Carnegie Mellon University -;; 5000 Forbes Avenue -;; Pittsburgh, PA 15213 - -;; and - -;; 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 - -;; Comments, improvements, and bug reports should be sent to Reingold. - -;; Technical details of the Mayan calendrical calculations can be found in -;; ``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. - -;;; Code: - -(require 'calendar) - -(defconst calendar-mayan-days-before-absolute-zero 1137140 - "Number of days of the Mayan calendar epoch before absolute day 0. -According to the Goodman-Martinez-Thompson correlation. This correlation is -not universally accepted, as it still a subject of astro-archeological -research. Using 1232041 will give you Spinden's correlation; using -1142840 will give you Hochleitner's correlation.") - -(defconst calendar-mayan-haab-at-epoch '(8 . 18) - "Mayan haab date at the epoch.") - -(defconst calendar-mayan-haab-month-name-array - ["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax" - "Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"]) - -(defconst calendar-mayan-tzolkin-at-epoch '(4 . 20) - "Mayan tzolkin date at the epoch.") - -(defconst calendar-mayan-tzolkin-names-array - ["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc" - "Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"]) - -(defun calendar-mayan-long-count-from-absolute (date) - "Compute the Mayan long count corresponding to the absolute DATE." - (let ((long-count (+ date calendar-mayan-days-before-absolute-zero))) - (let* ((baktun (/ long-count 144000)) - (remainder (% long-count 144000)) - (katun (/ remainder 7200)) - (remainder (% remainder 7200)) - (tun (/ remainder 360)) - (remainder (% remainder 360)) - (uinal (/ remainder 20)) - (kin (% remainder 20))) - (list baktun katun tun uinal kin)))) - -(defun calendar-mayan-long-count-to-string (mayan-long-count) - "Convert MAYAN-LONG-COUNT into traditional written form." - (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count))) - -(defun calendar-string-to-mayan-long-count (str) - "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of nums." - (let ((rlc nil) - (c (length str)) - (cc 0)) - (condition-case condition - (progn - (while (< cc c) - (let* ((start (string-match "[0-9]+" str cc)) - (end (match-end 0)) - datum) - (setq datum (read (substring str start end))) - (setq rlc (cons datum rlc)) - (setq cc end))) - (if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil))) - (invalid-read-syntax nil)) - (reverse rlc))) - -(defun calendar-mayan-haab-from-absolute (date) - "Convert absolute DATE into a Mayan haab date (a pair)." - (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero)) - (day-of-haab - (% (+ long-count - (car calendar-mayan-haab-at-epoch) - (* 20 (1- (cdr calendar-mayan-haab-at-epoch)))) - 365)) - (day (% day-of-haab 20)) - (month (1+ (/ day-of-haab 20)))) - (cons day month))) - -(defun calendar-mayan-haab-difference (date1 date2) - "Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2." - (mod (+ (* 20 (- (cdr date2) (cdr date1))) - (- (car date2) (car date1))) - 365)) - -(defun calendar-mayan-haab-on-or-before (haab-date date) - "Absolute date of latest HAAB-DATE on or before absolute DATE." - (- date - (% (- date - (calendar-mayan-haab-difference - (calendar-mayan-haab-from-absolute 0) haab-date)) - 365))) - -(defun calendar-next-haab-date (haab-date &optional noecho) - "Move cursor to next instance of Mayan HAAB-DATE. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-haab-date))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-mayan-haab-on-or-before - haab-date - (+ 365 - (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-previous-haab-date (haab-date &optional noecho) - "Move cursor to previous instance of Mayan HAAB-DATE. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-haab-date))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-mayan-haab-on-or-before - haab-date - (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-mayan-haab-to-string (haab) - "Convert Mayan haab date (a pair) into its traditional written form." - (let ((month (cdr haab)) - (day (car haab))) - ;; 19th month consists of 5 special days - (if (= month 19) - (format "%d Uayeb" day) - (format "%d %s" - day - (aref calendar-mayan-haab-month-name-array (1- month)))))) - -(defun calendar-mayan-tzolkin-from-absolute (date) - "Convert absolute DATE into a Mayan tzolkin date (a pair)." - (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero)) - (day (calendar-mod - (+ long-count (car calendar-mayan-tzolkin-at-epoch)) - 13)) - (name (calendar-mod - (+ long-count (cdr calendar-mayan-tzolkin-at-epoch)) - 20))) - (cons day name))) - -(defun calendar-mayan-tzolkin-difference (date1 date2) - "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2." - (let ((number-difference (- (car date2) (car date1))) - (name-difference (- (cdr date2) (cdr date1)))) - (mod (+ number-difference - (* 13 (mod (* 3 (- number-difference name-difference)) - 20))) - 260))) - -(defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date) - "Absolute date of latest TZOLKIN-DATE on or before absolute DATE." - (- date - (% (- date (calendar-mayan-tzolkin-difference - (calendar-mayan-tzolkin-from-absolute 0) - tzolkin-date)) - 260))) - -(defun calendar-next-tzolkin-date (tzolkin-date &optional noecho) - "Move cursor to next instance of Mayan TZOLKIN-DATE. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-tzolkin-date))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-mayan-tzolkin-on-or-before - tzolkin-date - (+ 260 - (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho) - "Move cursor to previous instance of Mayan TZOLKIN-DATE. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-tzolkin-date))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-mayan-tzolkin-on-or-before - tzolkin-date - (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date)))))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-mayan-tzolkin-to-string (tzolkin) - "Convert Mayan tzolkin date (a pair) into its traditional written form." - (format "%d %s" - (car tzolkin) - (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin))))) - -(defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date) - "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE. -Latest such date on or before DATE. -Returns nil if such a tzolkin-haab combination is impossible." - (let* ((haab-difference - (calendar-mayan-haab-difference - (calendar-mayan-haab-from-absolute 0) - haab-date)) - (tzolkin-difference - (calendar-mayan-tzolkin-difference - (calendar-mayan-tzolkin-from-absolute 0) - tzolkin-date)) - (difference (- tzolkin-difference haab-difference))) - (if (= (% difference 5) 0) - (- date - (mod (- date - (+ haab-difference (* 365 difference))) - 18980)) - nil))) - -(defun calendar-read-mayan-haab-date () - "Prompt for a Mayan haab date" - (let* ((completion-ignore-case t) - (haab-day (calendar-read - "Haab kin (0-19): " - '(lambda (x) (and (>= x 0) (< x 20))))) - (haab-month-list (append calendar-mayan-haab-month-name-array - (and (< haab-day 5) '("Uayeb")))) - (haab-month (cdr - (assoc - (capitalize - (completing-read "Haab uinal: " - (mapcar 'list haab-month-list) - nil t)) - (calendar-make-alist - haab-month-list 1 'capitalize))))) - (cons haab-day haab-month))) - -(defun calendar-read-mayan-tzolkin-date () - "Prompt for a Mayan tzolkin date" - (let* ((completion-ignore-case t) - (tzolkin-count (calendar-read - "Tzolkin kin (1-13): " - '(lambda (x) (and (> x 0) (< x 14))))) - (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil)) - (tzolkin-name (cdr - (assoc - (capitalize - (completing-read "Tzolkin uinal: " - (mapcar 'list tzolkin-name-list) - nil t)) - (calendar-make-alist - tzolkin-name-list 1 'capitalize))))) - (cons tzolkin-count tzolkin-name))) - -(defun calendar-next-calendar-round-date - (tzolkin-date haab-date &optional noecho) - "Move cursor to next instance of Mayan HAAB-DATE TZOLKIN-DATE combination. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-tzolkin-date) - (calendar-read-mayan-haab-date))) - (let ((date (calendar-mayan-tzolkin-haab-on-or-before - tzolkin-date haab-date - (+ 18980 (calendar-absolute-from-gregorian - (calendar-cursor-to-date)))))) - (if (not date) - (error "%s, %s does not exist in the Mayan calendar round" - (calendar-mayan-tzolkin-to-string tzolkin-date) - (calendar-mayan-haab-to-string haab-date)) - (calendar-goto-date (calendar-gregorian-from-absolute date)) - (or noecho (calendar-print-mayan-date))))) - -(defun calendar-previous-calendar-round-date - (tzolkin-date haab-date &optional noecho) - "Move to previous instance of Mayan TZOLKIN-DATE HAAB-DATE combination. -Echo Mayan date if NOECHO is t." - (interactive (list (calendar-read-mayan-tzolkin-date) - (calendar-read-mayan-haab-date))) - (let ((date (calendar-mayan-tzolkin-haab-on-or-before - tzolkin-date haab-date - (1- (calendar-absolute-from-gregorian - (calendar-cursor-to-date)))))) - (if (not date) - (error "%s, %s does not exist in the Mayan calendar round" - (calendar-mayan-tzolkin-to-string tzolkin-date) - (calendar-mayan-haab-to-string haab-date)) - (calendar-goto-date (calendar-gregorian-from-absolute date)) - (or noecho (calendar-print-mayan-date))))) - -(defun calendar-absolute-from-mayan-long-count (c) - "Compute the absolute date corresponding to the Mayan Long Count C. -Long count is a list (baktun katun tun uinal kin)" - (+ (* (nth 0 c) 144000) ; baktun - (* (nth 1 c) 7200) ; katun - (* (nth 2 c) 360) ; tun - (* (nth 3 c) 20) ; uinal - (nth 4 c) ; kin (days) - (- ; days before absolute date 0 - calendar-mayan-days-before-absolute-zero))) - -(defun calendar-mayan-date-string (&optional date) - "String of Mayan 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)))) - (tzolkin (calendar-mayan-tzolkin-from-absolute d)) - (haab (calendar-mayan-haab-from-absolute d)) - (long-count (calendar-mayan-long-count-from-absolute d))) - (format "Long count = %s; tzolkin = %s; haab = %s" - (calendar-mayan-long-count-to-string long-count) - (calendar-mayan-tzolkin-to-string tzolkin) - (calendar-mayan-haab-to-string haab)))) - -(defun calendar-print-mayan-date () - "Show the Mayan long count, tzolkin, and haab equivalents of date." - (interactive) - (message "Mayan date: %s" - (calendar-mayan-date-string (calendar-cursor-to-date t)))) - -(defun calendar-goto-mayan-long-count-date (date &optional noecho) - "Move cursor to Mayan long count DATE. Echo Mayan date unless NOECHO is t." - (interactive - (let (lc) - (while (not lc) - (let ((datum - (calendar-string-to-mayan-long-count - (read-string "Mayan long count (baktun.katun.tun.uinal.kin): " - (calendar-mayan-long-count-to-string - (calendar-mayan-long-count-from-absolute - (calendar-absolute-from-gregorian - (calendar-current-date)))))))) - (if (calendar-mayan-long-count-common-era datum) - (setq lc datum)))) - (list lc))) - (calendar-goto-date - (calendar-gregorian-from-absolute - (calendar-absolute-from-mayan-long-count date))) - (or noecho (calendar-print-mayan-date))) - -(defun calendar-mayan-long-count-common-era (lc) - "T if long count represents date in the Common Era." - (let ((base (calendar-mayan-long-count-from-absolute 1))) - (while (and (not (null base)) (= (car lc) (car base))) - (setq lc (cdr lc) - base (cdr base))) - (or (null lc) (> (car lc) (car base))))) - -(defun diary-mayan-date () - "Show the Mayan long count, haab, and tzolkin dates as a diary entry." - (format "Mayan date: %s" (calendar-mayan-date-string date))) - -(provide 'cal-mayan) - -;;; cal-mayan.el ends here diff --git a/lisp/calendar/cal-menu.el b/lisp/calendar/cal-menu.el deleted file mode 100644 index b8d17ef5597..00000000000 --- a/lisp/calendar/cal-menu.el +++ /dev/null @@ -1,523 +0,0 @@ -;;; cal-menu.el --- calendar functions for menu bar and popup menu support - -;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Lara Rios <lrios@coewl.cen.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: calendar, popup menus, menu bar - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements menu bar and popup menu support for -;; calendar.el. - -;; 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 - -;;; Code: - -(define-key calendar-mode-map [menu-bar edit] 'undefined) -(define-key calendar-mode-map [menu-bar search] 'undefined) - -(define-key calendar-mode-map [down-mouse-2] 'calendar-mouse-2-date-menu) -(define-key calendar-mode-map [mouse-2] 'ignore) - -(defvar calendar-mouse-3-map (make-sparse-keymap "Calendar")) -(define-key calendar-mode-map [down-mouse-3] calendar-mouse-3-map) -(define-key calendar-mode-map [C-down-mouse-3] calendar-mouse-3-map) - -(define-key calendar-mode-map [menu-bar moon] - (cons "Moon" (make-sparse-keymap "Moon"))) - -(define-key calendar-mode-map [menu-bar moon moon] - '("Lunar Phases" . calendar-phases-of-moon)) - -(define-key calendar-mode-map [menu-bar diary] - (cons "Diary" (make-sparse-keymap "Diary"))) - -(define-key calendar-mode-map [menu-bar diary heb] - '("Insert Hebrew" . calendar-mouse-insert-hebrew-diary-entry)) -(define-key calendar-mode-map [menu-bar diary isl] - '("Insert Islamic" . calendar-mouse-insert-islamic-diary-entry)) -(define-key calendar-mode-map [menu-bar diary cyc] - '("Insert Cyclic" . insert-cyclic-diary-entry)) -(define-key calendar-mode-map [menu-bar diary blk] - '("Insert Block" . insert-block-diary-entry)) -(define-key calendar-mode-map [menu-bar diary ann] - '("Insert Anniversary" . insert-anniversary-diary-entry)) -(define-key calendar-mode-map [menu-bar diary yr] - '("Insert Yearly" . insert-yearly-diary-entry)) -(define-key calendar-mode-map [menu-bar diary mon] - '("Insert Monthly" . insert-monthly-diary-entry)) -(define-key calendar-mode-map [menu-bar diary wk] - '("Insert Weekly" . insert-weekly-diary-entry)) -(define-key calendar-mode-map [menu-bar diary ent] - '("Insert Daily". insert-diary-entry)) -(define-key calendar-mode-map [menu-bar diary all] - '("Show All" . show-all-diary-entries)) -(define-key calendar-mode-map [menu-bar diary mark] - '("Mark All" . mark-diary-entries)) -(define-key calendar-mode-map [menu-bar diary view] - '("Cursor Date" . view-diary-entries)) -(define-key calendar-mode-map [menu-bar diary view] - '("Other File" . view-other-diary-entries)) - -(define-key calendar-mode-map [menu-bar holidays] - (cons "Holidays" (make-sparse-keymap "Holidays"))) - -(define-key calendar-mode-map [menu-bar holidays unmark] - '("Unmark" . calendar-unmark)) -(define-key calendar-mode-map [menu-bar holidays mark] - '("Mark" . mark-calendar-holidays)) -(define-key calendar-mode-map [menu-bar holidays 3-mon] - '("3 Months" . list-calendar-holidays)) -(define-key calendar-mode-map [menu-bar holidays 1-day] - '("One Day" . calendar-cursor-holidays)) - -(define-key calendar-mode-map [menu-bar goto] - (cons "Goto" (make-sparse-keymap "Goto"))) - -(define-key calendar-mode-map [menu-bar goto french] - '("French Date" . calendar-goto-french-date)) -(define-key calendar-mode-map [menu-bar goto mayan] - (cons "Mayan Date" (make-sparse-keymap "Mayan"))) -(define-key calendar-mode-map [menu-bar goto ethiopic] - '("Ethiopic Date" . calendar-goto-ethiopic-date)) -(define-key calendar-mode-map [menu-bar goto coptic] - '("Coptic Date" . calendar-goto-coptic-date)) -(define-key calendar-mode-map [menu-bar goto chinese] - '("Chinese Date" . calendar-goto-chinese-date)) -(define-key calendar-mode-map [menu-bar goto julian] - '("Julian Date" . calendar-goto-julian-date)) -(define-key calendar-mode-map [menu-bar goto islamic] - '("Islamic Date" . calendar-goto-islamic-date)) -(define-key calendar-mode-map [menu-bar goto persian] - '("Persian Date" . calendar-goto-persian-date)) -(define-key calendar-mode-map [menu-bar goto hebrew] - '("Hebrew Date" . calendar-goto-hebrew-date)) -(define-key calendar-mode-map [menu-bar goto astro] - '("Astronomical Date" . calendar-goto-astro-day-number)) -(define-key calendar-mode-map [menu-bar goto iso] - '("ISO Date" . calendar-goto-iso-date)) -(define-key calendar-mode-map [menu-bar goto gregorian] - '("Other Date" . calendar-goto-date)) -(define-key calendar-mode-map [menu-bar goto end-of-year] - '("End of Year" . calendar-end-of-year)) -(define-key calendar-mode-map [menu-bar goto beginning-of-year] - '("Beginning of Year" . calendar-beginning-of-year)) -(define-key calendar-mode-map [menu-bar goto end-of-month] - '("End of Month" . calendar-end-of-month)) -(define-key calendar-mode-map [menu-bar goto beginning-of-month] - '("Beginning of Month" . calendar-beginning-of-month)) -(define-key calendar-mode-map [menu-bar goto end-of-week] - '("End of Week" . calendar-end-of-week)) -(define-key calendar-mode-map [menu-bar goto beginning-of-week] - '("Beginning of Week" . calendar-beginning-of-week)) -(define-key calendar-mode-map [menu-bar goto today] - '("Today" . calendar-goto-today)) - - -(define-key calendar-mode-map [menu-bar goto mayan prev-rnd] - '("Previous Round" . calendar-previous-calendar-round-date)) -(define-key calendar-mode-map [menu-bar goto mayan nxt-rnd] - '("Next Round" . calendar-next-calendar-round-date)) -(define-key calendar-mode-map [menu-bar goto mayan prev-haab] - '("Previous Haab" . calendar-previous-haab-date)) -(define-key calendar-mode-map [menu-bar goto mayan next-haab] - '("Next Haab" . calendar-next-haab-date)) -(define-key calendar-mode-map [menu-bar goto mayan prev-tzol] - '("Previous Tzolkin" . calendar-previous-tzolkin-date)) -(define-key calendar-mode-map [menu-bar goto mayan next-tzol] - '("Next Tzolkin" . calendar-next-tzolkin-date)) - -(define-key calendar-mode-map [menu-bar scroll] - (cons "Scroll" (make-sparse-keymap "Scroll"))) - -(define-key calendar-mode-map [menu-bar scroll bk-12] - '("Backward 1 Year" . "4\ev")) -(define-key calendar-mode-map [menu-bar scroll bk-3] - '("Backward 3 Months" . scroll-calendar-right-three-months)) -(define-key calendar-mode-map [menu-bar scroll bk-1] - '("Backward 1 Month" . scroll-calendar-right)) -(define-key calendar-mode-map [menu-bar scroll fwd-12] - '("Forward 1 Year" . "4\C-v")) -(define-key calendar-mode-map [menu-bar scroll fwd-3] - '("Forward 3 Months" . scroll-calendar-left-three-months)) -(define-key calendar-mode-map [menu-bar scroll fwd-1] - '("Forward 1 Month" . scroll-calendar-left)) - -(put 'calendar-forward-day 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-backward-day 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-forward-week 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-backward-week 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-forward-month 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-backward-month 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-forward-year 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-backward-year 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-beginning-of-year 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-end-of-year 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-beginning-of-month 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-end-of-month 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-end-of-week 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-beginning-of-week 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-mouse-print-dates 'menu-enable '(calendar-event-to-date)) -(put 'calendar-sunrise-sunset 'menu-enable '(calendar-event-to-date)) -(put 'calendar-cursor-holidays 'menu-enable '(calendar-cursor-to-date)) -(put 'view-diary-entries 'menu-enable '(calendar-cursor-to-date)) -(put 'view-other-diary-entries 'menu-enable '(calendar-cursor-to-date)) -(put 'calendar-mouse-insert-hebrew-diary-entry - 'menu-enable - '(calendar-cursor-to-date)) -(put 'calendar-mouse-insert-islamic-diary-entry - 'menu-enable - '(calendar-cursor-to-date)) -(put 'insert-cyclic-diary-entry 'menu-enable '(calendar-cursor-to-date)) -(put 'insert-block-diary-entry 'menu-enable '(calendar-cursor-to-date)) -(put 'insert-anniversary-diary-entry 'menu-enable '(calendar-cursor-to-date)) -(put 'insert-yearly-diary-entry 'menu-enable '(calendar-cursor-to-date)) -(put 'insert-monthly-diary-entry 'menu-enable '(calendar-cursor-to-date)) -(put 'insert-weekly-diary-entry 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-day 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-week 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-week2 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-week-iso 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-week-monday 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-filofax-2week - 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-filofax-week 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-month 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-month-landscape 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-year 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-filofax-year 'menu-enable '(calendar-cursor-to-date)) -(put 'cal-tex-cursor-year-landscape 'menu-enable '(calendar-cursor-to-date)) - -(defun calendar-event-to-date (&optional error) - "Date of last event. -If event is not on a specific date, signals an error if optional parameter -ERROR is t, otherwise just returns nil." - (save-excursion - (set-buffer (window-buffer (posn-window (event-start last-input-event)))) - (goto-char (posn-point (event-start last-input-event))) - (calendar-cursor-to-date error))) - -(defun calendar-mouse-insert-hebrew-diary-entry (event) - "Pop up menu to insert a Hebrew-date diary entry." - (interactive "e") - (let ((hebrew-selection - (x-popup-menu - event - (list "Hebrew insert menu" - (list (calendar-hebrew-date-string (calendar-cursor-to-date)) - '("One time" . insert-hebrew-diary-entry) - '("Monthly" . insert-monthly-hebrew-diary-entry) - '("Yearly" . insert-yearly-hebrew-diary-entry)))))) - (and hebrew-selection (call-interactively hebrew-selection)))) - -(defun calendar-mouse-insert-islamic-diary-entry (event) - "Pop up menu to insert an Islamic-date diary entry." - (interactive "e") - (let ((islamic-selection - (x-popup-menu - event - (list "Islamic insert menu" - (list (calendar-islamic-date-string (calendar-cursor-to-date)) - '("One time" . insert-islamic-diary-entry) - '("Monthly" . insert-monthly-islamic-diary-entry) - '("Yearly" . insert-yearly-islamic-diary-entry)))))) - (and islamic-selection (call-interactively islamic-selection)))) - -(defun calendar-mouse-sunrise/sunset () - "Show sunrise/sunset times for mouse-selected date." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (calendar-sunrise-sunset))) - -(defun calendar-mouse-holidays () - "Show holidays for mouse-selected date." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (calendar-cursor-holidays))) - -(defun calendar-mouse-view-diary-entries () - "View diary entries on mouse-selected date." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (view-diary-entries 1))) - -(defun calendar-mouse-view-other-diary-entries () - "View diary entries from alternative file on mouse-selected date." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (call-interactively 'view-other-diary-entries))) - -(defun calendar-mouse-insert-diary-entry () - "Insert diary entry for mouse-selected date." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (insert-diary-entry nil))) - -(defun calendar-mouse-set-mark () - "Mark the date under the cursor." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (calendar-set-mark nil))) - -(defun cal-tex-mouse-day () - "Make a buffer with LaTeX commands for the day mouse is on." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (cal-tex-cursor-day nil))) - -(defun cal-tex-mouse-week () - "One page calendar for week indicated by cursor. -Holidays are included if `cal-tex-holidays' is t." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (cal-tex-cursor-week nil))) - -(defun cal-tex-mouse-week2 () - "Make a buffer with LaTeX commands for the week cursor is on. -The printed output will be on two pages." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (cal-tex-cursor-week2 nil))) - -(defun cal-tex-mouse-week-iso () - "One page calendar for week indicated by cursor. -Holidays are included if `cal-tex-holidays' is t." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (cal-tex-cursor-week-iso nil))) - -(defun cal-tex-mouse-week-monday () - "One page calendar for week indicated by cursor." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (cal-tex-cursor-week-monday nil))) - -(defun cal-tex-mouse-filofax-2week () - "One page Filofax calendar for week indicated by cursor." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (cal-tex-cursor-filofax-2week nil))) - -(defun cal-tex-mouse-filofax-week () - "Two page Filofax calendar for week indicated by cursor." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (cal-tex-cursor-filofax-week nil))) - -(defun cal-tex-mouse-month () - "Make a buffer with LaTeX commands for the month cursor is on. -Calendar is condensed onto one page." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (cal-tex-cursor-month nil))) - -(defun cal-tex-mouse-month-landscape () - "Make a buffer with LaTeX commands for the month cursor is on. -The output is in landscape format, one month to a page." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (cal-tex-cursor-month-landscape nil))) - -(defun cal-tex-mouse-year () - "Make a buffer with LaTeX commands for the year cursor is on." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (cal-tex-cursor-year nil))) - -(defun cal-tex-mouse-filofax-year () - "Make a buffer with LaTeX commands for Filofax calendar of year cursor is on." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (cal-tex-cursor-filofax-year nil))) - -(defun cal-tex-mouse-year-landscape () - "Make a buffer with LaTeX commands for the year cursor is on." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (cal-tex-cursor-year-landscape nil))) - -(defun calendar-mouse-print-dates () - "Pop up menu of equivalent dates to mouse selected date." - (interactive) - (let ((date (calendar-event-to-date)) - (selection - (x-popup-menu - event - (list - (concat (calendar-date-string date) " (Gregorian)") - (append - (list - (concat (calendar-date-string date) " (Gregorian)") - (list (calendar-day-of-year-string date)) - (list (format "ISO date: %s" (calendar-iso-date-string date))) - (list (format "Julian date: %s" - (calendar-julian-date-string date))) - (list - (format "Astronomical (Julian) day number (at noon UTC): %s.0" - (calendar-astro-date-string date))) - (list (format "Hebrew date (before sunset): %s" - (calendar-hebrew-date-string date))) - (list (format "Persian date: %s" - (calendar-persian-date-string date)))) - (let ((i (calendar-islamic-date-string date))) - (if (not (string-equal i "")) - (list (list (format "Islamic date (before sunset): %s" i))))) - (list - (list (format "Chinese date: %s" - (calendar-chinese-date-string date)))) -; (list '("Chinese date (select to echo Chinese date)" -; . calendar-mouse-chinese-date)) - (let ((c (calendar-coptic-date-string date))) - (if (not (string-equal c "")) - (list (list (format "Coptic date: %s" c))))) - (let ((e (calendar-ethiopic-date-string date))) - (if (not (string-equal e "")) - (list (list (format "Ethiopic date: %s" e))))) - (let ((f (calendar-french-date-string date))) - (if (not (string-equal f "")) - (list (list (format "French Revolutionary date: %s" f))))) - (list - (list - (format "Mayan date: %s" - (calendar-mayan-date-string date))))))))) - (and selection (call-interactively selection)))) - -(defun calendar-mouse-chinese-date () - "Show Chinese equivalent for mouse-selected date." - (interactive) - (save-excursion - (calendar-mouse-goto-date (calendar-event-to-date)) - (calendar-print-chinese-date))) - -(defun calendar-mouse-goto-date (date) - (set-buffer (window-buffer (posn-window (event-start last-input-event)))) - (calendar-goto-date date)) - -(defun calendar-mouse-2-date-menu (event) - "Pop up menu for Mouse-2 for selected date in the calendar window." - (interactive "e") - (let* ((date (calendar-event-to-date t)) - (selection - (x-popup-menu - event - (list (calendar-date-string date t nil) - (list - "" - '("Holidays" . calendar-mouse-holidays) - '("Mark date" . calendar-mouse-set-mark) - '("Sunrise/sunset" . calendar-mouse-sunrise/sunset) - '("Other calendars" . calendar-mouse-print-dates) - '("Prepare LaTeX buffer" . calendar-mouse-cal-tex-menu) - '("Diary entries" . calendar-mouse-view-diary-entries) - '("Insert diary entry" . calendar-mouse-insert-diary-entry) - '("Other diary file entries" - . calendar-mouse-view-other-diary-entries) - ))))) - (and selection (call-interactively selection)))) - -(defun calendar-mouse-cal-tex-menu (event) - "Pop up submenu for Mouse-2 for cal-tex commands for selected date in the calendar window." - (interactive "e") - (let* ((selection - (x-popup-menu - event - (list (calendar-date-string date t nil) - (list - "" - '("Daily (1 page)" . cal-tex-mouse-day) - '("Weekly (1 page)" . cal-tex-mouse-week) - '("Weekly (2 pages)" . cal-tex-mouse-week2) - '("Weekly (other style; 1 page)" . cal-tex-mouse-week-iso) - '("Weekly (yet another style; 1 page)" . - cal-tex-mouse-week-monday) - '("Monthly" . cal-tex-mouse-month) - '("Monthly (landscape)" . cal-tex-mouse-month-landscape) - '("Yearly" . cal-tex-mouse-year) - '("Yearly (landscape)" . cal-tex-mouse-year-landscape) - '("Filofax styles" . cal-tex-mouse-filofax) - ))))) - (and selection (call-interactively selection)))) - -(defun cal-tex-mouse-filofax (event) - "Pop up sub-submenu for Mouse-2 for Filofax cal-tex commands for selected date." - (interactive "e") - (let* ((selection - (x-popup-menu - event - (list (calendar-date-string date t nil) - (list - "" - '("Filofax Weekly (2-weeks-at-a-glance)" . - cal-tex-mouse-filofax-2week) - '("Filofax Weekly (week-at-a-glance)" . - cal-tex-mouse-filofax-week) - '("Filofax Yearly" . cal-tex-mouse-filofax-year) - ))))) - (and selection (call-interactively selection)))) - -(define-key calendar-mouse-3-map [exit-calendar] - '("Exit calendar" . exit-calendar)) -(define-key calendar-mouse-3-map [show-diary] - '("Show diary" . show-all-diary-entries)) -(define-key calendar-mouse-3-map [lunar-phases] - '("Lunar phases" . calendar-phases-of-moon)) -(define-key calendar-mouse-3-map [unmark] - '("Unmark" . calendar-unmark)) -(define-key calendar-mouse-3-map [mark-holidays] - '("Mark holidays" . mark-calendar-holidays)) -(define-key calendar-mouse-3-map [list-holidays] - '("List holidays" . list-calendar-holidays)) -(define-key calendar-mouse-3-map [mark-diary-entries] - '("Mark diary entries" . mark-diary-entries)) -(define-key calendar-mouse-3-map [scroll-backward] - '("Scroll backward" . scroll-calendar-right-three-months)) -(define-key calendar-mouse-3-map [scroll-forward] - '("Scroll forward" . scroll-calendar-left-three-months)) - -(run-hooks 'cal-menu-load-hook) - -(provide 'cal-menu) - -;;; cal-menu.el ends here diff --git a/lisp/calendar/cal-move.el b/lisp/calendar/cal-move.el deleted file mode 100644 index 8ec3295d77a..00000000000 --- a/lisp/calendar/cal-move.el +++ /dev/null @@ -1,315 +0,0 @@ -;;; cal-move.el --- calendar functions for movement in the calendar - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: calendar - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements movement in the calendar for -;; calendar.el. - -;; 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 - -;;; Code: - -(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-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)))))) - -(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-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)) - -(provide 'cal-move) - -;;; cal-move.el ends here diff --git a/lisp/calendar/cal-persia.el b/lisp/calendar/cal-persia.el deleted file mode 100644 index 89269526be8..00000000000 --- a/lisp/calendar/cal-persia.el +++ /dev/null @@ -1,206 +0,0 @@ -;;; cal-persia.el --- calendar functions for the Persian calendar. - -;; Copyright (C) 1996 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: Persian calendar, calendar, diary - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el and -;; diary.el that deal with the Persian calendar. - -;; 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 - -;;; Code: - -(require 'cal-julian) - -(defvar persian-calendar-month-name-array - ["Farvardin" "Ordibehest" "Xordad" "Tir" "Mordad" "Sahrivar" "Mehr" "Aban" - "Azar" "Dey" "Bahman" "Esfand"]) - -(defvar persian-calendar-epoch (calendar-absolute-from-julian '(3 19 622)) - "Absolute date of start of Persian calendar = March 19, 622 A.D. (Julian).") - -(defun persian-calendar-leap-year-p (year) - "True if YEAR is a leap year on the Persian calendar." - (< (mod (* (mod (mod (if (<= 0 year) - ; No year zero - (+ year 2346) - (+ year 2347)) - 2820) - 768) - 683) - 2820) - 683)) - -(defun persian-calendar-last-day-of-month (month year) - "Return last day of MONTH, YEAR on the Persian calendar." - (cond - ((< month 7) 31) - ((or (< month 12) (persian-calendar-leap-year-p year)) 30) - (t 29))) - -(defun calendar-absolute-from-persian (date) - "Compute absolute date from Persian date 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))) - (if (< year 0) - (+ (calendar-absolute-from-persian - (list month day (1+ (mod year 2820)))) - (* 1029983 (floor year 2820))) - (+ (1- persian-calendar-epoch); Days before epoch - (* 365 (1- year)) ; Days in prior years. - (* 683 ; Leap days in prior 2820-year cycles - (floor (+ year 2345) 2820)) - (* 186 ; Leap days in prior 768 year cycles - (floor (mod (+ year 2345) 2820) 768)) - (floor; Leap years in current 768 or 516 year cycle - (* 683 (mod (mod (+ year 2345) 2820) 768)) - 2820) - -568 ; Leap years in Persian years -2345...-1 - (calendar-sum ; Days in prior months this year. - m 1 (< m month) - (persian-calendar-last-day-of-month m year)) - day)))) ; Days so far this month. - -(defun calendar-persian-year-from-absolute (date) - "Persian year corresponding to the absolute DATE." - (let* ((d0 ; Prior days since start of 2820 cycles - (- date (calendar-absolute-from-persian (list 1 1 -2345)))) - (n2820 ; Completed 2820-year cycles - (floor d0 1029983)) - (d1 ; Prior days not in n2820 - (mod d0 1029983)) - (n768 ; 768-year cycles not in n2820 - (floor d1 280506)) - (d2 ; Prior days not in n2820 or n768 - (mod d1 280506)) - (n1 ; Years not in n2820 or n768 - ; we want is - ; (floor (+ (* 2820 d2) (* 2820 366)) 1029983)) - ; but that causes overflow, so we use - (let ((a (floor d2 366)); we use 366 as the divisor because - ; (2820*366 mod 1029983) is small - (b (mod d2 366))) - (+ 1 a (floor (+ (* 2137 a) (* 2820 b) 2137) 1029983)))) - (year (+ (* 2820 n2820); Complete 2820 year cycles - (* 768 n768) ; Complete 768 year cycles - (if ; Remaining years - ; Last day of 2820 year cycle - (= d1 1029617) - (1- n1) - n1) - -2345))) ; Years before year 1 - (if (< year 1) - (1- year); No year zero - year))) - -(defun calendar-persian-from-absolute (date) - "Compute the Persian equivalent for absolute date DATE. -The result is a list of the form (MONTH DAY YEAR). -The absolute date is the number of days elapsed since the imaginary -Gregorian date Sunday, December 31, 1 BC." - (let* ((year (calendar-persian-year-from-absolute date)) - (month ; Search forward from Farvardin - (1+ (calendar-sum m 1 - (> date - (calendar-absolute-from-persian - (list - m - (persian-calendar-last-day-of-month m year) - year))) - 1))) - (day ; Calculate the day by subtraction - (- date (1- (calendar-absolute-from-persian - (list month 1 year)))))) - (list month day year))) - -(defun calendar-persian-date-string (&optional date) - "String of Persian date of Gregorian DATE. -Defaults to today's date if DATE is not given." - (let* ((persian-date (calendar-persian-from-absolute - (calendar-absolute-from-gregorian - (or date (calendar-current-date))))) - (y (extract-calendar-year persian-date)) - (m (extract-calendar-month persian-date))) - (let ((monthname (aref persian-calendar-month-name-array (1- m))) - (day (int-to-string (extract-calendar-day persian-date))) - (dayname nil) - (month (int-to-string m)) - (year (int-to-string y))) - (mapconcat 'eval calendar-date-display-form "")))) - -(defun calendar-print-persian-date () - "Show the Persian calendar equivalent of the selected date." - (interactive) - (message "Persian date: %s" - (calendar-persian-date-string (calendar-cursor-to-date t)))) - -(defun calendar-goto-persian-date (date &optional noecho) - "Move cursor to Persian date DATE. -Echo Persian date unless NOECHO is t." - (interactive (persian-prompt-for-date)) - (calendar-goto-date (calendar-gregorian-from-absolute - (calendar-absolute-from-persian date))) - (or noecho (calendar-print-persian-date))) - -(defun persian-prompt-for-date () - "Ask for a Persian date." - (let* ((today (calendar-current-date)) - (year (calendar-read - "Persian calendar year (not 0): " - '(lambda (x) (/= x 0)) - (int-to-string - (extract-calendar-year - (calendar-persian-from-absolute - (calendar-absolute-from-gregorian today)))))) - (completion-ignore-case t) - (month (cdr (assoc - (capitalize - (completing-read - "Persian calendar month name: " - (mapcar 'list - (append persian-calendar-month-name-array nil)) - nil t)) - (calendar-make-alist persian-calendar-month-name-array - 1 'capitalize)))) - (last (persian-calendar-last-day-of-month month year)) - (day (calendar-read - (format "Persian calendar day (1-%d): " last) - '(lambda (x) (and (< 0 x) (<= x last)))))) - (list (list month day year)))) - -(defun diary-persian-date () - "Persian calendar equivalent of date diary entry." - (calendar-persian-date-string (calendar-cursor-to-date t))) - -(provide 'cal-persia) - -;;; cal-persia.el ends here diff --git a/lisp/calendar/cal-tex.el b/lisp/calendar/cal-tex.el deleted file mode 100644 index 315d2b45b4e..00000000000 --- a/lisp/calendar/cal-tex.el +++ /dev/null @@ -1,1608 +0,0 @@ -;;; cal-tex.el --- calendar functions for printing calendars with LaTeX. - -;; Copyright (C) 1995 Free Software Foundation, Inc. - -;; Author: Steve Fisk <fisk@bowdoin.edu> -;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: Calendar, LaTeX - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the creation of LaTeX calendars -;; based on the user's holiday choices and diary file. - -;; TO DO -;; -;; (*) Add holidays and diary entries to daily calendar. -;; -;; (*) Add diary entries to weekly calendar functions. -;; -;; (*) Make calendar styles for A4 paper. -;; -;; (*) Make daily and monthly styles Filofax paper. -;; -;; (*) Improve the LaTeX command that produces the boxes in the monthly -;; calendar to eliminate slight gap--what causes it?! - -;;; Code: - -(require 'calendar) - -(autoload 'list-diary-entries "diary-lib" nil t) -(autoload 'calendar-holiday-list "holidays" nil t) -(autoload 'calendar-iso-from-absolute "cal-iso" nil t) - -;;; -;;; Customizable variables -;;; - -(defvar cal-tex-which-days '(0 1 2 3 4 5 6) - "*The days of the week that are displayed on the portrait monthly calendar. -Sunday is 0, Monday is 1, and so on. The default is to print from Sunday to -Saturday. For example, use - - (setq cal-tex-which-days '(1 3 5)) - -to only print Monday, Wednesday, Friday.") - -(defvar cal-tex-holidays t - "*If t (default), then the holidays are also printed. -If finding the holidays is too slow, set this to nil.") - -(defvar cal-tex-diary nil - "*If t, the diary entries are printed in the calendar.") - -(defvar cal-tex-daily-string - '(let* ((year (extract-calendar-year date)) - (day (calendar-day-number date)) - (days-remaining (- (calendar-day-number (list 12 31 year)) day))) - (format "%d/%d" day days-remaining)) - "*An expression in the variable `date' whose value is placed on date. -The string resulting from evaluating this expression is placed at the bottom -center of `date' on the monthly calendar, next to the date in the weekly -calendars, and in the top center of daily calendars. - -Default is ordinal day number of the year and the number of days remaining. -As an example of what you do, setting this to - - '(progn - (require 'cal-hebrew) - (calendar-hebrew-date-string date)) - -will put the Hebrew date at the bottom of each day.") - -(defvar cal-tex-buffer "calendar.tex" - "*The name for the tex-ed calendar.") - -(defvar cal-tex-24 nil - "*If t, use a 24 hour clock in the daily calendar.") - -(defvar cal-tex-daily-start 8 - "*The first hour of the daily calendar page.") - -(defvar cal-tex-daily-end 20 - "*The last hour of the daily calendar page.") - -;;; -;;; Definitions for LaTeX code -;;; - -(defvar cal-tex-day-prefix "\\caldate{%s}{%s}" - "The initial LaTeX code for a day. -The holidays, diary entries, bottom string, and the text follow.") - -(defvar cal-tex-day-name-format "\\myday{%s}%%" - "The format for LaTeX code for a day name. The names are taken from -calendar-day-name-array.") - -(defvar cal-tex-cal-one-month -"\\def\\calmonth#1#2% -{\\begin{center}% -\\Huge\\bf\\uppercase{#1} #2 \\\\[1cm]% -\\end{center}}% -\\vspace*{-1.5cm}% -% -" - "LaTeX code for the month header") - -(defvar cal-tex-cal-multi-month -"\\def\\calmonth#1#2#3#4% -{\\begin{center}% -\\Huge\\bf #1 #2---#3 #4\\\\[1cm]% -\\end{center}}% -\\vspace*{-1.5cm}% -% -" - "LaTeX code for the month header") - -(defvar cal-tex-myday -"\\renewcommand{\\myday}[1]% -{\\makebox[\\cellwidth]{\\hfill\\large\\bf#1\\hfill}} -% -" - "LaTeX code for a day heading") - -(defvar cal-tex-caldate -"\\fboxsep=0pt -\\long\\def\\caldate#1#2#3#4#5#6{% - \\fbox{\\hbox to\\cellwidth{% - \\vbox to\\cellheight{% - \\hbox to\\cellwidth{% - {\\hspace*{1mm}\\Large \\bf \\strut #2}\\hspace{.05\\cellwidth}% - \\raisebox{\\holidaymult\\cellheight}% - {\\parbox[t]{.75\\cellwidth}{\\tiny \\raggedright #4}}} - \\hbox to\\cellwidth{% - \\hspace*{1mm}\\parbox{.95\\cellwidth}{\\tiny \\raggedright #3}} - \\hspace*{1mm}% - \\hbox to\\cellwidth{#6}% - \\vfill% - \\hbox to\\cellwidth{\\hfill \\tiny #5 \\hfill}% - \\vskip 1.4pt}% - \\hskip -0.4pt}}} -" - "LaTeX code to insert one box with date info in calendar. -This definition is the heart of the calendar!") - -(defun cal-tex-list-holidays (d1 d2) - "Generate a list of all holidays from absolute date D1 to D2." - (let* ((result nil) - (start (calendar-gregorian-from-absolute d1)) - (start-month (extract-calendar-month start)) - (start-year (extract-calendar-year start))) - (increment-calendar-month start-month start-year 1) - (let* ((end (calendar-gregorian-from-absolute d2)) - (end-month (extract-calendar-month end)) - (end-year (extract-calendar-year end))) - (if (= (extract-calendar-day end) 1) - (increment-calendar-month end-month end-year -1)) - (let* ((s (calendar-absolute-from-gregorian - (list start-month 1 start-year))) - (e (calendar-absolute-from-gregorian - (list end-month 1 end-year))) - (d s) - (never t) - (displayed-month start-month) - (displayed-year start-year)) - (while (or never (<= d e)) - (setq result (append result (calendar-holiday-list))) - (setq never nil) - (increment-calendar-month displayed-month displayed-year 3) - (setq d (calendar-absolute-from-gregorian - (list displayed-month 1 displayed-year)))))) - (let ((in-range) - (p result)) - (while p - (and (car (car p)) - (let ((a (calendar-absolute-from-gregorian (car (car p))))) - (and (<= d1 a) (<= a d2))) - (setq in-range (append (list (car p)) in-range))) - (setq p (cdr p))) - in-range))) - -(defun cal-tex-list-diary-entries (d1 d2) - "Generate a list of all diary-entries from absolute date D1 to D2." - (let ((diary-display-hook nil)) - (list-diary-entries - (calendar-gregorian-from-absolute d1) - (1+ (- d2 d1))))) - -(defun cal-tex-preamble (&optional args) - "Insert the LaTeX preamble. -Preamble Includes initial definitions for various LaTeX commands. -Optional ARGS are included." - (set-buffer (get-buffer-create cal-tex-buffer)) - (erase-buffer) - (insert "\\documentstyle") - (if args - (insert "[" args "]")) - (insert "{article}\n" - "\\hbadness 20000 -\\hfuzz=1000pt -\\vbadness 20000 -\\marginparwidth 0pt -\\oddsidemargin -2cm -\\evensidemargin -2cm -\\marginparsep 0pt -\\topmargin 0pt -\\textwidth 7.5in -\\textheight 9.5in -\\newlength{\\cellwidth} -\\newlength{\\cellheight} -\\newlength{\\boxwidth} -\\newlength{\\boxheight} -\\newlength{\\cellsize} -\\newcommand{\\myday}[1]{} -\\newcommand{\\caldate}[6]{} -\\newcommand{\\nocaldate}[6]{} -\\newcommand{\\calsmall}[6]{} -% -")) - -;;; -;;; Yearly calendars -;;; - -(defun cal-tex-cursor-year (&optional arg) - "Make a buffer with LaTeX commands for the year cursor is on. -Optional prefix argument specifies number of years." - (interactive "P") - (cal-tex-year (extract-calendar-year (calendar-cursor-to-date t)) - (if arg arg 1))) - -(defun cal-tex-cursor-year-landscape (&optional arg) - "Make a buffer with LaTeX commands for the year cursor is on. -Optional prefix argument specifies number of years." - (interactive "P") - (cal-tex-year (extract-calendar-year (calendar-cursor-to-date t)) - (if arg arg 1) - t)) - -(defun cal-tex-year (year n &optional landscape) - "Make a one page yearly calendar of YEAR; do this for N years. -There are four rows of three months each, unless optional LANDSCAPE is t, -in which case the calendar isprinted in landscape mode with three rows of -four months each." - (cal-tex-insert-preamble 1 landscape "12pt") - (if landscape - (cal-tex-vspace "-.6cm") - (cal-tex-vspace "-3.1cm")) - (calendar-for-loop j from 1 to n do - (insert "\\vfill%\n") - (cal-tex-b-center) - (cal-tex-Huge (number-to-string year)) - (cal-tex-e-center) - (cal-tex-vspace "1cm") - (cal-tex-b-center) - (cal-tex-b-parbox "l" (if landscape "5.9in" "4.3in")) - (insert "\n") - (cal-tex-noindent) - (cal-tex-nl) - (calendar-for-loop i from 1 to 12 do - (insert (cal-tex-mini-calendar i year "month" "1.1in" "1in")) - (insert "\\month") - (cal-tex-hspace "0.5in") - (if (zerop (mod i (if landscape 4 3))) - (cal-tex-nl "0.5in"))) - (cal-tex-e-parbox) - (cal-tex-e-center) - (insert "\\vfill%\n") - (setq year (1+ year)) - (if (/= j n) - (cal-tex-newpage) - (cal-tex-end-document)) - (run-hooks 'cal-tex-year-hook)) - (run-hooks 'cal-tex-hook)) - -(defun cal-tex-cursor-filofax-year (&optional arg) - "Make a Filofax one page yearly calendar of year indicated by cursor. -Optional parameter specifies number of years." - (interactive "P") - (let* ((n (if arg arg 1)) - (year (extract-calendar-year (calendar-cursor-to-date t)))) - (cal-tex-preamble "twoside") - (cal-tex-cmd "\\textwidth 3.25in") - (cal-tex-cmd "\\textheight 6.5in") - (cal-tex-cmd "\\oddsidemargin 1.675in") - (cal-tex-cmd "\\evensidemargin 1.675in") - (cal-tex-cmd "\\topmargin 0pt") - (cal-tex-cmd "\\headheight -0.875in") - (cal-tex-cmd "\\fboxsep 0.5mm") - (cal-tex-cmd "\\pagestyle{empty}") - (cal-tex-b-document) - (cal-tex-cmd "\\vspace*{0.25in}") - (calendar-for-loop j from 1 to n do - (insert (format "\\hfil {\\Large \\bf %s} \\hfil\\\\\n" year)) - (cal-tex-b-center) - (cal-tex-b-parbox "l" "\\textwidth") - (insert "\n") - (cal-tex-noindent) - (cal-tex-nl) - (calendar-for-loop i from 1 to 12 do - (insert (cal-tex-mini-calendar i year - (calendar-month-name i) - "1in" ".9in" "tiny" "0.6mm"))) - (insert -"\\noindent\\fbox{\\January}\\fbox{\\February}\\fbox{\\March}\\\\ -\\noindent\\fbox{\\April}\\fbox{\\May}\\fbox{\\June}\\\\ -\\noindent\\fbox{\\July}\\fbox{\\August}\\fbox{\\September}\\\\ -\\noindent\\fbox{\\October}\\fbox{\\November}\\fbox{\\December} -") - (cal-tex-e-parbox) - (cal-tex-e-center) - (setq year (1+ year)) - (if (= j n) - (cal-tex-end-document) - (cal-tex-newpage) - (cal-tex-cmd "\\vspace*{0.25in}")) - (run-hooks 'cal-tex-year-hook)) - (run-hooks 'cal-tex-hook))) - -;;; -;;; Monthly calendars -;;; - -(defun cal-tex-cursor-month-landscape (&optional arg) - "Make a buffer with LaTeX commands for the month cursor is on. -Optional prefix argument specifies number of months to be produced. -The output is in landscape format, one month to a page." - (interactive "P") - (let* ((n (if arg arg 1)) - (date (calendar-cursor-to-date t)) - (month (extract-calendar-month date)) - (year (extract-calendar-year date)) - (end-month month) - (end-year year) - (cal-tex-which-days '(0 1 2 3 4 5 6))) - (increment-calendar-month end-month end-year (1- n)) - (let ((diary-list (if cal-tex-diary - (cal-tex-list-diary-entries - (calendar-absolute-from-gregorian - (list month 1 year)) - (calendar-absolute-from-gregorian - (list end-month - (calendar-last-day-of-month - end-month end-year) - end-year))))) - (holidays (if cal-tex-holidays - (cal-tex-list-holidays - (calendar-absolute-from-gregorian - (list month 1 year)) - (calendar-absolute-from-gregorian - (list end-month - (calendar-last-day-of-month end-month end-year) - end-year))))) - (other-month) - (other-year) - (small-months-at-start)) - (cal-tex-insert-preamble (cal-tex-number-weeks month year 1) t "12pt") - (cal-tex-cmd cal-tex-cal-one-month) - (calendar-for-loop i from 1 to n do - (setq other-month month) - (setq other-year year) - (increment-calendar-month other-month other-year -1) - (insert (cal-tex-mini-calendar other-month other-year "lastmonth" - "\\cellwidth" "\\cellheight")) - (increment-calendar-month other-month other-year 2) - (insert (cal-tex-mini-calendar other-month other-year "nextmonth" - "\\cellwidth" "\\cellheight")) - (cal-tex-insert-month-header 1 month year month year) - (cal-tex-insert-day-names) - (cal-tex-nl ".2cm") - (setq small-months-at-start - (< 1 (mod (- (calendar-day-of-week (list month 1 year)) - calendar-week-start-day) - 7))) - (if small-months-at-start - (insert "\\lastmonth\\nextmonth\\hspace*{-2\\cellwidth}")) - (cal-tex-insert-blank-days month year cal-tex-day-prefix) - (cal-tex-insert-days month year diary-list holidays - cal-tex-day-prefix) - (cal-tex-insert-blank-days-at-end month year cal-tex-day-prefix) - (if (and (not small-months-at-start) - (< 1 (mod (- (1- calendar-week-start-day) - (calendar-day-of-week - (list month - (calendar-last-day-of-month month year) - year))) - 7))) - (insert "\\vspace*{-\\cellwidth}\\hspace*{-2\\cellwidth}" - "\\lastmonth\\nextmonth")) - (if (/= i n) - (progn - (run-hooks 'cal-tex-month-hook) - (cal-tex-newpage) - (increment-calendar-month month year 1) - (cal-tex-vspace "-2cm") - (cal-tex-insert-preamble - (cal-tex-number-weeks month year 1) t "12pt" t)))) - (cal-tex-end-document) - (run-hooks 'cal-tex-hook)))) - -(defun cal-tex-cursor-month (arg) - "Make a buffer with LaTeX commands for the month cursor is on. -Optional prefix argument specifies number of months to be produced. -Calendar is condensed onto one page." - (interactive "P") - (let* ((date (calendar-cursor-to-date t)) - (month (extract-calendar-month date)) - (year (extract-calendar-year date)) - (end-month month) - (end-year year) - (n (if arg arg 1))) - (increment-calendar-month end-month end-year (1- n)) - (let ((diary-list (if cal-tex-diary - (cal-tex-list-diary-entries - (calendar-absolute-from-gregorian - (list month 1 year)) - (calendar-absolute-from-gregorian - (list end-month - (calendar-last-day-of-month - end-month end-year) - end-year))))) - (holidays (if cal-tex-holidays - (cal-tex-list-holidays - (calendar-absolute-from-gregorian - (list month 1 year)) - (calendar-absolute-from-gregorian - (list end-month - (calendar-last-day-of-month end-month end-year) - end-year))))) - (other-month) - (other-year)) - (cal-tex-insert-preamble (cal-tex-number-weeks month year n) nil"12pt") - (if (> n 1) - (cal-tex-cmd cal-tex-cal-multi-month) - (cal-tex-cmd cal-tex-cal-one-month)) - (cal-tex-insert-month-header n month year end-month end-year) - (cal-tex-insert-day-names) - (cal-tex-nl ".2cm") - (cal-tex-insert-blank-days month year cal-tex-day-prefix) - (calendar-for-loop i from 1 to n do - (setq other-month month) - (setq other-year year) - (cal-tex-insert-days month year diary-list holidays - cal-tex-day-prefix) - (increment-calendar-month month year 1)) - (cal-tex-insert-blank-days-at-end end-month end-year cal-tex-day-prefix) - (cal-tex-end-document))) - (run-hooks 'cal-tex-hook)) - -(defun cal-tex-insert-days (month year diary-list holidays day-format) - "Insert LaTeX commands for a range of days in monthly calendars. -LaTeX commands are inserted for the days of the MONTH in YEAR. -Diary entries on DIARY-LIST are included. Holidays on HOLIDAYS are included. -Each day is formatted using format DAY-FORMAT." - (let* ((blank-days;; at start of month - (mod - (- (calendar-day-of-week (list month 1 year)) - calendar-week-start-day) - 7)) - (date) - (last (calendar-last-day-of-month month year))) - (calendar-for-loop i from 1 to last do - (setq date (list month i year)) - (if (memq (calendar-day-of-week date) cal-tex-which-days) - (progn - (insert (format day-format (calendar-month-name month) i)) - (cal-tex-arg (cal-tex-latexify-list diary-list date)) - (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) - (cal-tex-arg) - (cal-tex-comment))) - (if (and (zerop (mod (+ i blank-days) 7)) - (/= i last)) - (progn - (cal-tex-hfill) - (cal-tex-nl)))))) - -(defun cal-tex-insert-day-names () - "Insert the names of the days at top of a monthly calendar." - (calendar-for-loop i from 0 to 6 do - (if (memq i cal-tex-which-days) - (insert (format cal-tex-day-name-format - (aref calendar-day-name-array - (mod (+ calendar-week-start-day i) 7))))) - (cal-tex-comment))) - -(defun cal-tex-insert-month-header (n month year end-month end-year) - "Create a title for a calendar. -A title is inserted for a calendar with N months starting with -MONTH YEAR and ending with END-MONTH END-YEAR." - (let ( (month-name (calendar-month-name month)) - (end-month-name (calendar-month-name end-month))) - (if (= 1 n) - (insert (format "\\calmonth{%s}{%s}\n\\vspace*{-0.5cm}" - month-name year) ) - (insert (format "\\calmonth{%s}{%s}{%s}{%s}\n\\vspace*{-0.5cm}" - month-name year end-month-name end-year)))) - (cal-tex-comment)) - -(defun cal-tex-insert-blank-days (month year day-format) - "Insert code for initial days not in calendar. -Insert LaTeX code for the blank days at the beginning of the MONTH in -YEAR. The entry is formatted using DAY-FORMAT. If the entire week is -blank, no days are inserted." - (if (cal-tex-first-blank-p month year) - (let* ((blank-days;; at start of month - (mod - (- (calendar-day-of-week (list month 1 year)) - calendar-week-start-day) - 7))) - (calendar-for-loop i from 0 to (1- blank-days) do - (if (memq i cal-tex-which-days) - (insert (format day-format " " " ") "{}{}{}{}%\n")))))) - -(defun cal-tex-insert-blank-days-at-end (month year day-format) - "Insert code for final days not in calendar. -Insert LaTeX code for the blank days at the end of the MONTH in YEAR. -The entry is formatted using DAY-FORMAT." - (if (cal-tex-last-blank-p month year) - (let* ((last-day (calendar-last-day-of-month month year)) - (blank-days;; at end of month - (mod - (- (calendar-day-of-week (list month last-day year)) - calendar-week-start-day) - 7))) - (calendar-for-loop i from (1+ blank-days) to 6 do - (if (memq i cal-tex-which-days) - (insert (format day-format "" "") "{}{}{}{}%\n")))))) - -(defun cal-tex-first-blank-p (month year) - "Determine if any days of the first week will be printed. -Return t if there will there be any days of the first week printed -in the calendar starting in MONTH YEAR." - (let ((any-days nil) - (the-saturday)) ;the day of week of 1st Saturday - (calendar-for-loop i from 1 to 7 do - (if (= 6 (calendar-day-of-week (list month i year))) - (setq the-saturday i))) - (calendar-for-loop i from 1 to the-saturday do - (if (memq (calendar-day-of-week (list month i year)) - cal-tex-which-days) - (setq any-days t))) - any-days)) - -(defun cal-tex-last-blank-p (month year) - "Determine if any days of the last week will be printed. -Return t if there will there be any days of the last week printed -in the calendar starting in MONTH YEAR." - (let ((any-days nil) - (last-day (calendar-last-day-of-month month year)) - (the-sunday)) ;the day of week of last Sunday - (calendar-for-loop i from (- last-day 6) to last-day do - (if (= 0 (calendar-day-of-week (list month i year))) - (setq the-sunday i))) - (calendar-for-loop i from the-sunday to last-day do - (if (memq (calendar-day-of-week (list month i year)) - cal-tex-which-days) - (setq any-days t))) - any-days)) - -(defun cal-tex-number-weeks (month year n) - "Determine the number of weeks in a range of dates. -Compute the number of weeks in the calendar starting with MONTH and YEAR, -and lasting N months, including only the days in WHICH-DAYS. As it stands, -this is only an upper bound." - (let ((d (list month 1 year))) - (increment-calendar-month month year (1- n)) - (/ (- (calendar-dayname-on-or-before - calendar-week-start-day - (+ 7 (calendar-absolute-from-gregorian - (list month (calendar-last-day-of-month month year) year)))) - (calendar-dayname-on-or-before - calendar-week-start-day - (calendar-absolute-from-gregorian d))) - 7))) - -;;; -;;; Weekly calendars -;;; - -(defun cal-tex-cursor-week (&optional arg) - "Make a buffer with LaTeX commands for a two-page one-week calendar. -It applies to the week that point is in. -Optional prefix argument specifies number of weeks. -Holidays are included if `cal-tex-holidays' is t." - (interactive "P") - (let* ((n (if arg arg 1)) - (date (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before - calendar-week-start-day - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - (month (extract-calendar-month date)) - (year (extract-calendar-year date)) - (holidays (if cal-tex-holidays - (cal-tex-list-holidays - (calendar-absolute-from-gregorian date) - (+ (* 7 n) - (calendar-absolute-from-gregorian date)))))) - (cal-tex-preamble "11pt") - (cal-tex-cmd "\\textwidth 6.5in") - (cal-tex-cmd "\\textheight 10.5in") - (cal-tex-cmd "\\oddsidemargin 0in") - (cal-tex-cmd "\\evensidemargin 0in") - (insert cal-tex-LaTeX-hourbox) - (cal-tex-b-document) - (cal-tex-cmd "\\pagestyle{empty}") - (calendar-for-loop i from 1 to n do - (cal-tex-vspace "-1.5in") - (cal-tex-b-center) - (cal-tex-Huge-bf (format "\\uppercase{%s}" - (calendar-month-name month))) - (cal-tex-hspace "2em") - (cal-tex-Huge-bf (number-to-string year)) - (cal-tex-nl ".5cm") - (cal-tex-e-center) - (cal-tex-hspace "-.2in") - (cal-tex-b-parbox "l" "7in") - (calendar-for-loop j from 1 to 7 do - (cal-tex-week-hours date holidays "3.1") - (setq date (cal-tex-incr-date date))) - (cal-tex-e-parbox) - (setq month (extract-calendar-month date)) - (setq year (extract-calendar-year date)) - (if (/= i n) - (progn - (run-hooks 'cal-tex-week-hook) - (cal-tex-newpage)))) - (cal-tex-end-document) - (run-hooks 'cal-tex-hook))) - -(defun cal-tex-cursor-week2 (&optional arg) - "Make a buffer with LaTeX commands for a two-page one-week calendar. -It applies to the week that point is in. -Optional prefix argument specifies number of weeks. -Holidays are included if `cal-tex-holidays' is t." - (interactive "P") - (let* ((n (if arg arg 1)) - (date (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before - calendar-week-start-day - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - (month (extract-calendar-month date)) - (year (extract-calendar-year date)) - (d date) - (holidays (if cal-tex-holidays - (cal-tex-list-holidays - (calendar-absolute-from-gregorian date) - (+ (* 7 n) - (calendar-absolute-from-gregorian date)))))) - (cal-tex-preamble "12pt") - (cal-tex-cmd "\\textwidth 6.5in") - (cal-tex-cmd "\\textheight 10.5in") - (cal-tex-cmd "\\oddsidemargin 0in") - (cal-tex-cmd "\\evensidemargin 0in") - (insert cal-tex-LaTeX-hourbox) - (cal-tex-b-document) - (cal-tex-cmd "\\pagestyle{empty}") - (calendar-for-loop i from 1 to n do - (cal-tex-vspace "-1.5in") - (cal-tex-b-center) - (cal-tex-Huge-bf (format "\\uppercase{%s}" - (calendar-month-name month))) - (cal-tex-hspace "2em") - (cal-tex-Huge-bf (number-to-string year)) - (cal-tex-nl ".5cm") - (cal-tex-e-center) - (cal-tex-hspace "-.2in") - (cal-tex-b-parbox "l" "\\textwidth") - (calendar-for-loop j from 1 to 3 do - (cal-tex-week-hours date holidays "5") - (setq date (cal-tex-incr-date date))) - (cal-tex-e-parbox) - (cal-tex-nl) - (insert (cal-tex-mini-calendar - (extract-calendar-month (cal-tex-previous-month date)) - (extract-calendar-year (cal-tex-previous-month date)) - "lastmonth" "1.1in" "1in")) - (insert (cal-tex-mini-calendar - (extract-calendar-month date) - (extract-calendar-year date) - "thismonth" "1.1in" "1in")) - (insert (cal-tex-mini-calendar - (extract-calendar-month (cal-tex-next-month date)) - (extract-calendar-year (cal-tex-next-month date)) - "nextmonth" "1.1in" "1in")) - (insert "\\hbox to \\textwidth{") - (cal-tex-hfill) - (insert "\\lastmonth") - (cal-tex-hfill) - (insert "\\thismonth") - (cal-tex-hfill) - (insert "\\nextmonth") - (cal-tex-hfill) - (insert "}") - (cal-tex-nl) - (cal-tex-b-parbox "l" "\\textwidth") - (calendar-for-loop j from 4 to 7 do - (cal-tex-week-hours date holidays "5") - (setq date (cal-tex-incr-date date))) - (cal-tex-e-parbox) - (setq month (extract-calendar-month date)) - (setq year (extract-calendar-year date)) - (if (/= i n) - (progn - (run-hooks 'cal-tex-week-hook) - (cal-tex-newpage)))) - (cal-tex-end-document) - (run-hooks 'cal-tex-hook))) - -(defun cal-tex-cursor-week-iso (&optional arg) - "Make a buffer with LaTeX commands for a one page ISO-style weekly calendar. -Optional prefix argument specifies number of weeks. -Diary entries are included if `cal-tex-diary' is t. -Holidays are included if `cal-tex-holidays' is t." - (interactive "P") - (let* ((n (if arg arg 1)) - (date (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before - 1 - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - (month (extract-calendar-month date)) - (year (extract-calendar-year date)) - (day (extract-calendar-day date)) - (holidays (if cal-tex-holidays - (cal-tex-list-holidays - (calendar-absolute-from-gregorian date) - (+ (* 7 n) - (calendar-absolute-from-gregorian date))))) - (diary-list (if cal-tex-diary - (cal-tex-list-diary-entries - (calendar-absolute-from-gregorian - (list month 1 year)) - (+ (* 7 n) - (calendar-absolute-from-gregorian date)))))) - (cal-tex-preamble "11pt") - (cal-tex-cmd "\\textwidth 6.5in") - (cal-tex-cmd "\\textheight 10.5in") - (cal-tex-cmd "\\oddsidemargin 0in") - (cal-tex-cmd "\\evensidemargin 0in") - (cal-tex-b-document) - (cal-tex-cmd "\\pagestyle{empty}") - (calendar-for-loop i from 1 to n do - (cal-tex-vspace "-1.5in") - (cal-tex-b-center) - (cal-tex-Huge-bf - (let* ((d (calendar-iso-from-absolute - (calendar-absolute-from-gregorian date)))) - (format "Week %d of %d" - (extract-calendar-month d) - (extract-calendar-year d)))) - (cal-tex-nl ".5cm") - (cal-tex-e-center) - (cal-tex-b-parbox "l" "\\textwidth") - (calendar-for-loop j from 1 to 7 do - (cal-tex-b-parbox "t" "\\textwidth") - (cal-tex-b-parbox "t" "\\textwidth") - (cal-tex-rule "0pt" "\\textwidth" ".2mm") - (cal-tex-nl) - (cal-tex-b-parbox "t" "\\textwidth") - (cal-tex-large-bf (calendar-day-name date)) - (insert ", ") - (cal-tex-large-bf (calendar-month-name month)) - (insert " ") - (cal-tex-large-bf (number-to-string day)) - (if (not (string= "" (cal-tex-latexify-list holidays date))) - (progn - (insert ": ") - (cal-tex-large-bf (cal-tex-latexify-list holidays date "; ")))) - (cal-tex-hfill) - (insert " " (eval cal-tex-daily-string)) - (cal-tex-e-parbox) - (cal-tex-nl) - (cal-tex-noindent) - (cal-tex-b-parbox "t" "\\textwidth") - (if (not (string= "" (cal-tex-latexify-list diary-list date))) - (progn - (insert "\\vbox to 0pt{") - (cal-tex-large-bf - (cal-tex-latexify-list diary-list date)) - (insert "}"))) - (cal-tex-e-parbox) - (cal-tex-nl) - (setq date (cal-tex-incr-date date)) - (setq month (extract-calendar-month date)) - (setq day (extract-calendar-day date)) - (cal-tex-e-parbox) - (cal-tex-e-parbox "2cm") - (cal-tex-nl) - (setq month (extract-calendar-month date)) - (setq year (extract-calendar-year date))) - (cal-tex-e-parbox)% - (if (/= i n) - (progn - (run-hooks 'cal-tex-week-hook) - (cal-tex-newpage)))) - (cal-tex-end-document) - (run-hooks 'cal-tex-hook))) - -(defvar cal-tex-LaTeX-hourbox - "\\newcommand{\\hourbox}[2]% -{\\makebox[2em]{\\rule{0cm}{#2ex}#1}\\rule{3in}{.15mm}}\n" - "One hour and a line on the right.") - -(defun cal-tex-week-hours (date holidays height) - "Insert hourly entries for DATE with HOLIDAYS, with line height HEIGHT." - (let ((month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (afternoon)) - (cal-tex-comment "begin cal-tex-week-hours") - (cal-tex-cmd "\\ \\\\[-.2cm]") - (cal-tex-cmd "\\noindent") - (cal-tex-b-parbox "l" "6.8in") - (cal-tex-large-bf (calendar-day-name date)) - (insert ", ") - (cal-tex-large-bf (calendar-month-name month)) - (insert " ") - (cal-tex-large-bf (number-to-string day)) - (if (not (string= "" (cal-tex-latexify-list holidays date))) - (progn - (insert ": ") - (cal-tex-large-bf (cal-tex-latexify-list holidays date "; ")))) - (cal-tex-hfill) - (insert " " (eval cal-tex-daily-string)) - (cal-tex-e-parbox) - (cal-tex-nl "-.3cm") - (cal-tex-rule "0pt" "6.8in" ".2mm") - (cal-tex-nl "-.1cm") - (calendar-for-loop i from 8 to 12 do - (if cal-tex-24 - (setq afternoon (+ i 5)) - (setq afternoon (- i 7))) - (cal-tex-cmd "\\hourbox" (number-to-string i)) - (cal-tex-arg height) - (cal-tex-hspace ".4cm") - (cal-tex-cmd "\\hourbox" (number-to-string afternoon)) - (cal-tex-arg height) - (cal-tex-nl)))) - -(defun cal-tex-cursor-week-monday (&optional arg) - "Make a buffer with LaTeX commands for a two-page one-week calendar. -It applies to the week that point is in, and starts on Monday. -Optional prefix argument specifies number of weeks. -Holidays are included if `cal-tex-holidays' is t." - (interactive "P") - (let* ((n (if arg arg 1)) - (date (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before - 0 - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t)))))) - (cal-tex-preamble "11pt") - (cal-tex-cmd "\\textwidth 6.5in") - (cal-tex-cmd "\\textheight 10.5in") - (cal-tex-cmd "\\oddsidemargin 0in") - (cal-tex-cmd "\\evensidemargin 0in") - (cal-tex-b-document) - (calendar-for-loop i from 1 to n do - (cal-tex-vspace "-1cm") - (insert "\\noindent ") - (cal-tex-weekly4-box (cal-tex-incr-date date) nil) - (cal-tex-weekly4-box (cal-tex-incr-date date 4) nil) - (cal-tex-nl ".2cm") - (cal-tex-weekly4-box (cal-tex-incr-date date 2) nil) - (cal-tex-weekly4-box (cal-tex-incr-date date 5) nil) - (cal-tex-nl ".2cm") - (cal-tex-weekly4-box (cal-tex-incr-date date 3) nil) - (cal-tex-weekly4-box (cal-tex-incr-date date 6) t) - (if (/= i n) - (progn - (run-hooks 'cal-tex-week-hook) - (setq date (cal-tex-incr-date date 7)) - (cal-tex-newpage)))) - (cal-tex-end-document) - (run-hooks 'cal-tex-hook))) - -(defun cal-tex-weekly4-box (date weekend) - "Make one box for DATE, different if WEEKEND." - (let* ( - (day (extract-calendar-day date)) - (month (extract-calendar-month date)) - (year (extract-calendar-year date)) - (dayname (calendar-day-name date)) - (date1 (cal-tex-incr-date date)) - (day1 (extract-calendar-day date1)) - (month1 (extract-calendar-month date1)) - (year1 (extract-calendar-year date1)) - (dayname1 (calendar-day-name date1)) - ) - (cal-tex-b-framebox "8cm" "l") - (cal-tex-b-parbox "b" "7.5cm") - (insert (format "{\\Large\\bf %s,} %s/%s/%s\\\\\n" dayname month day year)) - (cal-tex-rule "0pt" "7.5cm" ".5mm") - (cal-tex-nl) - (if (not weekend) - (progn - (calendar-for-loop i from 8 to 12 do - (insert (format "{\\large\\sf %d}\\\\\n" i))) - (calendar-for-loop i from 1 to 5 do - (insert (format "{\\large\\sf %d}\\\\\n" i))))) - (cal-tex-nl ".5cm") - (if weekend - (progn - (cal-tex-vspace "1cm") - (insert "\\ \\vfill") - (insert (format "{\\Large\\bf %s,} %s/%s/%s\\\\\n" - dayname1 month1 day1 year1)) - (cal-tex-rule "0pt" "7.5cm" ".5mm") - (cal-tex-nl "1.5cm") - (cal-tex-vspace "1cm"))) - (cal-tex-e-parbox) - (cal-tex-e-framebox) - (cal-tex-hspace "1cm"))) - -(defun cal-tex-cursor-filofax-2week (&optional arg) - "Two-weeks-at-a-glance Filofax style calendar for week indicated by cursor. -Optional prefix argument specifies number of weeks. -Diary entries are included if `cal-tex-diary' is t. -Holidays are included if `cal-tex-holidays' is t." - (interactive "P") - (let* ((n (if arg arg 1)) - (date (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before - calendar-week-start-day - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - (month (extract-calendar-month date)) - (year (extract-calendar-year date)) - (day (extract-calendar-day date)) - (holidays (if cal-tex-holidays - (cal-tex-list-holidays - (calendar-absolute-from-gregorian date) - (+ (* 7 n) - (calendar-absolute-from-gregorian date))))) - (diary-list (if cal-tex-diary - (cal-tex-list-diary-entries - (calendar-absolute-from-gregorian - (list month 1 year)) - (+ (* 7 n) - (calendar-absolute-from-gregorian date)))))) - (cal-tex-preamble "twoside") - (cal-tex-cmd "\\textwidth 3.25in") - (cal-tex-cmd "\\textheight 6.5in") - (cal-tex-cmd "\\oddsidemargin 1.75in") - (cal-tex-cmd "\\evensidemargin 1.5in") - (cal-tex-cmd "\\topmargin 0pt") - (cal-tex-cmd "\\headheight -0.875in") - (cal-tex-cmd "\\headsep 0.125in") - (cal-tex-cmd "\\footskip .125in") - (insert "\\def\\righthead#1{\\hfill {\\normalsize \\bf #1}\\\\[-6pt]} -\\long\\def\\rightday#1#2#3#4#5{% - \\rule{\\textwidth}{0.3pt}\\\\% - \\hbox to \\textwidth{% - \\vbox to 0.7in{% - \\vspace*{2pt}% - \\hbox to \\textwidth{\\small #5 \\hfill #1 {\\normalsize \\bf #2}}% - \\hbox to \\textwidth{\\vbox {\\raggedleft \\footnotesize \\em #4}}% - \\hbox to \\textwidth{\\vbox to 0pt {\\noindent \\footnotesize #3}}}}\\\\} -\\def\\lefthead#1{\\noindent {\\normalsize \\bf #1}\\hfill\\\\[-6pt]} -\\long\\def\\leftday#1#2#3#4#5{% - \\rule{\\textwidth}{0.3pt}\\\\% - \\hbox to \\textwidth{% - \\vbox to 0.7in{% - \\vspace*{2pt}% - \\hbox to \\textwidth{\\noindent {\\normalsize \\bf #2} \\small #1 \\hfill #5}% - \\hbox to \\textwidth{\\vbox {\\noindent \\footnotesize \\em #4}}% - \\hbox to \\textwidth{\\vbox to 0pt {\\noindent \\footnotesize #3}}}}\\\\} -") - (cal-tex-b-document) - (cal-tex-cmd "\\pagestyle{empty}") - (calendar-for-loop i from 1 to n do - (if (= (mod i 2) 1) - (insert "\\righthead") - (insert "\\lefthead")) - (cal-tex-arg - (let ((d (cal-tex-incr-date date 6))) - (if (= (extract-calendar-month date) - (extract-calendar-month d)) - (format "%s %s" - (calendar-month-name - (extract-calendar-month date)) - (extract-calendar-year date)) - (if (= (extract-calendar-year date) - (extract-calendar-year d)) - (format "%s---%s %s" - (calendar-month-name - (extract-calendar-month date)) - (calendar-month-name - (extract-calendar-month d)) - (extract-calendar-year date)) - (format "%s %s---%s %s" - (calendar-month-name - (extract-calendar-month date)) - (extract-calendar-year date) - (calendar-month-name (extract-calendar-month d)) - (extract-calendar-year d)))))) - (insert "%\n") - (calendar-for-loop j from 1 to 7 do - (if (= (mod i 2) 1) - (insert "\\rightday") - (insert "\\leftday")) - (cal-tex-arg (calendar-day-name date)) - (cal-tex-arg (int-to-string (extract-calendar-day date))) - (cal-tex-arg (cal-tex-latexify-list diary-list date)) - (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) - (insert "%\n") - (setq date (cal-tex-incr-date date))) - (if (/= i n) - (progn - (run-hooks 'cal-tex-week-hook) - (cal-tex-newpage)))) - (cal-tex-end-document) - (run-hooks 'cal-tex-hook))) - -(defun cal-tex-cursor-filofax-week (&optional arg) - "One-week-at-a-glance Filofax style calendar for week indicated by cursor. -Optional prefix argument specifies number of weeks. -Weeks start on Monday. -Diary entries are included if `cal-tex-diary' is t. -Holidays are included if `cal-tex-holidays' is t." - (interactive "P") - (let* ((n (if arg arg 1)) - (date (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before - 1 - (calendar-absolute-from-gregorian - (calendar-cursor-to-date t))))) - (month (extract-calendar-month date)) - (year (extract-calendar-year date)) - (day (extract-calendar-day date)) - (holidays (if cal-tex-holidays - (cal-tex-list-holidays - (calendar-absolute-from-gregorian date) - (+ (* 7 n) - (calendar-absolute-from-gregorian date))))) - (diary-list (if cal-tex-diary - (cal-tex-list-diary-entries - (calendar-absolute-from-gregorian - (list month 1 year)) - (+ (* 7 n) - (calendar-absolute-from-gregorian date)))))) - (cal-tex-preamble "twoside") - (cal-tex-cmd "\\textwidth 3.25in") - (cal-tex-cmd "\\textheight 6.5in") - (cal-tex-cmd "\\oddsidemargin 1.75in") - (cal-tex-cmd "\\evensidemargin 1.5in") - (cal-tex-cmd "\\topmargin 0pt") - (cal-tex-cmd "\\headheight -0.875in") - (cal-tex-cmd "\\headsep 0.125in") - (cal-tex-cmd "\\footskip .125in") - (insert "\\def\\righthead#1{\\hfill {\\normalsize \\bf #1}\\\\[-6pt]} -\\long\\def\\rightday#1#2#3#4#5{% - \\rule{\\textwidth}{0.3pt}\\\\% - \\hbox to \\textwidth{% - \\vbox to 1.85in{% - \\vspace*{2pt}% - \\hbox to \\textwidth{\\small #5 \\hfill #1 {\\normalsize \\bf #2}}% - \\hbox to \\textwidth{\\vbox {\\raggedleft \\footnotesize \\em #4}}% - \\hbox to \\textwidth{\\vbox to 0pt {\\noindent \\footnotesize #3}}}}\\\\} -\\long\\def\\weekend#1#2#3#4#5{% - \\rule{\\textwidth}{0.3pt}\\\\% - \\hbox to \\textwidth{% - \\vbox to .8in{% - \\vspace*{2pt}% - \\hbox to \\textwidth{\\small #5 \\hfill #1 {\\normalsize \\bf #2}}% - \\hbox to \\textwidth{\\vbox {\\raggedleft \\footnotesize \\em #4}}% - \\hbox to \\textwidth{\\vbox to 0pt {\\noindent \\footnotesize #3}}}}\\\\} -\\def\\lefthead#1{\\noindent {\\normalsize \\bf #1}\\hfill\\\\[-6pt]} -\\long\\def\\leftday#1#2#3#4#5{% - \\rule{\\textwidth}{0.3pt}\\\\% - \\hbox to \\textwidth{% - \\vbox to 1.85in{% - \\vspace*{2pt}% - \\hbox to \\textwidth{\\noindent {\\normalsize \\bf #2} \\small #1 \\hfill #5}% - \\hbox to \\textwidth{\\vbox {\\noindent \\footnotesize \\em #4}}% - \\hbox to \\textwidth{\\vbox to 0pt {\\noindent \\footnotesize #3}}}}\\\\} -") - (cal-tex-b-document) - (cal-tex-cmd "\\pagestyle{empty}\\ ") - (cal-tex-newpage) - (calendar-for-loop i from 1 to n do - (insert "\\lefthead") - (cal-tex-arg - (let ((d (cal-tex-incr-date date 2))) - (if (= (extract-calendar-month date) - (extract-calendar-month d)) - (format "%s %s" - (calendar-month-name - (extract-calendar-month date)) - (extract-calendar-year date)) - (if (= (extract-calendar-year date) - (extract-calendar-year d)) - (format "%s---%s %s" - (calendar-month-name - (extract-calendar-month date)) - (calendar-month-name - (extract-calendar-month d)) - (extract-calendar-year date)) - (format "%s %s---%s %s" - (calendar-month-name - (extract-calendar-month date)) - (extract-calendar-year date) - (calendar-month-name (extract-calendar-month d)) - (extract-calendar-year d)))))) - (insert "%\n") - (calendar-for-loop j from 1 to 3 do - (insert "\\leftday") - (cal-tex-arg (calendar-day-name date)) - (cal-tex-arg (int-to-string (extract-calendar-day date))) - (cal-tex-arg (cal-tex-latexify-list diary-list date)) - (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) - (insert "%\n") - (setq date (cal-tex-incr-date date))) - (insert "\\noindent\\rule{\\textwidth}{0.3pt}\\\\%\n") - (cal-tex-newpage) - (insert "\\righthead") - (cal-tex-arg - (let ((d (cal-tex-incr-date date 3))) - (if (= (extract-calendar-month date) - (extract-calendar-month d)) - (format "%s %s" - (calendar-month-name - (extract-calendar-month date)) - (extract-calendar-year date)) - (if (= (extract-calendar-year date) - (extract-calendar-year d)) - (format "%s---%s %s" - (calendar-month-name - (extract-calendar-month date)) - (calendar-month-name - (extract-calendar-month d)) - (extract-calendar-year date)) - (format "%s %s---%s %s" - (calendar-month-name - (extract-calendar-month date)) - (extract-calendar-year date) - (calendar-month-name (extract-calendar-month d)) - (extract-calendar-year d)))))) - (insert "%\n") - (calendar-for-loop j from 1 to 2 do - (insert "\\rightday") - (cal-tex-arg (calendar-day-name date)) - (cal-tex-arg (int-to-string (extract-calendar-day date))) - (cal-tex-arg (cal-tex-latexify-list diary-list date)) - (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) - (insert "%\n") - (setq date (cal-tex-incr-date date))) - (calendar-for-loop j from 1 to 2 do - (insert "\\weekend") - (cal-tex-arg (calendar-day-name date)) - (cal-tex-arg (int-to-string (extract-calendar-day date))) - (cal-tex-arg (cal-tex-latexify-list diary-list date)) - (cal-tex-arg (cal-tex-latexify-list holidays date)) - (cal-tex-arg (eval cal-tex-daily-string)) - (insert "%\n") - (setq date (cal-tex-incr-date date))) - (if (/= i n) - (progn - (run-hooks 'cal-tex-week-hook) - (cal-tex-newpage)))) - (cal-tex-end-document) - (run-hooks 'cal-tex-hook))) -;;; -;;; Daily calendars -;;; - -(defun cal-tex-cursor-day (&optional arg) - "Make a buffer with LaTeX commands for the day cursor is on. -Optional prefix argument specifies number of days." - (interactive "P") - (let ((n (if arg arg 1)) - (date (calendar-absolute-from-gregorian (calendar-cursor-to-date t)))) - (cal-tex-preamble "12pt") - (cal-tex-cmd "\\textwidth 6.5in") - (cal-tex-cmd "\\textheight 10.5in") - (cal-tex-b-document) - (cal-tex-cmd "\\pagestyle{empty}") - (calendar-for-loop i from 1 to n do - (cal-tex-vspace "-1.7in") - (cal-tex-daily-page (calendar-gregorian-from-absolute date)) - (setq date (1+ date)) - (if (/= i n) - (progn - (cal-tex-newpage) - (run-hooks 'cal-tex-daily-hook)))) - (cal-tex-end-document) - (run-hooks 'cal-tex-hook))) - -(defun cal-tex-daily-page (date) - "Make a calendar page for Gregorian DATE on 8.5 by 11 paper." - (let* ((hour) - (month-name (calendar-month-name (extract-calendar-month date)))) - (cal-tex-banner "cal-tex-daily-page") - (cal-tex-b-makebox "4cm" "l") - (cal-tex-b-parbox "b" "3.8cm") - (cal-tex-rule "0mm" "0mm" "2cm") - (cal-tex-Huge (number-to-string (extract-calendar-day date))) - (cal-tex-nl ".5cm") - (cal-tex-bf month-name ) - (cal-tex-e-parbox) - (cal-tex-hspace "1cm") - (cal-tex-scriptsize (eval cal-tex-daily-string)) - (cal-tex-hspace "3.5cm") - (cal-tex-e-makebox) - (cal-tex-hfill) - (cal-tex-b-makebox "4cm" "r") - (cal-tex-bf (calendar-day-name date)) - (cal-tex-e-makebox) - (cal-tex-nl) - (cal-tex-hspace ".4cm") - (cal-tex-rule "0mm" "16.1cm" "1mm") - (cal-tex-nl ".1cm") - (calendar-for-loop i from cal-tex-daily-start to cal-tex-daily-end do - (cal-tex-cmd "\\noindent") - (setq hour (if cal-tex-24 - i - (mod i 12))) - (if (= 0 hour) (setq hour 12)) - (cal-tex-b-makebox "1cm" "c") - (cal-tex-arg (number-to-string hour)) - (cal-tex-e-makebox) - (cal-tex-rule "0mm" "15.5cm" ".2mm") - (cal-tex-nl ".2cm") - (cal-tex-b-makebox "1cm" "c") - (cal-tex-arg "$\\diamond$" ) - (cal-tex-e-makebox) - (cal-tex-rule "0mm" "15.5cm" ".2mm") - (cal-tex-nl ".2cm")) - (cal-tex-hfill) - (insert (cal-tex-mini-calendar - (extract-calendar-month (cal-tex-previous-month date)) - (extract-calendar-year (cal-tex-previous-month date)) - "lastmonth" "1.1in" "1in")) - (insert (cal-tex-mini-calendar - (extract-calendar-month date) - (extract-calendar-year date) - "thismonth" "1.1in" "1in")) - (insert (cal-tex-mini-calendar - (extract-calendar-month (cal-tex-next-month date)) - (extract-calendar-year (cal-tex-next-month date)) - "nextmonth" "1.1in" "1in")) - (insert "\\hbox to \\textwidth{") - (cal-tex-hfill) - (insert "\\lastmonth") - (cal-tex-hfill) - (insert "\\thismonth") - (cal-tex-hfill) - (insert "\\nextmonth") - (cal-tex-hfill) - (insert "}") - (cal-tex-banner "end of cal-tex-daily-page"))) - -;;; -;;; Mini calendars -;;; - -(defun cal-tex-mini-calendar (month year name width height &optional ptsize colsep) - "Produce mini-calendar for MONTH, YEAR in macro NAME with WIDTH and HEIGHT. -Optional PTSIZE gives the point ptsize; scriptsize is the default. Optional -COLSEP gives the column separation; 1mm is the default." - (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)) - (colsep (if colsep colsep "1mm")) - (str (concat "\\def\\" name "{\\hbox to" width "{%\n" - "\\vbox to" height "{%\n" - "\\vfil \\hbox to" width "{%\n" - "\\hfil\\" - (if ptsize ptsize "scriptsize") - "\\begin{tabular}" - "{@{\\hspace{0mm}}r@{\\hspace{" colsep - "}}r@{\\hspace{" colsep "}}r@{\\hspace{" colsep - "}}r@{\\hspace{" colsep "}}r@{\\hspace{" colsep - "}}r@{\\hspace{" colsep "}}r@{\\hspace{0mm}}}%\n" - "\\multicolumn{7}{c}{" - (calendar-month-name month) - " " - (int-to-string year) - "}\\\\[1mm]\n"))) - (calendar-for-loop i from 0 to 6 do - (setq str (concat str - (substring (aref calendar-day-name-array - (mod (+ calendar-week-start-day i) 7)) - 0 2) - (if (/= i 6) - " & " - "\\\\[0.7mm]\n")))) - (calendar-for-loop i from 1 to blank-days do - (setq str (concat str " & "))) - (calendar-for-loop i from 1 to last do - (setq str (concat str (int-to-string i))) - (setq str (concat str (if (zerop (mod (+ i blank-days) 7)) - (if (/= i last) "\\\\[0.5mm]\n" "") - " & ")))) - (setq str (concat str "\n\\end{tabular}\\hfil}\\vfil}}}%\n")) - str)) - -;;; -;;; Various calendar functions -;;; - -(defun cal-tex-incr-date (date &optional n) - "The date of the day following DATE. -If optional N is given, the date of N days after DATE." - (calendar-gregorian-from-absolute - (+ (if n n 1) (calendar-absolute-from-gregorian date)))) - -(defun cal-tex-latexify-list (date-list date &optional separator) - "Return string with concatenated, LaTeXified entries in DATE_LIST for DATE. -Use double backslash as a separator unless optional SEPARATOR is given." - (mapconcat '(lambda (x) (cal-tex-LaTeXify-string x)) - (let ((result) - (p date-list)) - (while p - (and (car (car p)) - (calendar-date-equal date (car (car p))) - (setq result (append (cdr (car p)) result))) - (setq p (cdr p))) - result) - (if separator separator "\\\\"))) - -(defun cal-tex-previous-month (date) - "Return the date of the first day in the month previous to DATE." - (let* ((month (extract-calendar-month date)) - (year (extract-calendar-year date))) - (increment-calendar-month month year -1) - (list month 1 year))) - -(defun cal-tex-next-month (date) - "Return the date of the first day in the month following DATE." - (let* ((month (extract-calendar-month date)) - (year (extract-calendar-year date))) - (increment-calendar-month month year 1) - (list month 1 year))) - -;;; -;;; LaTeX Code -;;; - -(defun cal-tex-end-document () - "Finish the LaTeX document. -Insert the trailer to LaTeX document, pop to LaTeX buffer, add -informative header, and run HOOK." - (cal-tex-e-document) - (latex-mode) - (pop-to-buffer cal-tex-buffer) - (goto-char (point-min)) - (cal-tex-comment " This buffer was produced by cal-tex.el.") - (cal-tex-comment " To print a calendar, type") - (cal-tex-comment " M-x tex-buffer RET") - (cal-tex-comment " M-x tex-print RET") - (goto-char (point-min))) - -(defun cal-tex-insert-preamble (weeks landscape size &optional append) - "Initialize the output buffer. -Select the output buffer, and insert the preamble for a calendar of -WEEKS weeks. Insert code for landscape mode if LANDSCAPE is true. -Use pointsize SIZE. Optional argument APPEND, if t, means add to end of -without erasing current contents." - (let ((width "18cm") - (height "24cm")) - (if landscape - (progn - (setq width "24cm") - (setq height "18cm"))) - (if (not append) - (progn - (cal-tex-preamble size) - (if (not landscape) - (progn - (cal-tex-cmd "\\oddsidemargin -1.75cm") - (cal-tex-cmd "\\def\\holidaymult{.06}")) - (cal-tex-cmd "\\special{landscape}") - (cal-tex-cmd "\\textwidth 9.5in") - (cal-tex-cmd "\\textheight 7in") - (cal-tex-comment) - (cal-tex-cmd "\\def\\holidaymult{.08}")) - (cal-tex-cmd cal-tex-caldate) - (cal-tex-cmd cal-tex-myday) - (cal-tex-b-document) - (cal-tex-cmd "\\pagestyle{empty}"))) - (cal-tex-cmd "\\setlength{\\cellwidth}" width) - (insert (format "\\setlength{\\cellwidth}{%f\\cellwidth}\n" - (/ 1.1 (length cal-tex-which-days)))) - (cal-tex-cmd "\\setlength{\\cellheight}" height) - (insert (format "\\setlength{\\cellheight}{%f\\cellheight}\n" - (/ 1.0 weeks))) - (cal-tex-cmd "\\ \\par") - (cal-tex-vspace "-3cm"))) - -(defvar cal-tex-LaTeX-subst-list - '(("\"". "``") - ("\"". "''");; Quote changes meaning when list is reversed. - ("@" . "\\verb|@|") - ("&" . "\\&") - ("%" . "\\%") - ("$" . "\\$") - ("#" . "\\#") - ("_" . "\\_") - ("{" . "\\{") - ("}" . "\\}") - ("<" . "$<$") - (">" . "$>$") - ("\n" . "\\ \\\\")) ;\\ needed for e.g \begin{center}\n AA\end{center} - "List of symbols and their replacements.") - -(defun cal-tex-LaTeXify-string (string) - "Protect special characters in STRING from LaTeX." - (if (not string) - "" - (let ((head "") - (tail string) - (list cal-tex-LaTeX-subst-list)) - (while (not (string-equal tail "")) - (let* ((ch (substring tail 0 1)) - (pair (assoc ch list))) - (if (and pair (string-equal ch "\"")) - (setq list (reverse list)));; Quote changes meaning each time. - (setq tail (substring tail 1)) - (setq head (concat head (if pair (cdr pair) ch))))) - head))) - -(defun cal-tex-hfill () "Insert hfill." (insert "\\hfill")) - -(defun cal-tex-newpage () "Insert newpage." (insert "\\newpage%\n")) - -(defun cal-tex-noindent () "Insert noindent." (insert "\\noindent")) - -(defun cal-tex-vspace (space) - "Insert vspace command to move SPACE vertically." - (insert "\\vspace*{" space "}") - (cal-tex-comment)) - -(defun cal-tex-hspace (space) - "Insert hspace command to move SPACE horizontally." - (insert "\\hspace*{" space "}") - (cal-tex-comment)) - -(defun cal-tex-comment (&optional comment) - "Insert % at end of line, include COMMENT if present, and move - to next line." - (insert "% ") - (if comment - (insert comment)) - (insert "\n")) - -(defun cal-tex-banner (comment) - "Insert the COMMENT separated by blank lines." - (cal-tex-comment) - (cal-tex-comment) - (cal-tex-comment (concat "\t\t\t" comment)) - (cal-tex-comment)) - - -(defun cal-tex-nl (&optional skip comment) - "End a line with \\. If SKIP, then add that much spacing. - Add COMMENT if present" - (insert "\\\\") - (if skip - (insert "[" skip "]")) - (cal-tex-comment comment)) - -(defun cal-tex-arg (&optional text) - "Insert optional TEXT surrounded by braces." - (insert "{") - (if text (insert text)) - (insert "}")) - -(defun cal-tex-cmd (cmd &optional arg) - "Insert LaTeX CMD, with optional ARG, and end with %" - (insert cmd) - (cal-tex-arg arg) - (cal-tex-comment)) - -;;; -;;; Environments -;;; - -(defun cal-tex-b-document () - "Insert beginning of document." - (cal-tex-cmd "\\begin{document}")) - -(defun cal-tex-e-document () - "Insert end of document." - (cal-tex-cmd "\\end{document}")) - -(defun cal-tex-b-center () - "Insert beginning of centered block." - (cal-tex-cmd "\\begin{center}")) - -(defun cal-tex-e-center () - "Insert end of centered block." - (cal-tex-comment) - (cal-tex-cmd "\\end{center}")) - - -;;; -;;; Boxes -;;; - - -(defun cal-tex-b-parbox (position width) - "Insert parbox with parameters POSITION and WIDTH." - (insert "\\parbox[" position "]{" width "}{") - (cal-tex-comment)) - -(defun cal-tex-e-parbox (&optional height) - "Insert end of parbox. Force it to be a given HEIGHT." - (cal-tex-comment) - (if height - (cal-tex-rule "0mm" "0mm" height)) - (insert "}") - (cal-tex-comment "end parbox")) - -(defun cal-tex-b-framebox ( width position ) - "Insert framebox with parameters WIDTH and POSITION (clr)." - (insert "\\framebox[" width "][" position "]{" ) - (cal-tex-comment)) - -(defun cal-tex-e-framebox () - "Insert end of framebox." - (cal-tex-comment) - (insert "}") - (cal-tex-comment "end framebox")) - - -(defun cal-tex-b-makebox ( width position ) - "Insert makebox with parameters WIDTH and POSITION (clr)." - (insert "\\makebox[" width "][" position "]{" ) - (cal-tex-comment)) - -(defun cal-tex-e-makebox () - "Insert end of makebox." - (cal-tex-comment) - (insert "}") - (cal-tex-comment "end makebox")) - - -(defun cal-tex-rule (lower width height) - "Insert a rule with parameters LOWER WIDTH HEIGHT." - (insert "\\rule[" lower "]{" width "}{" height "}")) - -;;; -;;; Fonts -;;; - -(defun cal-tex-em (string) - "Insert STRING in bf font." - (insert "{\\em " string "}")) - -(defun cal-tex-bf (string) - "Insert STRING in bf font." - (insert "{\\bf " string "}")) - -(defun cal-tex-scriptsize (string) - "Insert STRING in scriptsize font." - (insert "{\\scriptsize " string "}")) - -(defun cal-tex-huge (string) - "Insert STRING in huge size." - (insert "{\\huge " string "}")) - -(defun cal-tex-Huge (string) - "Insert STRING in Huge size." - (insert "{\\Huge " string "}")) - -(defun cal-tex-Huge-bf (string) - "Insert STRING in Huge bf size." - (insert "{\\Huge\\bf " string "}")) - -(defun cal-tex-large (string) - "Insert STRING in large size." - (insert "{\\large " string "}")) - -(defun cal-tex-large-bf (string) - "Insert STRING in large bf size." - (insert "{\\large\\bf " string "}")) - -(provide 'cal-tex) - -;;; cal-tex.el ends here diff --git a/lisp/calendar/cal-x.el b/lisp/calendar/cal-x.el deleted file mode 100644 index c12e23cfa26..00000000000 --- a/lisp/calendar/cal-x.el +++ /dev/null @@ -1,143 +0,0 @@ -;;; cal-x.el --- calendar windows in dedicated frames in X - -;; Copyright (C) 1994, 1995 Free Software Foundation, Inc. - -;; Author: Michael Kifer <kifer@cs.sunysb.edu> -;; Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: calendar, dedicated frames, X Window System - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements dedicated frames in X for -;; calendar.el. - -;; 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 - -;;; Code: - -(require 'calendar) - -(defvar calendar-frame nil "Frame in which to display the calendar.") - -(defvar diary-frame nil "Frame in which to display the diary.") - -;; This should not specify the font. That's up to the user. -;; Certainly it should not specify auto-lower and auto-raise -;; since most users won't like that. -(defvar diary-frame-parameters - '((name . "Diary") (height . 10) (width . 80) (unsplittable . t) - (minibuffer . nil)) - "Parameters of the diary frame, if the diary is in its own frame. -Location and color should be set in .Xdefaults.") - -(defvar calendar-frame-parameters - '((name . "Calendar") (minibuffer . nil) (height . 10) (width . 80) - (unsplittable . t) (vertical-scroll-bars . nil)) - "Parameters of the calendar frame, if the calendar is in a separate frame. -Location and color should be set in .Xdefaults.") - -(defvar calendar-and-diary-frame-parameters - '((name . "Calendar") (height . 28) (width . 80) (minibuffer . nil)) - "Parameters of the frame that displays both the calendar and the diary. -Location and color should be set in .Xdefaults.") - -(defvar calendar-after-frame-setup-hooks nil - "Hooks to be run just after setting up a calendar frame. -Can be used to change frame parameters, such as font, color, location, etc.") - -(defun calendar-one-frame-setup (&optional arg) - "Start calendar and display it in a dedicated frame together with the diary." - (if (not window-system) - (calendar-basic-setup arg) - (if (frame-live-p calendar-frame) (delete-frame calendar-frame)) - (if (frame-live-p diary-frame) (delete-frame diary-frame)) - (let ((special-display-buffer-names nil) - (view-diary-entries-initially t)) - (save-window-excursion - (save-excursion - (setq calendar-frame - (make-frame calendar-and-diary-frame-parameters)) - (run-hooks 'calendar-after-frame-setup-hooks) - (select-frame calendar-frame) - (if (eq 'icon (cdr (assoc 'visibility - (frame-parameters calendar-frame)))) - (iconify-or-deiconify-frame)) - (calendar-basic-setup arg) - (set-window-dedicated-p (selected-window) 'calendar) - (set-window-dedicated-p - (display-buffer - (if (not (memq 'fancy-diary-display diary-display-hook)) - (get-file-buffer diary-file) - (if (not (bufferp (get-buffer fancy-diary-buffer))) - (make-fancy-diary-buffer)) - fancy-diary-buffer)) - 'diary)))))) - -(defun calendar-two-frame-setup (&optional arg) - "Start calendar and diary in separate, dedicated frames." - (if (not window-system) - (calendar-basic-setup arg) - (if (frame-live-p calendar-frame) (delete-frame calendar-frame)) - (if (frame-live-p diary-frame) (delete-frame diary-frame)) - (let ((pop-up-windows nil) - (view-diary-entries-initially nil) - (special-display-buffer-names nil)) - (save-window-excursion - (save-excursion (calendar-basic-setup arg)) - (setq calendar-frame (make-frame calendar-frame-parameters)) - (run-hooks 'calendar-after-frame-setup-hooks) - (select-frame calendar-frame) - (if (eq 'icon (cdr (assoc 'visibility - (frame-parameters calendar-frame)))) - (iconify-or-deiconify-frame)) - (display-buffer calendar-buffer) - (set-window-dedicated-p (selected-window) 'calendar) - (setq diary-frame (make-frame diary-frame-parameters)) - (run-hooks 'calendar-after-frame-setup-hooks) - (select-frame diary-frame) - (if (eq 'icon (cdr (assoc 'visibility - (frame-parameters diary-frame)))) - (iconify-or-deiconify-frame)) - (save-excursion (diary)) - (set-window-dedicated-p - (display-buffer - (if (not (memq 'fancy-diary-display diary-display-hook)) - (get-file-buffer diary-file) - (if (not (bufferp (get-buffer fancy-diary-buffer))) - (make-fancy-diary-buffer)) - fancy-diary-buffer)) - 'diary))))) - -(setq special-display-buffer-names - (append special-display-buffer-names - (list "*Yahrzeits*" lunar-phases-buffer holiday-buffer - fancy-diary-buffer (get-file-buffer diary-file) - calendar-buffer))) - -(run-hooks 'cal-x-load-hook) - -(provide 'cal-x) - -;;; cal-x.el ends here diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el deleted file mode 100644 index bd3d58fe48f..00000000000 --- a/lisp/calendar/calendar.el +++ /dev/null @@ -1,2336 +0,0 @@ -;;; calendar.el --- Calendar functions. - -;; Copyright (C) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995 Free -;; Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: calendar, Gregorian calendar, diary, holidays - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, 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, to the Chinese calendar, to the Coptic calendar, to the -;; Ethiopic 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. Calendar printing via LaTeX is available. - -;; The following files are part of the calendar/diary code: - -;; appt.el Appointment notification -;; cal-china.el Chinese calendar -;; cal-coptic.el Coptic/Ethiopic calendars -;; cal-dst.el Daylight savings time rules -;; cal-hebrew.el Hebrew calendar -;; cal-islam.el Islamic calendar -;; cal-iso.el ISO calendar -;; cal-julian.el Julian/astronomical calendars -;; cal-mayan.el Mayan calendars -;; cal-menu.el Menu support -;; cal-move.el Movement in the calendar -;; cal-persia.el Persian calendar -;; cal-tex.el Calendars in LaTeX -;; cal-x.el X-windows dedicated frame functions -;; diary-lib.el Diary functions -;; holidays.el Holiday functions -;; lunar.el Phases of the moon -;; solar.el Sunrise/sunset, equinoxes/solstices - -;; 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 - -;; 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 6, October 12, 1995")) - -;;;###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 - (if (not window-system) - "+" - (require 'faces) - (add-to-list 'facemenu-unlisted-faces 'diary-face) - (make-face 'diary-face) - (cond ((face-differs-from-default-p 'diary-face)) - ((x-display-color-p) (set-face-foreground 'diary-face "red")) - (t (copy-face 'bold 'diary-face))) - 'diary-face) - "*Used to mark dates that have diary entries. -Can be either a single-character string or a face.") - -(defvar calendar-today-marker - (if (not window-system) - "=" - (require 'faces) - (add-to-list 'facemenu-unlisted-faces 'calendar-today-face) - (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 - (if (not window-system) - "*" - (require 'faces) - (add-to-list 'facemenu-unlisted-faces 'holiday-face) - (make-face 'holiday-face) - (cond ((face-differs-from-default-p 'holiday-face)) - ((x-display-color-p) (set-face-background 'holiday-face "pink")) - (t (set-face-background 'holiday-face "black") - (set-face-foreground 'holiday-face "white"))) - '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-chinese-date', `diary-coptic-date', `diary-ethiopic-date', -`diary-persian-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 Fools' 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 'oriental-holidays 'risky-local-variable t) -;;;###autoload -(defvar oriental-holidays - '((if (fboundp 'atan) - (holiday-chinese-new-year))) - "*Oriental holidays. -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 - oriental-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', `oriental-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 'calendar-goto-today "cal-move" - "Reposition the calendar window so the current date is visible." - t) - -(autoload 'calendar-forward-month "cal-move" - "Move the cursor forward ARG months." - t) - -(autoload 'calendar-forward-year "cal-move" - "Move the cursor forward by ARG years." - t) - -(autoload 'calendar-backward-month "cal-move" - "Move the cursor backward by ARG months." - t) - -(autoload 'calendar-backward-year "cal-move" - "Move the cursor backward ARG years." - t) - -(autoload 'scroll-calendar-left "cal-move" - "Scroll the displayed calendar left by ARG months." - t) - -(autoload 'scroll-calendar-right "cal-move" - "Scroll the displayed calendar window right by ARG months." - t) - -(autoload 'scroll-calendar-left-three-months "cal-move" - "Scroll the displayed calendar window left by 3*ARG months." - t) - -(autoload 'scroll-calendar-right-three-months "cal-move" - "Scroll the displayed calendar window right by 3*ARG months." - t) - -(autoload 'calendar-cursor-to-nearest-date "cal-move" - "Move the cursor to the closest date." - t) - -(autoload 'calendar-forward-day "cal-move" - "Move the cursor forward ARG days." - t) - -(autoload 'calendar-backward-day "cal-move" - "Move the cursor back ARG days." - t) - -(autoload 'calendar-forward-week "cal-move" - "Move the cursor forward ARG weeks." - t) - -(autoload 'calendar-backward-week "cal-move" - "Move the cursor back ARG weeks." - t) - -(autoload 'calendar-beginning-of-week "cal-move" - "Move the cursor back ARG calendar-week-start-day's." - t) - -(autoload 'calendar-end-of-week "cal-move" - "Move the cursor forward ARG calendar-week-start-day+6's." - t) - -(autoload 'calendar-beginning-of-month "cal-move" - "Move the cursor backward ARG month beginnings." - t) - -(autoload 'calendar-end-of-month "cal-move" - "Move the cursor forward ARG month ends." - t) - -(autoload 'calendar-beginning-of-year "cal-move" - "Move the cursor backward ARG year beginnings." - t) - -(autoload 'calendar-end-of-year "cal-move" - "Move the cursor forward ARG year beginnings." - t) - -(autoload 'calendar-cursor-to-visible-date "cal-move" - "Move the cursor to DATE that is on the screen." - t) - -(autoload 'calendar-goto-date "cal-move" - "Move cursor to DATE." - t) - -(autoload 'calendar-one-frame-setup "cal-x" - "Start calendar and display it in a dedicated frame together with the diary.") - -(autoload 'calendar-two-frame-setup "cal-x" - "Start calendar and diary in separate, dedicated frames.") - -;;;###autoload -(defvar calendar-setup nil - "The frame set up of the calendar. -The choices are `one-frame' (calendar and diary together in one separate, -dedicated frame) or `two-frames' (calendar and diary in separate, dedicated -frames); with any other value the current frame is used.") - -;;;###autoload -(defun calendar (&optional arg) - "Choose between the one frame, two frame, or basic calendar displays. -The original function `calendar' has been renamed `calendar-basic-setup'." - (interactive "P") - (cond ((equal calendar-setup 'one-frame) (calendar-one-frame-setup arg)) - ((equal calendar-setup 'two-frames) (calendar-two-frame-setup arg)) - (t (calendar-basic-setup arg)))) - -(defun calendar-basic-setup (&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 -every time 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/Tzolkin combination." - t) - -(autoload 'calendar-previous-calendar-round-date "cal-mayan" - "Move cursor to previous instance of Mayan Haab/Tzolkin combination." - t) - -(autoload 'calendar-goto-chinese-date "cal-china" - "Move cursor to Chinese date." - t) - -(autoload 'calendar-print-chinese-date "cal-china" - "Show the Chinese date equivalents of date." - t) - -(autoload 'calendar-chinese-date-string "cal-china" - "String of Chinese date of Gregorian date." - t) - -(autoload 'calendar-absolute-from-astro - "Absolute date of astronomical (Julian) day number D." - "cal-julian") - -(autoload 'calendar-astro-from-absolute "cal-julian" - "Astronomical (Julian) day number of absolute date D.") - -(autoload 'calendar-astro-date-string "cal-julian" - "String of astronomical (Julian) day number of Gregorian date." - t) - -(autoload 'calendar-goto-astro-date "cal-julian" - "Move cursor to astronomical (Julian) day number." - t) - -(autoload 'calendar-julian-from-absolute "cal-julian" - "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.") - -(autoload 'calendar-goto-julian-date "cal-julian" - "Move cursor to Julian DATE; echo Julian date unless NOECHO is t." - t) - -(autoload 'calendar-julian-date-string "cal-julian" - "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'." - t) - -(autoload 'calendar-goto-iso-date "cal-iso" - "Move cursor to ISO date." - t) - -(autoload 'calendar-print-iso-date "cal-iso" - "Show the ISO date equivalents of date." - t) - -(autoload 'calendar-iso-date-string "cal-iso" - "String of ISO date of Gregorian date." - t) - -(autoload 'calendar-print-islamic-date "cal-islam" - "Show the Islamic date equivalents of date." - t) - -(autoload 'calendar-islamic-date-string "cal-islam" - "String of Islamic date of Gregorian date." - t) - -(autoload 'calendar-goto-hebrew-date "cal-hebrew" - "Move cursor to Hebrew date date." - t) - -(autoload 'calendar-print-hebrew-date "cal-hebrew" - "Show the Hebrew date equivalents of date." - t) - -(autoload 'calendar-hebrew-date-string "cal-hebrew" - "String of Hebrew date of Gregorian date." - t) - -(autoload 'calendar-goto-coptic-date "cal-coptic" - "Move cursor to Coptic date date." - t) - -(autoload 'calendar-print-coptic-date "cal-coptic" - "Show the Coptic date equivalents of date." - t) - -(autoload 'calendar-coptic-date-string "cal-coptic" - "String of Coptic date of Gregorian date." - t) - -(autoload 'calendar-goto-ethiopic-date "cal-coptic" - "Move cursor to Ethiopic date date." - t) - -(autoload 'calendar-print-ethiopic-date "cal-coptic" - "Show the Ethiopic date equivalents of date." - t) - -(autoload 'calendar-ethiopic-date-string "cal-coptic" - "String of Ethiopic date of Gregorian date." - t) - -(autoload 'calendar-goto-persian-date "cal-persia" - "Move cursor to Persian date date." - t) - -(autoload 'calendar-print-persian-date "cal-persia" - "Show the Persian date equivalents of date." - t) - -(autoload 'calendar-persian-date-string "cal-persia" - "String of Persian date of Gregorian date." - 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 'make-diary-entry "diary-lib" - "Insert a diary entry STRING which may be NONMARKING in FILE." - t) - -(autoload 'insert-diary-entry "diary-lib" - "Insert a diary entry for the date indicated by point." - t) - -(autoload 'insert-weekly-diary-entry "diary-lib" - "Insert a weekly diary entry for the day of the week indicated by point." - t) - - -(autoload 'insert-monthly-diary-entry "diary-lib" - "Insert a monthly diary entry for the day of the month indicated by point." - t) - -(autoload 'insert-yearly-diary-entry "diary-lib" - "Insert an annual diary entry for the day of the year indicated by point." - t) - -(autoload 'insert-anniversary-diary-entry "diary-lib" - "Insert an anniversary diary entry for the date indicated by point." - t) - -(autoload 'insert-block-diary-entry "diary-lib" - "Insert a block diary entry for the dates indicated by point and mark." - t) - -(autoload 'insert-cyclic-diary-entry "diary-lib" - "Insert a cyclic diary entry starting at the date indicated by point." - t) - -(autoload 'insert-hebrew-diary-entry "cal-hebrew" - "Insert a diary entry for the Hebrew date corresponding to the date -indicated by point." - t) - -(autoload 'insert-monthly-hebrew-diary-entry "cal-hebrew" - "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 "cal-hebrew" - "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 "cal-islam" - "Insert a diary entry for the Islamic date corresponding to the date -indicated by point." - t) - -(autoload 'insert-monthly-islamic-diary-entry "cal-islam" - "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 "cal-islam" - "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 'cal-tex-cursor-month "cal-tex" - "Make a buffer with LaTeX commands for the month cursor is on. -Optional prefix argument specifies number of months to be produced. -Calendar is condensed onto one page.") - -(autoload 'cal-tex-cursor-month-landscape "cal-tex" - "Make a buffer with LaTeX commands for the month cursor is on. -Optional prefix argument specifies number of months to be produced.") - -(autoload 'cal-tex-cursor-day "cal-tex" - "Make a buffer with LaTeX commands for the day cursor is on.") - -(autoload 'cal-tex-cursor-week "cal-tex" - "Make a buffer with LaTeX commands for a two-page one-week calendar. -It applies to the week that point is in. -Optional prefix argument specifies number of weeks. -Holidays are included if `cal-tex-holidays' is t.") - -(autoload 'cal-tex-cursor-week2 "cal-tex" - "Make a buffer with LaTeX commands for a two-page one-week calendar. -It applies to the week that point is in. -Optional prefix argument specifies number of weeks. -Holidays are included if `cal-tex-holidays' is t.") - -(autoload 'cal-tex-cursor-week-iso "cal-tex" - "Make a buffer with LaTeX commands for a one page ISO-style weekly calendar. -Optional prefix argument specifies number of weeks. -Diary entries are included if `cal-tex-diary' is t. -Holidays are included if `cal-tex-holidays' is t.") - -(autoload 'cal-tex-cursor-week-monday "cal-tex" - "Make a buffer with LaTeX commands for a two-page one-week calendar. -It applies to the week that point is in, and starts on Monday. -Optional prefix argument specifies number of weeks. -Holidays are included if `cal-tex-holidays' is t.") - -(autoload 'cal-tex-cursor-filofax-2week "cal-tex" - "Two-weeks-at-a-glance Filofax style calendar for week indicated by cursor. -Optional prefix argument specifies number of weeks. -Diary entries are included if cal-tex-diary is t. -Holidays are included if `cal-tex-holidays' is t.") - -(autoload 'cal-tex-cursor-filofax-week "cal-tex" - "One-week-at-a-glance Filofax style calendar for week indicated by cursor. -Optional prefix argument specifies number of weeks. -Weeks start on Monday. -Diary entries are included if cal-tex-diary is t. -Holidays are included if `cal-tex-holidays' is t.") - -(autoload 'cal-tex-cursor-year "cal-tex" - "Make a buffer with LaTeX commands for a year's calendar. -Optional prefix argument specifies number of years.") - -(autoload 'cal-tex-cursor-year-landscape "cal-tex" - "Make a buffer with LaTeX commands for a year's calendar (landscape). -Optional prefix argument specifies number of years.") - -(autoload 'cal-tex-cursor-filofax-year "cal-tex" - "Make a buffer with LaTeX commands for a year's calendar (Filofax). -Optional prefix argument specifies number of years.") - -(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) 3) (1- (point)) - 'mouse-face 'highlight) - (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)) - (if window-system (require 'cal-menu)) - (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 global-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 "\ev" '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 "\e{" '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 "\e}" '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 "\ea" 'calendar-beginning-of-month) - (define-key calendar-mode-map "\ee" 'calendar-end-of-month) - (define-key calendar-mode-map "\e<" 'calendar-beginning-of-year) - (define-key calendar-mode-map "\e>" '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 "\e=" '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-chinese-date) - (define-key calendar-mode-map "gk" 'calendar-goto-coptic-date) - (define-key calendar-mode-map "ge" 'calendar-goto-ethiopic-date) - (define-key calendar-mode-map "gp" 'calendar-goto-persian-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-chinese-date) - (define-key calendar-mode-map "pk" 'calendar-print-coptic-date) - (define-key calendar-mode-map "pe" 'calendar-print-ethiopic-date) - (define-key calendar-mode-map "pp" 'calendar-print-persian-date) - (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) - (define-key calendar-mode-map "tm" 'cal-tex-cursor-month) - (define-key calendar-mode-map "tM" 'cal-tex-cursor-month-landscape) - (define-key calendar-mode-map "td" 'cal-tex-cursor-day) - (define-key calendar-mode-map "tw1" 'cal-tex-cursor-week) - (define-key calendar-mode-map "tw2" 'cal-tex-cursor-week2) - (define-key calendar-mode-map "tw3" 'cal-tex-cursor-week-iso) - (define-key calendar-mode-map "tw4" 'cal-tex-cursor-week-monday) - (define-key calendar-mode-map "tfw" 'cal-tex-cursor-filofax-2week) - (define-key calendar-mode-map "tfW" 'cal-tex-cursor-filofax-week) - (define-key calendar-mode-map "tfy" 'cal-tex-cursor-filofax-year) - (define-key calendar-mode-map "ty" 'cal-tex-cursor-year) - (define-key calendar-mode-map "tY" 'cal-tex-cursor-year-landscape)) - -(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 (save-window-excursion - (Info-find-emacs-command-nodes 'calendar)))) - (if (not where) - (error "Couldn't find documentation for the calendar.") - (let (same-window-buffer-names) - (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) - (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. -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 - (if (< (length strings) 2) - (append (list "") strings (list "")) - 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-current-date () - "Returns the current date in a list (month day year)." - (let ((now (decode-time))) - (list (nth 4 now) (nth 3 now) (nth 5 now)))) - -(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." - (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]?[0-9][^0-9]") - (< 2 (count-lines (point-min) (point)))) - (save-excursion - (if (not (looking-at " ")) - (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!")))))) - -;; 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-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-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)) - (overlay-put - (make-overlay (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-set-mode-line (str) - "Set mode line to STR, centered, surrounded by dashes." - (setq mode-line-format - (calendar-string-spread (list str) ?- (frame-width)))) - -(defun calendar-mod (m n) - "Non-negative remainder of M/N with N instead of 0." - (1+ (mod (1- m) n))) - -(run-hooks 'calendar-load-hook) - -(provide 'calendar) - -;;; Local variables: -;;; byte-compile-dynamic: t -;;; End: - -;;; calendar.el ends here diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el deleted file mode 100644 index 875cc2ae840..00000000000 --- a/lisp/calendar/diary-lib.el +++ /dev/null @@ -1,1392 +0,0 @@ -;;; diary-lib.el --- diary functions. - -;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995 Free Software -;; Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the diary features as described -;; in calendar.el. - -;; 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 - -;;; Code: - -(require 'calendar) - -;;;###autoload -(defun diary (&optional arg) - "Generate the diary window for ARG days starting with the current date. -If no argument is provided, the number of days of diary entries is governed -by the variable `number-of-diary-entries'. This function is suitable for -execution in a `.emacs' file." - (interactive "P") - (let ((d-file (substitute-in-file-name diary-file)) - (date (calendar-current-date))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (list-diary-entries - date - (cond - (arg (prefix-numeric-value arg)) - ((vectorp number-of-diary-entries) - (aref number-of-diary-entries (calendar-day-of-week date))) - (t number-of-diary-entries))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun view-diary-entries (arg) - "Prepare and display a buffer with diary entries. -Searches the file named in `diary-file' for entries that -match ARG days starting with the date indicated by the cursor position -in the displayed three-month calendar." - (interactive "p") - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (list-diary-entries (calendar-cursor-to-date t) arg) - (error "Diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun view-other-diary-entries (arg diary-file) - "Prepare and display buffer of diary entries from an alternative diary file. -Prompts for a file name and searches that file for entries that match ARG -days starting with the date indicated by the cursor position in the displayed -three-month calendar." - (interactive - (list (cond ((null current-prefix-arg) 1) - ((listp current-prefix-arg) (car current-prefix-arg)) - (t current-prefix-arg)) - (setq diary-file (read-file-name "Enter diary file name: " - default-directory nil t)))) - (view-diary-entries arg)) - -(autoload 'check-calendar-holidays "holidays" - "Check the list of holidays for any that occur on DATE. -The value returned is a list of strings of relevant holiday descriptions. -The holidays are those in the list `calendar-holidays'." - t) - -(autoload 'calendar-holiday-list "holidays" - "Form the list of holidays that occur on dates in the calendar window. -The holidays are those in the list `calendar-holidays'." - t) - -(autoload 'diary-french-date "cal-french" - "French calendar equivalent of date diary entry." - t) - -(autoload 'diary-mayan-date "cal-mayan" - "Mayan calendar equivalent of date diary entry." - t) - -(autoload 'diary-iso-date "cal-iso" - "ISO calendar equivalent of date diary entry." - t) - -(autoload 'diary-julian-date "cal-julian" - "Julian calendar equivalent of date diary entry." - t) - -(autoload 'diary-astro-day-number "cal-julian" - "Astronomical (Julian) day number diary entry." - t) - -(autoload 'diary-chinese-date "cal-china" - "Chinese calendar equivalent of date diary entry." - t) - -(autoload 'diary-islamic-date "cal-islam" - "Islamic calendar equivalent of date diary entry." - t) - -(autoload 'list-islamic-diary-entries "cal-islam" - "Add any Islamic date entries from the diary file to `diary-entries-list'." - t) - -(autoload 'mark-islamic-diary-entries "cal-islam" - "Mark days in the calendar window that have Islamic date diary entries." - t) - -(autoload 'mark-islamic-calendar-date-pattern "cal-islam" - "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR." - t) - -(autoload 'diary-hebrew-date "cal-hebrew" - "Hebrew calendar equivalent of date diary entry." - t) - -(autoload 'diary-omer "cal-hebrew" - "Omer count diary entry." - t) - -(autoload 'diary-yahrzeit "cal-hebrew" - "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before." - t) - -(autoload 'diary-parasha "cal-hebrew" - "Parasha diary entry--entry applies if date is a Saturday." - t) - -(autoload 'diary-rosh-hodesh "cal-hebrew" - "Rosh Hodesh diary entry." - t) - -(autoload 'list-hebrew-diary-entries "cal-hebrew" - "Add any Hebrew date entries from the diary file to `diary-entries-list'." - t) - -(autoload 'mark-hebrew-diary-entries "cal-hebrew" - "Mark days in the calendar window that have Hebrew date diary entries." - t) - -(autoload 'mark-hebrew-calendar-date-pattern "cal-hebrew" - "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR." - t) - -(autoload 'diary-coptic-date "cal-coptic" - "Coptic calendar equivalent of date diary entry." - t) - -(autoload 'diary-ethiopic-date "cal-coptic" - "Ethiopic calendar equivalent of date diary entry." - t) - -(autoload 'diary-persian-date "cal-persia" - "Persian calendar equivalent of date diary entry." - t) - -(autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t) - -(autoload 'diary-sunrise-sunset "solar" - "Local time of sunrise and sunset as a diary entry." - t) - -(autoload 'diary-sabbath-candles "solar" - "Local time of candle lighting diary entry--applies if date is a Friday. -No diary entry if there is no sunset on that date." - t) - -(defvar diary-syntax-table (copy-syntax-table (standard-syntax-table)) - "The syntax table used when parsing dates in the diary file. -It is the standard syntax table used in Fundamental mode, but with the -syntax of `*' changed to be a word constituent.") - -(modify-syntax-entry ?* "w" diary-syntax-table) - -(defun list-diary-entries (date number) - "Create and display a buffer containing the relevant lines in diary-file. -The arguments are DATE and NUMBER; the entries selected are those -for NUMBER days starting with date DATE. The other entries are hidden -using selective display. - -Returns a list of all relevant diary entries found, if any, in order by date. -The list entries have the form ((month day year) string). If the variable -`diary-list-include-blanks' is t, this list includes a dummy diary entry -\(consisting of the empty string) for a date with no diary entries. - -After the list is prepared, the hooks `nongregorian-diary-listing-hook', -`list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run. -These hooks have the following distinct roles: - - `nongregorian-diary-listing-hook' can cull dates from the diary - and each included file. Usually used for Hebrew or Islamic - diary entries in files. Applied to *each* file. - - `list-diary-entries-hook' adds or manipulates diary entries from - external sources. Used, for example, to include diary entries - from other files or to sort the diary entries. Invoked *once* only, - before the display hook is run. - - `diary-display-hook' does the actual display of information. If this is - nil, simple-diary-display will be used. Use add-hook to set this to - fancy-diary-display, if desired. If you want no diary display, use - add-hook to set this to ignore. - - `diary-hook' is run last. This can be used for an appointment - notification function." - - (if (< 0 number) - (let* ((original-date date);; save for possible use in the hooks - (old-diary-syntax-table) - (diary-entries-list) - (date-string (calendar-date-string date)) - (d-file (substitute-in-file-name diary-file))) - (message "Preparing diary...") - (save-excursion - (let ((diary-buffer (find-buffer-visiting d-file))) - (if (not diary-buffer) - (set-buffer (find-file-noselect d-file t)) - (set-buffer diary-buffer) - (or (verify-visited-file-modtime diary-buffer) - (revert-buffer t t)))) - (setq selective-display t) - (setq selective-display-ellipses nil) - (setq old-diary-syntax-table (syntax-table)) - (set-syntax-table diary-syntax-table) - (unwind-protect - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p)) - (mark (regexp-quote diary-nonmarking-symbol))) - (goto-char (1- (point-max))) - (if (not (looking-at "\^M\\|\n")) - (progn - (forward-char 1) - (insert-string "\^M"))) - (goto-char (point-min)) - (if (not (looking-at "\^M\\|\n")) - (insert-string "\^M")) - (subst-char-in-region (point-min) (point-max) ?\n ?\^M t) - (calendar-for-loop i from 1 to number do - (let ((d diary-date-forms) - (month (extract-calendar-month date)) - (day (extract-calendar-day date)) - (year (extract-calendar-year date)) - (entry-found (list-sexp-diary-entries date))) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d))) - (backup (equal (car (car d)) 'backup)) - (dayname - (concat - (calendar-day-name date) "\\|" - (substring (calendar-day-name date) 0 3) ".?")) - (monthname - (concat - "\\*\\|" - (calendar-month-name month) "\\|" - (substring (calendar-month-name month) 0 3) ".?")) - (month (concat "\\*\\|0*" (int-to-string month))) - (day (concat "\\*\\|0*" (int-to-string day))) - (year - (concat - "\\*\\|0*" (int-to-string year) - (if abbreviated-calendar-year - (concat "\\|" (int-to-string (% year 100))) - ""))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)" mark "?\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (if backup (re-search-backward "\\<" nil t)) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - ;; Diary entry that consists only of date. - (backward-char 1) - ;; Found a nonempty diary entry--make it visible and - ;; add it to the list. - (setq entry-found t) - (let ((entry-start (point)) - (date-start)) - (re-search-backward "\^M\\|\n\\|\\`") - (setq date-start (point)) - (re-search-forward "\^M\\|\n" nil t 2) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (subst-char-in-region date-start - (point) ?\^M ?\n t) - (add-to-diary-list - date - (buffer-substring-no-properties - entry-start (point))))))) - (setq d (cdr d))) - (or entry-found - (not diary-list-include-blanks) - (setq diary-entries-list - (append diary-entries-list - (list (list date ""))))) - (setq date - (calendar-gregorian-from-absolute - (1+ (calendar-absolute-from-gregorian date)))) - (setq entry-found nil))) - (set-buffer-modified-p diary-modified)) - (set-syntax-table old-diary-syntax-table)) - (goto-char (point-min)) - (run-hooks 'nongregorian-diary-listing-hook - 'list-diary-entries-hook) - (if diary-display-hook - (run-hooks 'diary-display-hook) - (simple-diary-display)) - (run-hooks 'diary-hook) - diary-entries-list)))) - -(defun include-other-diary-files () - "Include the diary entries from other diary files with those of diary-file. -This function is suitable for use in `list-diary-entries-hook'; -it enables you to use shared diary files together with your own. -The files included are specified in the diaryfile by lines of this form: - #include \"filename\" -This is recursive; that is, #include directives in diary files thus included -are obeyed. You can change the `#include' to some other string by -changing the variable `diary-include-string'." - (goto-char (point-min)) - (while (re-search-forward - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote diary-include-string) - " \"\\([^\"]*\\)\"") - nil t) - (let ((diary-file (substitute-in-file-name - (buffer-substring-no-properties - (match-beginning 2) (match-end 2)))) - (diary-list-include-blanks nil) - (list-diary-entries-hook 'include-other-diary-files) - (diary-display-hook 'ignore) - (diary-hook nil)) - (if (file-exists-p diary-file) - (if (file-readable-p diary-file) - (unwind-protect - (setq diary-entries-list - (append diary-entries-list - (list-diary-entries original-date number))) - (kill-buffer (find-buffer-visiting diary-file))) - (beep) - (message "Can't read included diary file %s" diary-file) - (sleep-for 2)) - (beep) - (message "Can't find included diary file %s" diary-file) - (sleep-for 2)))) - (goto-char (point-min))) - -(defun simple-diary-display () - "Display the diary buffer if there are any relevant entries or holidays." - (let* ((holiday-list (if holidays-in-diary-buffer - (check-calendar-holidays original-date))) - (msg (format "No diary entries for %s %s" - (concat date-string (if holiday-list ":" "")) - (mapconcat 'identity holiday-list "; ")))) - (if (or (not diary-entries-list) - (and (not (cdr diary-entries-list)) - (string-equal (car (cdr (car diary-entries-list))) ""))) - (if (<= (length msg) (frame-width)) - (message "%s" msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "No diary entries for %s" date-string)) - (calendar-set-mode-line - (concat "Diary for " date-string - (if holiday-list ": " "") - (mapconcat 'identity holiday-list "; "))) - (display-buffer (find-buffer-visiting d-file)) - (message "Preparing diary...done")))) - -(defun fancy-diary-display () - "Prepare a diary buffer with relevant entries in a fancy, noneditable form. -This function is provided for optional use as the `diary-display-hook'." - (save-excursion;; Turn off selective-display in the diary file's buffer. - (set-buffer (find-buffer-visiting (substitute-in-file-name diary-file))) - (let ((diary-modified (buffer-modified-p))) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) - (setq selective-display nil) - (kill-local-variable 'mode-line-format) - (set-buffer-modified-p diary-modified))) - (if (or (not diary-entries-list) - (and (not (cdr diary-entries-list)) - (string-equal (car (cdr (car diary-entries-list))) ""))) - (let* ((holiday-list (if holidays-in-diary-buffer - (check-calendar-holidays original-date))) - (msg (format "No diary entries for %s %s" - (concat date-string (if holiday-list ":" "")) - (mapconcat 'identity holiday-list "; ")))) - (if (<= (length msg) (frame-width)) - (message "%s" msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "No diary entries for %s" date-string))) - (save-excursion;; Prepare the fancy diary buffer. - (set-buffer (make-fancy-diary-buffer)) - (setq buffer-read-only nil) - (let ((entry-list diary-entries-list) - (holiday-list) - (holiday-list-last-month 1) - (holiday-list-last-year 1) - (date (list 0 0 0))) - (while entry-list - (if (not (calendar-date-equal date (car (car entry-list)))) - (progn - (setq date (car (car entry-list))) - (and holidays-in-diary-buffer - (calendar-date-compare - (list (list holiday-list-last-month - (calendar-last-day-of-month - holiday-list-last-month - holiday-list-last-year) - holiday-list-last-year)) - (list date)) - ;; We need to get the holidays for the next 3 months. - (setq holiday-list-last-month - (extract-calendar-month date)) - (setq holiday-list-last-year - (extract-calendar-year date)) - (increment-calendar-month - holiday-list-last-month holiday-list-last-year 1) - (setq holiday-list - (let ((displayed-month holiday-list-last-month) - (displayed-year holiday-list-last-year)) - (calendar-holiday-list))) - (increment-calendar-month - holiday-list-last-month holiday-list-last-year 1)) - (let* ((date-string (calendar-date-string date)) - (date-holiday-list - (let ((h holiday-list) - (d)) - ;; Make a list of all holidays for date. - (while h - (if (calendar-date-equal date (car (car h))) - (setq d (append d (cdr (car h))))) - (setq h (cdr h))) - d))) - (insert (if (= (point) (point-min)) "" ?\n) date-string) - (if date-holiday-list (insert ": ")) - (let* ((l (current-column)) - (longest 0)) - (insert (mapconcat '(lambda (x) - (if (< longest (length x)) - (setq longest (length x))) - x) - date-holiday-list - (concat "\n" (make-string l ? )))) - (insert ?\n (make-string (+ l longest) ?=) ?\n))))) - (if (< 0 (length (car (cdr (car entry-list))))) - (insert (car (cdr (car entry-list))) ?\n)) - (setq entry-list (cdr entry-list)))) - (set-buffer-modified-p nil) - (goto-char (point-min)) - (setq buffer-read-only t) - (display-buffer fancy-diary-buffer) - (message "Preparing diary...done")))) - -(defun make-fancy-diary-buffer () - "Create and return the initial fancy diary buffer." - (save-excursion - (set-buffer (get-buffer-create fancy-diary-buffer)) - (setq buffer-read-only nil) - (make-local-variable 'mode-line-format) - (calendar-set-mode-line "Diary Entries") - (erase-buffer) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (get-buffer fancy-diary-buffer))) - -(defun print-diary-entries () - "Print a hard copy of the diary display. - -If the simple diary display is being used, prepare a temp buffer with the -visible lines of the diary buffer, add a heading line composed from the mode -line, print the temp buffer, and destroy it. - -If the fancy diary display is being used, just print the buffer. - -The hooks given by the variable `print-diary-entries-hook' are called to do -the actual printing." - (interactive) - (if (bufferp (get-buffer fancy-diary-buffer)) - (save-excursion - (set-buffer (get-buffer fancy-diary-buffer)) - (run-hooks 'print-diary-entries-hook)) - (let ((diary-buffer - (find-buffer-visiting (substitute-in-file-name diary-file)))) - (if diary-buffer - (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*")) - (heading)) - (save-excursion - (set-buffer diary-buffer) - (setq heading - (if (not (stringp mode-line-format)) - "All Diary Entries" - (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format) - (substring mode-line-format - (match-beginning 1) (match-end 1)))) - (copy-to-buffer temp-buffer (point-min) (point-max)) - (set-buffer temp-buffer) - (while (re-search-forward "\^M.*$" nil t) - (replace-match "")) - (goto-char (point-min)) - (insert heading "\n" - (make-string (length heading) ?=) "\n") - (run-hooks 'print-diary-entries-hook) - (kill-buffer temp-buffer))) - (error "You don't have a diary buffer!"))))) - -(defun show-all-diary-entries () - "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." - (interactive) - (let ((d-file (substitute-in-file-name diary-file))) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (save-excursion - (let ((diary-buffer (find-buffer-visiting d-file))) - (set-buffer (if diary-buffer - diary-buffer - (find-file-noselect d-file t))) - (let ((buffer-read-only nil) - (diary-modified (buffer-modified-p))) - (subst-char-in-region (point-min) (point-max) ?\^M ?\n t) - (setq selective-display nil) - (make-local-variable 'mode-line-format) - (setq mode-line-format default-mode-line-format) - (display-buffer (current-buffer)) - (set-buffer-modified-p diary-modified)))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun diary-name-pattern (string-array &optional fullname) - "Convert an STRING-ARRAY, an array of strings to a pattern. -The pattern will match any of the strings, either entirely or abbreviated -to three characters. An abbreviated form will match with or without a period; -If the optional FULLNAME is t, abbreviations will not match, just the full -name." - (let ((pattern "")) - (calendar-for-loop i from 0 to (1- (length string-array)) do - (setq pattern - (concat - pattern - (if (string-equal pattern "") "" "\\|") - (aref string-array i) - (if fullname - "" - (concat - "\\|" - (substring (aref string-array i) 0 3) ".?"))))) - pattern)) - -(defvar marking-diary-entries nil - "True during the marking of diary entries, nil otherwise.") - -(defvar marking-diary-entry nil - "True during the marking of diary entries, if current entry is marking.") - -(defun mark-diary-entries () - "Mark days in the calendar window that have diary entries. -Each entry in the diary file visible in the calendar window is marked. -After the entries are marked, the hooks `nongregorian-diary-marking-hook' and -`mark-diary-entries-hook' are run." - (interactive) - (setq mark-diary-entries-in-calendar t) - (let ((d-file (substitute-in-file-name diary-file)) - (marking-diary-entries t)) - (if (and d-file (file-exists-p d-file)) - (if (file-readable-p d-file) - (save-excursion - (message "Marking diary entries...") - (set-buffer (find-file-noselect d-file t)) - (let ((d diary-date-forms) - (old-diary-syntax-table)) - (setq old-diary-syntax-table (syntax-table)) - (set-syntax-table diary-syntax-table) - (while d - (let* - ((date-form (if (equal (car (car d)) 'backup) - (cdr (car d)) - (car d)));; ignore 'backup directive - (dayname (diary-name-pattern calendar-day-name-array)) - (monthname - (concat - (diary-name-pattern calendar-month-name-array) - "\\|\\*")) - (month "[0-9]+\\|\\*") - (day "[0-9]+\\|\\*") - (year "[0-9]+\\|\\*") - (l (length date-form)) - (d-name-pos (- l (length (memq 'dayname date-form)))) - (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos))) - (m-name-pos (- l (length (memq 'monthname date-form)))) - (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos))) - (d-pos (- l (length (memq 'day date-form)))) - (d-pos (if (/= l d-pos) (+ 2 d-pos))) - (m-pos (- l (length (memq 'month date-form)))) - (m-pos (if (/= l m-pos) (+ 2 m-pos))) - (y-pos (- l (length (memq 'year date-form)))) - (y-pos (if (/= l y-pos) (+ 2 y-pos))) - (regexp - (concat - "\\(\\`\\|\^M\\|\n\\)\\(" - (mapconcat 'eval date-form "\\)\\(") - "\\)")) - (case-fold-search t)) - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (let* ((dd-name - (if d-name-pos - (buffer-substring-no-properties - (match-beginning d-name-pos) - (match-end d-name-pos)))) - (mm-name - (if m-name-pos - (buffer-substring-no-properties - (match-beginning m-name-pos) - (match-end m-name-pos)))) - (mm (string-to-int - (if m-pos - (buffer-substring-no-properties - (match-beginning m-pos) - (match-end m-pos)) - ""))) - (dd (string-to-int - (if d-pos - (buffer-substring-no-properties - (match-beginning d-pos) - (match-end d-pos)) - ""))) - (y-str (if y-pos - (buffer-substring-no-properties - (match-beginning y-pos) - (match-end y-pos)))) - (yy (if (not y-str) - 0 - (if (and (= (length y-str) 2) - abbreviated-calendar-year) - (let* ((current-y - (extract-calendar-year - (calendar-current-date))) - (y (+ (string-to-int y-str) - (* 100 - (/ current-y 100))))) - (if (> (- y current-y) 50) - (- y 100) - (if (> (- current-y y) 50) - (+ y 100) - y))) - (string-to-int y-str))))) - (if dd-name - (mark-calendar-days-named - (cdr (assoc (capitalize (substring dd-name 0 3)) - (calendar-make-alist - calendar-day-name-array - 0 - '(lambda (x) (substring x 0 3)))))) - (if mm-name - (if (string-equal mm-name "*") - (setq mm 0) - (setq mm - (cdr (assoc - (capitalize - (substring mm-name 0 3)) - (calendar-make-alist - calendar-month-name-array - 1 - '(lambda (x) (substring x 0 3))) - ))))) - (mark-calendar-date-pattern mm dd yy)))) - (setq d (cdr d)))) - (mark-sexp-diary-entries) - (run-hooks 'nongregorian-diary-marking-hook - 'mark-diary-entries-hook) - (set-syntax-table old-diary-syntax-table) - (message "Marking diary entries...done"))) - (error "Your diary file is not readable!")) - (error "You don't have a diary file!")))) - -(defun mark-sexp-diary-entries () - "Mark days in the calendar window that have sexp diary entries. -Each entry in the diary file (or included files) visible in the calendar window -is marked. See the documentation for the function `list-sexp-diary-entries'." - (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol)) - (s-entry (concat "\\(\\`\\|\^M\\|\n\\)\\(" - (regexp-quote sexp-mark) "(\\)\\|\\(" - (regexp-quote diary-nonmarking-symbol) - (regexp-quote sexp-mark) "(diary-remind\\)")) - (m) - (y) - (first-date) - (last-date)) - (save-excursion - (set-buffer calendar-buffer) - (setq m displayed-month) - (setq y displayed-year)) - (increment-calendar-month m y -1) - (setq first-date - (calendar-absolute-from-gregorian (list m 1 y))) - (increment-calendar-month m y 2) - (setq last-date - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))) - (goto-char (point-min)) - (while (re-search-forward s-entry nil t) - (if (char-equal (preceding-char) ?\() - (setq marking-diary-entry t) - (setq marking-diary-entry nil)) - (re-search-backward "(") - (let ((sexp-start (point)) - (sexp) - (entry) - (entry-start) - (line-start)) - (forward-sexp) - (setq sexp (buffer-substring-no-properties sexp-start (point))) - (save-excursion - (re-search-backward "\^M\\|\n\\|\\`") - (setq line-start (point))) - (forward-char 1) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - (progn;; Diary entry consists only of the sexp - (backward-char 1) - (setq entry "")) - (setq entry-start (point)) - (re-search-forward "\^M\\|\n" nil t) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (setq entry (buffer-substring-no-properties entry-start (point))) - (while (string-match "[\^M]" entry) - (aset entry (match-beginning 0) ?\n ))) - (calendar-for-loop date from first-date to last-date do - (if (diary-sexp-entry sexp entry - (calendar-gregorian-from-absolute date)) - (mark-visible-calendar-date - (calendar-gregorian-from-absolute date)))))))) - -(defun mark-included-diary-files () - "Mark the diary entries from other diary files with those of the diary file. -This function is suitable 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 this form: - #include \"filename\" -This is recursive; that is, #include directives in diary files thus included -are obeyed. You can change the `#include' to some other string by -changing the variable `diary-include-string'." - (goto-char (point-min)) - (while (re-search-forward - (concat - "\\(\\`\\|\^M\\|\n\\)" - (regexp-quote diary-include-string) - " \"\\([^\"]*\\)\"") - nil t) - (let ((diary-file (substitute-in-file-name - (buffer-substring-no-properties - (match-beginning 2) (match-end 2)))) - (mark-diary-entries-hook 'mark-included-diary-files)) - (if (file-exists-p diary-file) - (if (file-readable-p diary-file) - (progn - (mark-diary-entries) - (kill-buffer (find-buffer-visiting diary-file))) - (beep) - (message "Can't read included diary file %s" diary-file) - (sleep-for 2)) - (beep) - (message "Can't find included diary file %s" diary-file) - (sleep-for 2)))) - (goto-char (point-min))) - -(defun mark-calendar-days-named (dayname) - "Mark all dates in the calendar window that are day DAYNAME of the week. -0 means all Sundays, 1 means all Mondays, and so on." - (save-excursion - (set-buffer calendar-buffer) - (let ((prev-month displayed-month) - (prev-year displayed-year) - (succ-month displayed-month) - (succ-year displayed-year) - (last-day) - (day)) - (increment-calendar-month succ-month succ-year 1) - (increment-calendar-month prev-month prev-year -1) - (setq day (calendar-absolute-from-gregorian - (calendar-nth-named-day 1 dayname prev-month prev-year))) - (setq last-day (calendar-absolute-from-gregorian - (calendar-nth-named-day -1 dayname succ-month succ-year))) - (while (<= day last-day) - (mark-visible-calendar-date (calendar-gregorian-from-absolute day)) - (setq day (+ day 7)))))) - -(defun mark-calendar-date-pattern (month day year) - "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR. -A value of 0 in any position is a wildcard." - (save-excursion - (set-buffer calendar-buffer) - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y -1) - (calendar-for-loop i from 0 to 2 do - (mark-calendar-month m y month day year) - (increment-calendar-month m y 1))))) - -(defun mark-calendar-month (month year p-month p-day p-year) - "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR. -A value of 0 in any position of the pattern is a wildcard." - (if (or (and (= month p-month) - (or (= p-year 0) (= year p-year))) - (and (= p-month 0) - (or (= p-year 0) (= year p-year)))) - (if (= p-day 0) - (calendar-for-loop - i from 1 to (calendar-last-day-of-month month year) do - (mark-visible-calendar-date (list month i year))) - (mark-visible-calendar-date (list month p-day year))))) - -(defun sort-diary-entries () - "Sort the list of diary entries by time of day." - (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare))) - -(defun diary-entry-compare (e1 e2) - "Returns t if E1 is earlier than E2." - (or (calendar-date-compare e1 e2) - (and (calendar-date-equal (car e1) (car e2)) - (< (diary-entry-time (car (cdr e1))) - (diary-entry-time (car (cdr e2))))))) - -(defun diary-entry-time (s) - "Time at the beginning of the string S in a military-style integer. -For example, returns 1325 for 1:25pm. Returns -9999 if no time is recognized. -The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm, -and XX:XXam or XX:XXpm." - (cond ((string-match;; Military time - "^[ \t]*\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s) - (+ (* 100 (string-to-int - (substring s (match-beginning 1) (match-end 1)))) - (string-to-int (substring s (match-beginning 2) (match-end 2))))) - ((string-match;; Hour only XXam or XXpm - "^[ \t]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s) - (+ (* 100 (% (string-to-int - (substring s (match-beginning 1) (match-end 1))) - 12)) - (if (string-equal "a" - (substring s (match-beginning 2) (match-end 2))) - 0 1200))) - ((string-match;; Hour and minute XX:XXam or XX:XXpm - "^[ \t]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s) - (+ (* 100 (% (string-to-int - (substring s (match-beginning 1) (match-end 1))) - 12)) - (string-to-int (substring s (match-beginning 2) (match-end 2))) - (if (string-equal "a" - (substring s (match-beginning 3) (match-end 3))) - 0 1200))) - (t -9999)));; Unrecognizable - -(defun list-sexp-diary-entries (date) - "Add sexp entries for DATE from the diary file to `diary-entries-list'. -Also, Make them visible in the diary file. Returns t if any entries were -found. - -Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally -`%%'). The form of a sexp diary entry is - - %%(SEXP) ENTRY - -Both ENTRY and DATE are globally available when the SEXP is evaluated. If the -SEXP yields the value nil, the diary entry does not apply. If it yields a -non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a -string, that string will be the diary entry in the fancy diary display. - -For example, the following diary entry will apply to the 21st of the month -if it is a weekday and the Friday before if the 21st is on a weekend: - - &%%(let ((dayname (calendar-day-of-week date)) - (day (extract-calendar-day date))) - (or - (and (= day 21) (memq dayname '(1 2 3 4 5))) - (and (memq day '(19 20)) (= dayname 5))) - ) UIUC pay checks deposited - -A number of built-in functions are available for this type of diary entry: - - %%(diary-date MONTH DAY YEAR) text - Entry applies if date is MONTH, DAY, YEAR if - `european-calendar-style' is nil, and DAY, MONTH, YEAR if - `european-calendar-style' is t. DAY, MONTH, and YEAR - can be lists of integers, the constant t, or an integer. - The constant t means all values. - - %%(diary-float MONTH DAYNAME N) text - Entry will appear on the Nth DAYNAME of MONTH. - (DAYNAME=0 means Sunday, 1 means Monday, and so on; - if N is negative it counts backward from the end of - the month. MONTH can be a list of months, a single - month, or t to specify all months. - - %%(diary-block M1 D1 Y1 M2 D2 Y2) text - Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2, - inclusive. (If `european-calendar-style' is t, the - order of the parameters should be changed to D1, M1, Y1, - D2, M2, Y2.) - - %%(diary-anniversary MONTH DAY YEAR) text - Entry will appear on anniversary dates of MONTH DAY, YEAR. - (If `european-calendar-style' is t, the order of the - parameters should be changed to DAY, MONTH, YEAR.) Text - can contain %d or %d%s; %d will be replaced by the number - of years since the MONTH DAY, YEAR and %s will be replaced - by the ordinal ending of that number (that is, `st', `nd', - `rd' or `th', as appropriate. The anniversary of February - 29 is considered to be March 1 in a non-leap year. - - %%(diary-cyclic N MONTH DAY YEAR) text - Entry will appear every N days, starting MONTH DAY, YEAR. - (If `european-calendar-style' is t, the order of the - parameters should be changed to N, DAY, MONTH, YEAR.) Text - can contain %d or %d%s; %d will be replaced by the number - of repetitions since the MONTH DAY, YEAR and %s will - be replaced by the ordinal ending of that number (that is, - `st', `nd', `rd' or `th', as appropriate. - - %%(diary-remind SEXP DAYS &optional MARKING) text - Entry is a reminder for diary sexp SEXP. DAYS is either a - single number or a list of numbers indicating the number(s) - of days before the event that the warning(s) should occur. - If the current date is (one of) DAYS before the event - indicated by EXPR, then a suitable message (as specified - by `diary-remind-message') appears. In addition to the - reminders beforehand, the diary entry also appears on - the date itself. If optional MARKING is non-nil then the - *reminders* are marked on the calendar. Marking of - reminders is independent of whether the entry *itself* is - a marking or nonmarking one. - - %%(diary-day-of-year) - Diary entries giving the day of the year and the number of - days remaining in the year will be made every day. Note - that since there is no text, it makes sense only if the - fancy diary display is used. - - %%(diary-iso-date) - Diary entries giving the corresponding ISO commercial date - will be made every day. Note that since there is no text, - it makes sense only if the fancy diary display is used. - - %%(diary-french-date) - Diary entries giving the corresponding French Revolutionary - date will be made every day. Note that since there is no - text, it makes sense only if the fancy diary display is used. - - %%(diary-islamic-date) - Diary entries giving the corresponding Islamic date will be - made every day. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-hebrew-date) - Diary entries giving the corresponding Hebrew date will be - made every day. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-astro-day-number) Diary entries giving the corresponding - astronomical (Julian) day number will be made every day. - Note that since there is no text, it makes sense only if the - fancy diary display is used. - - %%(diary-julian-date) Diary entries giving the corresponding - Julian date will be made every day. Note that since - there is no text, it makes sense only if the fancy diary - display is used. - - %%(diary-sunrise-sunset) - Diary entries giving the local times of sunrise and sunset - will be made every day. Note that since there is no text, - it makes sense only if the fancy diary display is used. - Floating point required. - - %%(diary-phases-of-moon) - Diary entries giving the times of the phases of the moon - will be when appropriate. Note that since there is no text, - it makes sense only if the fancy diary display is used. - Floating point required. - - %%(diary-yahrzeit MONTH DAY YEAR) text - Text is assumed to be the name of the person; the date is - the date of death on the *civil* calendar. The diary entry - will appear on the proper Hebrew-date anniversary and on the - day before. (If `european-calendar-style' is t, the order - of the parameters should be changed to DAY, MONTH, YEAR.) - - %%(diary-rosh-hodesh) - Diary entries will be made on the dates of Rosh Hodesh on - the Hebrew calendar. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-parasha) - Diary entries giving the weekly parasha will be made on - every Saturday. Note that since there is no text, it - makes sense only if the fancy diary display is used. - - %%(diary-omer) - Diary entries giving the omer count will be made every day - from Passover to Shavuot. Note that since there is no text, - it makes sense only if the fancy diary display is used. - -Marking these entries is *extremely* time consuming, so these entries are -best if they are nonmarking." - (let* ((mark (regexp-quote diary-nonmarking-symbol)) - (sexp-mark (regexp-quote sexp-diary-entry-symbol)) - (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "(")) - (entry-found)) - (goto-char (point-min)) - (while (re-search-forward s-entry nil t) - (backward-char 1) - (let ((sexp-start (point)) - (sexp) - (entry) - (entry-start) - (line-start)) - (forward-sexp) - (setq sexp (buffer-substring-no-properties sexp-start (point))) - (save-excursion - (re-search-backward "\^M\\|\n\\|\\`") - (setq line-start (point))) - (forward-char 1) - (if (and (or (char-equal (preceding-char) ?\^M) - (char-equal (preceding-char) ?\n)) - (not (looking-at " \\|\^I"))) - (progn;; Diary entry consists only of the sexp - (backward-char 1) - (setq entry "")) - (setq entry-start (point)) - (re-search-forward "\^M\\|\n" nil t) - (while (looking-at " \\|\^I") - (re-search-forward "\^M\\|\n" nil t)) - (backward-char 1) - (setq entry (buffer-substring-no-properties entry-start (point))) - (while (string-match "[\^M]" entry) - (aset entry (match-beginning 0) ?\n ))) - (let ((diary-entry (diary-sexp-entry sexp entry date))) - (if diary-entry - (subst-char-in-region line-start (point) ?\^M ?\n t)) - (add-to-diary-list date diary-entry) - (setq entry-found (or entry-found diary-entry))))) - entry-found)) - -(defun diary-sexp-entry (sexp entry date) - "Process a SEXP diary ENTRY for DATE." - (let ((result (if calendar-debug-sexp - (let ((stack-trace-on-error t)) - (eval (car (read-from-string sexp)))) - (condition-case nil - (eval (car (read-from-string sexp))) - (error - (beep) - (message "Bad sexp at line %d in %s: %s" - (save-excursion - (save-restriction - (narrow-to-region 1 (point)) - (goto-char (point-min)) - (let ((lines 1)) - (while (re-search-forward "\n\\|\^M" nil t) - (setq lines (1+ lines))) - lines))) - diary-file sexp) - (sleep-for 2)))))) - (if (stringp result) - result - (if result - entry - nil)))) - -(defun diary-date (month day year) - "Specific date(s) diary entry. -Entry applies if date is MONTH, DAY, YEAR if `european-calendar-style' is nil, -and DAY, MONTH, YEAR if `european-calendar-style' is t. DAY, MONTH, and YEAR -can be lists of integers, the constant t, or an integer. The constant t means -all values." - (let* ((dd (if european-calendar-style - month - day)) - (mm (if european-calendar-style - day - month)) - (m (extract-calendar-month date)) - (y (extract-calendar-year date)) - (d (extract-calendar-day date))) - (if (and - (or (and (listp dd) (memq d dd)) - (equal d dd) - (eq dd t)) - (or (and (listp mm) (memq m mm)) - (equal m mm) - (eq mm t)) - (or (and (listp year) (memq y year)) - (equal y year) - (eq year t))) - entry))) - -(defun diary-block (m1 d1 y1 m2 d2 y2) - "Block diary entry. -Entry applies if date is between two dates. Order of the parameters is -M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and -D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t." - (let ((date1 (calendar-absolute-from-gregorian - (if european-calendar-style - (list d1 m1 y1) - (list m1 d1 y1)))) - (date2 (calendar-absolute-from-gregorian - (if european-calendar-style - (list d2 m2 y2) - (list m2 d2 y2)))) - (d (calendar-absolute-from-gregorian date))) - (if (and (<= date1 d) (<= d date2)) - entry))) - -(defun diary-float (month dayname n) - "Floating diary entry--entry applies if date is the nth dayname of month. -Parameters are MONTH, DAYNAME, N. MONTH can be a list of months, the constant -t, or an integer. The constant t means all months. If N is negative, count -backward from the end of the month." - (let ((m (extract-calendar-month date)) - (y (extract-calendar-year date))) - (if (and - (or (and (listp month) (memq m month)) - (equal m month) - (eq month t)) - (calendar-date-equal date (calendar-nth-named-day n dayname m y))) - entry))) - -(defun diary-anniversary (month day year) - "Anniversary diary entry. -Entry applies if date is the anniversary of MONTH, DAY, YEAR if -`european-calendar-style' is nil, and DAY, MONTH, YEAR if -`european-calendar-style' is t. Diary entry can contain `%d' or `%d%s'; the -%d will be replaced by the number of years since the MONTH DAY, YEAR and the -%s will be replaced by the ordinal ending of that number (that is, `st', `nd', -`rd' or `th', as appropriate. The anniversary of February 29 is considered -to be March 1 in non-leap years." - (let* ((d (if european-calendar-style - month - day)) - (m (if european-calendar-style - day - month)) - (y (extract-calendar-year date)) - (diff (- y year))) - (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y))) - (setq m 3 - d 1)) - (if (and (> diff 0) (calendar-date-equal (list m d y) date)) - (format entry diff (diary-ordinal-suffix diff))))) - -(defun diary-cyclic (n month day year) - "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR. -If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR. -ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of -years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal -ending of that number (that is, `st', `nd', `rd' or `th', as appropriate." - (let* ((d (if european-calendar-style - month - day)) - (m (if european-calendar-style - day - month)) - (diff (- (calendar-absolute-from-gregorian date) - (calendar-absolute-from-gregorian - (list m d year)))) - (cycle (/ diff n))) - (if (and (>= diff 0) (zerop (% diff n))) - (format entry cycle (diary-ordinal-suffix cycle))))) - -(defun diary-ordinal-suffix (n) - "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)" - (if (or (memq (% n 100) '(11 12 13)) - (< 3 (% n 10))) - "th" - (aref ["th" "st" "nd" "rd"] (% n 10)))) - -(defun diary-day-of-year () - "Day of year and number of days remaining in the year of date diary entry." - (calendar-day-of-year-string date)) - -(defvar diary-remind-message - '("Reminder: Only " - (if (= 0 (% days 7)) - (concat (int-to-string (/ days 7)) (if (= 7 days) " week" " weeks")) - (concat (int-to-string days) (if (= 1 days) " day" " days"))) - " until " - diary-entry) - "*Pseudo-pattern giving form of reminder messages in the fancy diary -display. - -Used by the function `diary-remind', a pseudo-pattern is a list of -expressions that can involve the keywords `days' (a number), `date' (a list of -month, day, year), and `diary-entry' (a string).") - -(defun diary-remind (sexp days &optional marking) - "Provide a reminder of a diary entry. -SEXP is a diary-sexp. DAYS is either a single number or a list of numbers -indicating the number(s) of days before the event that the warning(s) should -occur on. If the current date is (one of) DAYS before the event indicated by -SEXP, then a suitable message (as specified by `diary-remind-message' is -returned. - -In addition to the reminders beforehand, the diary entry also appears on -the date itself. - -If optional parameter MARKING is non-nil then the reminders are marked on the -calendar. Marking of reminders is independent of whether the entry itself is -a marking or nonmarking one." - (let ((diary-entry)) - (if (or (not marking-diary-entries) marking) - (cond - ((integerp days) - (let ((date (calendar-gregorian-from-absolute - (+ (calendar-absolute-from-gregorian date) days)))) - (if (setq diary-entry (eval sexp)) - (setq diary-entry (mapconcat 'eval diary-remind-message ""))))) - ((and (listp days) days) - (setq diary-entry (diary-remind sexp (car days) marking)) - (if (not diary-entry) - (setq diary-entry (diary-remind sexp (cdr days) marking)))))) - (or diary-entry - (and (or (not marking-diary-entries) marking-diary-entry) - (eval sexp))))) - -(defun add-to-diary-list (date string) - "Add the entry (DATE STRING) to `diary-entries-list'. -Do nothing if DATE or STRING is nil." - (and date string - (setq diary-entries-list - (append diary-entries-list (list (list date string)))))) - -(defun make-diary-entry (string &optional nonmarking file) - "Insert a diary entry STRING which may be NONMARKING in FILE. -If omitted, NONMARKING defaults to nil and FILE defaults to diary-file." - (find-file-other-window - (substitute-in-file-name (if file file diary-file))) - (goto-char (point-max)) - (insert - (if (bolp) "" "\n") - (if nonmarking diary-nonmarking-symbol "") - string " ")) - -(defun insert-diary-entry (arg) - "Insert a diary entry for the date indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t t) - arg)) - -(defun insert-weekly-diary-entry (arg) - "Insert a weekly diary entry for the day of the week indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (make-diary-entry (calendar-day-name (calendar-cursor-to-date t)) - arg)) - -(defun insert-monthly-diary-entry (arg) - "Insert a monthly diary entry for the day of the month indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " * ") - '("* " day)))) - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) - arg))) - -(defun insert-yearly-diary-entry (arg) - "Insert an annual diary entry for the day of the year indicated by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " monthname) - '(monthname " " day)))) - (make-diary-entry (calendar-date-string (calendar-cursor-to-date t) t) - arg))) - -(defun insert-anniversary-diary-entry (arg) - "Insert an anniversary diary entry for the date given by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year)))) - (make-diary-entry - (format "%s(diary-anniversary %s)" - sexp-diary-entry-symbol - (calendar-date-string (calendar-cursor-to-date t) nil t)) - arg))) - -(defun insert-block-diary-entry (arg) - "Insert a block diary entry for the days between the point and marked date. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year))) - (cursor (calendar-cursor-to-date t)) - (mark (or (car calendar-mark-ring) - (error "No mark set in this buffer"))) - (start) - (end)) - (if (< (calendar-absolute-from-gregorian mark) - (calendar-absolute-from-gregorian cursor)) - (setq start mark - end cursor) - (setq start cursor - end mark)) - (make-diary-entry - (format "%s(diary-block %s %s)" - sexp-diary-entry-symbol - (calendar-date-string start nil t) - (calendar-date-string end nil t)) - arg))) - -(defun insert-cyclic-diary-entry (arg) - "Insert a cyclic diary entry starting at the date given by point. -Prefix arg will make the entry nonmarking." - (interactive "P") - (let* ((calendar-date-display-form - (if european-calendar-style - '(day " " month " " year) - '(month " " day " " year)))) - (make-diary-entry - (format "%s(diary-cyclic %d %s)" - sexp-diary-entry-symbol - (calendar-read "Repeat every how many days: " - '(lambda (x) (> x 0))) - (calendar-date-string (calendar-cursor-to-date t) nil t)) - arg))) - -(provide 'diary-lib) - -;;; diary-lib.el ends here diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el deleted file mode 100644 index cb5b3a1d8cb..00000000000 --- a/lisp/calendar/holidays.el +++ /dev/null @@ -1,384 +0,0 @@ -;;; holidays.el --- holiday functions for the calendar package - -;; Copyright (C) 1989, 1990, 1992, 1993, 1994 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: holidays, calendar - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the holiday features as described -;; in calendar.el. - -;; 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 - -;; 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: - -(require 'calendar) - -(autoload 'holiday-julian "cal-julian" - "Holiday on MONTH, DAY (Julian) called STRING." - t) - -(autoload 'holiday-hebrew "cal-hebrew" - "Holiday on MONTH, DAY (Hebrew) called STRING." - t) - -(autoload 'holiday-rosh-hashanah-etc "cal-hebrew" - "List of dates related to Rosh Hashanah, as visible in calendar window." - t) - -(autoload 'holiday-hanukkah "cal-hebrew" - "List of dates related to Hanukkah, as visible in calendar window." - t) - -(autoload 'holiday-passover-etc "cal-hebrew" - "List of dates related to Passover, as visible in calendar window." - t) - -(autoload 'holiday-tisha-b-av-etc "cal-hebrew" - "List of dates around Tisha B'Av, as visible in calendar window." - t) - -(autoload 'holiday-islamic "cal-islam" - "Holiday on MONTH, DAY (Islamic) called STRING." - t) - -(autoload 'holiday-chinese-new-year "cal-china" - "Date of Chinese New Year." - t) - -(autoload 'solar-equinoxes-solstices "solar" - "Date and time of equinoxes and solstices, if visible in the calendar window. -Requires floating point." - t) - -(defun holidays (&optional arg) - "Display the holidays for last month, this month, and next month. -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file." - (interactive "P") - (save-excursion - (let* ((completion-ignore-case t) - (date (if arg - (calendar-read-date t) - (calendar-current-date))) - (displayed-month (extract-calendar-month date)) - (displayed-year (extract-calendar-year date))) - (list-calendar-holidays)))) - -(defun check-calendar-holidays (date) - "Check the list of holidays for any that occur on DATE. -The value returned is a list of strings of relevant holiday descriptions. -The holidays are those in the list calendar-holidays." - (let* ((displayed-month (extract-calendar-month date)) - (displayed-year (extract-calendar-year date)) - (h (calendar-holiday-list)) - (holiday-list)) - (while h - (if (calendar-date-equal date (car (car h))) - (setq holiday-list (append holiday-list (cdr (car h))))) - (setq h (cdr h))) - holiday-list)) - -(defun calendar-cursor-holidays () - "Find holidays for the date specified by the cursor in the calendar window." - (interactive) - (message "Checking holidays...") - (let* ((date (calendar-cursor-to-date t)) - (date-string (calendar-date-string date)) - (holiday-list (check-calendar-holidays date)) - (holiday-string (mapconcat 'identity holiday-list "; ")) - (msg (format "%s: %s" date-string holiday-string))) - (if (not holiday-list) - (message "No holidays known for %s" date-string) - (if (<= (length msg) (frame-width)) - (message "%s" msg) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line date-string) - (erase-buffer) - (insert (mapconcat 'identity holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "Checking holidays...done"))))) - -(defun mark-calendar-holidays () - "Mark notable days in the calendar window." - (interactive) - (setq mark-holidays-in-calendar t) - (message "Marking holidays...") - (let ((holiday-list (calendar-holiday-list))) - (while holiday-list - (mark-visible-calendar-date - (car (car holiday-list)) calendar-holiday-marker) - (setq holiday-list (cdr holiday-list)))) - (message "Marking holidays...done")) - -(defun list-calendar-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." - (interactive) - (message "Looking up holidays...") - (let ((holiday-list (calendar-holiday-list)) - (m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year)) - (if (not holiday-list) - (progn - (message "Looking up holidays...none found") - nil) - (set-buffer (get-buffer-create holiday-buffer)) - (setq buffer-read-only nil) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (calendar-set-mode-line - (if (= y1 y2) - (format "Notable Dates from %s to %s, %d%%-" - (calendar-month-name m1) (calendar-month-name m2) y2) - (format "Notable Dates from %s, %d to %s, %d%%-" - (calendar-month-name m1) y1 (calendar-month-name m2) y2))) - (erase-buffer) - (insert - (mapconcat - '(lambda (x) (concat (calendar-date-string (car x)) - ": " (car (cdr x)))) - holiday-list "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer holiday-buffer) - (message "Looking up holidays...done") - t))) - -(defun calendar-holiday-list () - "Form the list of holidays that occur on dates in the calendar window. -The holidays are those in the list calendar-holidays." - (let ((p calendar-holidays) - (holiday-list)) - (while p - (let* ((holidays - (if calendar-debug-sexp - (let ((stack-trace-on-error t)) - (eval (car p))) - (condition-case nil - (eval (car p)) - (error (beep) - (message "Bad holiday list item: %s" (car p)) - (sleep-for 2)))))) - (if holidays - (setq holiday-list (append holidays holiday-list)))) - (setq p (cdr p))) - (setq holiday-list (sort holiday-list 'calendar-date-compare)))) - -;; Below are the functions that calculate the dates of holidays; these -;; are eval'ed in the function calendar-holiday-list. If you -;; write other such functions, be sure to imitate the style used below. -;; Remember that each function must return a list of items of the form -;; ((month day year) string) of VISIBLE dates in the calendar window. - -(defun holiday-fixed (month day string) - "Holiday on MONTH, DAY (Gregorian) called STRING. -If MONTH, DAY is visible, the value returned is the list (((MONTH DAY year) -STRING)). Returns nil if it is not visible in the current calendar window." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y (- 11 month)) - (if (> m 9) - (list (list (list month day y) string))))) - -(defun holiday-float (month dayname n string &optional day) - "Holiday on MONTH, DAYNAME (Nth occurrence, Gregorian) called STRING. -If the Nth DAYNAME in MONTH is visible, the value returned is the list -\(((MONTH DAY year) STRING)). - -If N<0, count backward from the end of MONTH. - -An optional parameter DAY means the Nth DAYNAME after/before MONTH DAY. - -Returns nil if it is not visible in the current calendar window." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y (- 11 month)) - (if (> m 9) - (list (list (calendar-nth-named-day n dayname month y day) string))))) - -(defun holiday-sexp (sexp string) - "Sexp holiday for dates in the calendar window. -SEXP is an expression in variable `year' evaluates to `date'. - -STRING is an expression in `date' that evaluates to the holiday description -of `date'. - -If `date' is visible in the calendar window, the holiday STRING is on that -date. If date is nil, or if the date is not visible, there is no holiday." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y -1) - (filter-visible-calendar-holidays - (append - (let* ((year y) - (date (eval sexp)) - (string (if date (eval string)))) - (list (list date string))) - (let* ((year (1+ y)) - (date (eval sexp)) - (string (if date (eval string)))) - (list (list date string))))))) - -(defun holiday-advent () - "Date of Advent, if visible in calendar window." - (let ((year displayed-year) - (month displayed-month)) - (increment-calendar-month month year -1) - (let ((advent (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 0 - (calendar-absolute-from-gregorian - (list 12 3 year)))))) - (if (calendar-date-is-visible-p advent) - (list (list advent "Advent")))))) - -(defun holiday-easter-etc () - "List of dates related to Easter, as visible in calendar window." - (if (and (> displayed-month 5) (not all-christian-calendar-holidays)) - nil;; Ash Wednesday, Good Friday, and Easter are not visible. - (let* ((century (1+ (/ displayed-year 100))) - (shifted-epact ;; Age of moon for April 5... - (% (+ 14 (* 11 (% displayed-year 19));; ...by Nicaean rule - (- ;; ...corrected for the Gregorian century rule - (/ (* 3 century) 4)) - (/ ;; ...corrected for Metonic cycle inaccuracy. - (+ 5 (* 8 century)) 25) - (* 30 century));; Keeps value positive. - 30)) - (adjusted-epact ;; Adjust for 29.5 day month. - (if (or (= shifted-epact 0) - (and (= shifted-epact 1) (< 10 (% displayed-year 19)))) - (1+ shifted-epact) - shifted-epact)) - (paschal-moon ;; Day after the full moon on or after March 21. - (- (calendar-absolute-from-gregorian (list 4 19 displayed-year)) - adjusted-epact)) - (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7))) - (mandatory - (list - (list (calendar-gregorian-from-absolute abs-easter) - "Easter Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 2)) - "Good Friday") - (list (calendar-gregorian-from-absolute (- abs-easter 46)) - "Ash Wednesday"))) - (optional - (list - (list (calendar-gregorian-from-absolute (- abs-easter 63)) - "Septuagesima Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 56)) - "Sexagesima Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 49)) - "Shrove Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 48)) - "Shrove Monday") - (list (calendar-gregorian-from-absolute (- abs-easter 47)) - "Shrove Tuesday") - (list (calendar-gregorian-from-absolute (- abs-easter 14)) - "Passion Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 7)) - "Palm Sunday") - (list (calendar-gregorian-from-absolute (- abs-easter 3)) - "Maundy Thursday") - (list (calendar-gregorian-from-absolute (+ abs-easter 35)) - "Rogation Sunday") - (list (calendar-gregorian-from-absolute (+ abs-easter 39)) - "Ascension Day") - (list (calendar-gregorian-from-absolute (+ abs-easter 49)) - "Pentecost (Whitsunday)") - (list (calendar-gregorian-from-absolute (+ abs-easter 50)) - "Whitmonday") - (list (calendar-gregorian-from-absolute (+ abs-easter 56)) - "Trinity Sunday") - (list (calendar-gregorian-from-absolute (+ abs-easter 60)) - "Corpus Christi"))) - (output-list - (filter-visible-calendar-holidays mandatory))) - (if all-christian-calendar-holidays - (setq output-list - (append - (filter-visible-calendar-holidays optional) - output-list))) - output-list))) - -(defun holiday-greek-orthodox-easter () - "Date of Easter according to the rule of the Council of Nicaea." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y 1) - (let* ((julian-year - (extract-calendar-year - (calendar-julian-from-absolute - (calendar-absolute-from-gregorian - (list m (calendar-last-day-of-month m y) y))))) - (shifted-epact ;; Age of moon for April 5. - (% (+ 14 - (* 11 (% julian-year 19))) - 30)) - (paschal-moon ;; Day after full moon on or after March 21. - (- (calendar-absolute-from-julian (list 4 19 julian-year)) - shifted-epact)) - (nicaean-easter;; Sunday following the Paschal moon - (calendar-gregorian-from-absolute - (calendar-dayname-on-or-before 0 (+ paschal-moon 7))))) - (if (calendar-date-is-visible-p nicaean-easter) - (list (list nicaean-easter "Pascha (Greek Orthodox Easter)")))))) - -(defun filter-visible-calendar-holidays (l) - "Return a list of all visible holidays of those on L." - (let ((visible) - (p l)) - (while p - (and (car (car p)) - (calendar-date-is-visible-p (car (car p))) - (setq visible (append (list (car p)) visible))) - (setq p (cdr p))) - visible)) - -(provide 'holidays) - -;;; holidays.el ends here diff --git a/lisp/calendar/lunar.el b/lisp/calendar/lunar.el deleted file mode 100644 index 67a472ebaab..00000000000 --- a/lisp/calendar/lunar.el +++ /dev/null @@ -1,391 +0,0 @@ -;;; lunar.el --- calendar functions for phases of the moon. - -;; Copyright (C) 1992, 1993, 1995 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Keywords: calendar -;; Human-Keywords: moon, lunar phases, calendar, diary - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements lunar phases for calendar.el and -;; diary.el. - -;; Based on ``Astronomical Formulae for Calculators,'' 3rd ed., by Jean Meeus, -;; Willmann-Bell, Inc., 1985 and ``Astronomical Algorithms'' by Jean Meeus, -;; Willmann-Bell, Inc., 1991. -;; -;; WARNING: The calculations will be accurate only to within a few minutes. - -;; The author would be delighted to have an astronomically more sophisticated -;; person rewrite the code for the lunar calculations in this file! - -;; 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 - -;;; Code: - -(if (fboundp 'atan) - (require 'lisp-float-type) - (error "Lunar calculations impossible since floating point is unavailable.")) - -(require 'solar) - -(defun lunar-phase-list (month year) - "List of lunar phases for three months starting with Gregorian MONTH, YEAR." - (let ((end-month month) - (end-year year) - (start-month month) - (start-year year)) - (increment-calendar-month end-month end-year 3) - (increment-calendar-month start-month start-year -1) - (let* ((end-date (list (list end-month 1 end-year))) - (start-date (list (list start-month - (calendar-last-day-of-month - start-month start-year) - start-year))) - (index (* 4 - (truncate - (* 12.3685 - (+ year - ( / (calendar-day-number (list month 1 year)) - 366.0) - -1900))))) - (new-moon (lunar-phase index)) - (list)) - (while (calendar-date-compare new-moon end-date) - (if (calendar-date-compare start-date new-moon) - (setq list (append list (list new-moon)))) - (setq index (1+ index)) - (setq new-moon (lunar-phase index))) - list))) - -(defun lunar-phase (index) - "Local date and time of lunar phase INDEX. -Integer below INDEX/4 gives the lunation number, counting from Jan 1, 1900; -remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon, -3 last quarter." - (let* ((phase (mod index 4)) - (index (/ index 4.0)) - (time (/ index 1236.85)) - (date (+ (calendar-absolute-from-gregorian '(1 0.5 1900)) - 0.75933 - (* 29.53058868 index) - (* 0.0001178 time time) - (* -0.000000155 time time time) - (* 0.00033 - (solar-sin-degrees (+ 166.56 - (* 132.87 time) - (* -0.009173 time time)))))) - (sun-anomaly (mod - (+ 359.2242 - (* 29.105356 index) - (* -0.0000333 time time) - (* -0.00000347 time time time)) - 360.0)) - (moon-anomaly (mod - (+ 306.0253 - (* 385.81691806 index) - (* 0.0107306 time time) - (* 0.00001236 time time time)) - 360.0)) - (moon-lat (mod - (+ 21.2964 - (* 390.67050646 index) - (* -0.0016528 time time) - (* -0.00000239 time time time)) - 360.0)) - (adjustment - (if (memq phase '(0 2)) - (+ (* (- 0.1734 (* 0.000393 time)) - (solar-sin-degrees sun-anomaly)) - (* 0.0021 (solar-sin-degrees (* 2 sun-anomaly))) - (* -0.4068 (solar-sin-degrees moon-anomaly)) - (* 0.0161 (solar-sin-degrees (* 2 moon-anomaly))) - (* -0.0004 (solar-sin-degrees (* 3 moon-anomaly))) - (* 0.0104 (solar-sin-degrees (* 2 moon-lat))) - (* -0.0051 (solar-sin-degrees (+ sun-anomaly moon-anomaly))) - (* -0.0074 (solar-sin-degrees (- sun-anomaly moon-anomaly))) - (* 0.0004 (solar-sin-degrees (+ (* 2 moon-lat) sun-anomaly))) - (* -0.0004 (solar-sin-degrees (- (* 2 moon-lat) sun-anomaly))) - (* -0.0006 (solar-sin-degrees - (+ (* 2 moon-lat) moon-anomaly))) - (* 0.0010 (solar-sin-degrees (- (* 2 moon-lat) moon-anomaly))) - (* 0.0005 (solar-sin-degrees - (+ (* 2 moon-anomaly) sun-anomaly)))) - (+ (* (- 0.1721 (* 0.0004 time)) - (solar-sin-degrees sun-anomaly)) - (* 0.0021 (solar-sin-degrees (* 2 sun-anomaly))) - (* -0.6280 (solar-sin-degrees moon-anomaly)) - (* 0.0089 (solar-sin-degrees (* 2 moon-anomaly))) - (* -0.0004 (solar-sin-degrees (* 3 moon-anomaly))) - (* 0.0079 (solar-sin-degrees (* 2 moon-lat))) - (* -0.0119 (solar-sin-degrees (+ sun-anomaly moon-anomaly))) - (* -0.0047 (solar-sin-degrees (- sun-anomaly moon-anomaly))) - (* 0.0003 (solar-sin-degrees (+ (* 2 moon-lat) sun-anomaly))) - (* -0.0004 (solar-sin-degrees (- (* 2 moon-lat) sun-anomaly))) - (* -0.0006 (solar-sin-degrees (+ (* 2 moon-lat) moon-anomaly))) - (* 0.0021 (solar-sin-degrees (- (* 2 moon-lat) moon-anomaly))) - (* 0.0003 (solar-sin-degrees - (+ (* 2 moon-anomaly) sun-anomaly))) - (* 0.0004 (solar-sin-degrees - (- sun-anomaly (* 2 moon-anomaly)))) - (* -0.0003 (solar-sin-degrees - (+ (* 2 sun-anomaly) moon-anomaly)))))) - (adj (+ 0.0028 - (* -0.0004 (solar-cosine-degrees - sun-anomaly)) - (* 0.0003 (solar-cosine-degrees - moon-anomaly)))) - (adjustment (cond ((= phase 1) (+ adjustment adj)) - ((= phase 2) (- adjustment adj)) - (t adjustment))) - (date (+ date adjustment)) - (date (+ date (/ (- calendar-time-zone - (solar-ephemeris-correction - (extract-calendar-year - (calendar-gregorian-from-absolute - (truncate date))))) - 60.0 24.0))) - (time (* 24 (- date (truncate date)))) - (date (calendar-gregorian-from-absolute (truncate date))) - (adj (dst-adjust-time date time))) - (list (car adj) (apply 'solar-time-string (cdr adj)) phase))) - -(defun lunar-phase-name (phase) - "Name of lunar PHASE. -0 = new moon, 1 = first quarter, 2 = full moon, 3 = last quarter." - (cond ((= 0 phase) "New Moon") - ((= 1 phase) "First Quarter Moon") - ((= 2 phase) "Full Moon") - ((= 3 phase) "Last Quarter Moon"))) - -(defun calendar-phases-of-moon () - "Create a buffer with the lunar phases for the current calendar window." - (interactive) - (message "Computing phases of the moon...") - (let ((m1 displayed-month) - (y1 displayed-year) - (m2 displayed-month) - (y2 displayed-year)) - (increment-calendar-month m1 y1 -1) - (increment-calendar-month m2 y2 1) - (set-buffer (get-buffer-create lunar-phases-buffer)) - (setq buffer-read-only nil) - (calendar-set-mode-line - (if (= y1 y2) - (format "Phases of the Moon from %s to %s, %d%%-" - (calendar-month-name m1) (calendar-month-name m2) y2) - (format "Phases of the Moon from %s, %d to %s, %d%%-" - (calendar-month-name m1) y1 (calendar-month-name m2) y2))) - (erase-buffer) - (insert - (mapconcat - '(lambda (x) - (let ((date (car x)) - (time (car (cdr x))) - (phase (car (cdr (cdr x))))) - (concat (calendar-date-string date) - ": " - (lunar-phase-name phase) - " " - time))) - (lunar-phase-list m1 y1) "\n")) - (goto-char (point-min)) - (set-buffer-modified-p nil) - (setq buffer-read-only t) - (display-buffer lunar-phases-buffer) - (message "Computing phases of the moon...done"))) - -;;;###autoload -(defun phases-of-moon (&optional arg) - "Display the quarters of the moon for last month, this month, and next month. -If called with an optional prefix argument, prompts for month and year. - -This function is suitable for execution in a .emacs file." - (interactive "P") - (save-excursion - (let* ((date (if arg - (calendar-read-date t) - (calendar-current-date))) - (displayed-month (extract-calendar-month date)) - (displayed-year (extract-calendar-year date))) - (calendar-phases-of-moon)))) - -(defun diary-phases-of-moon () - "Moon phases diary entry." - (let* ((index (* 4 - (truncate - (* 12.3685 - (+ (extract-calendar-year date) - ( / (calendar-day-number date) - 366.0) - -1900))))) - (phase (lunar-phase index))) - (while (calendar-date-compare phase (list date)) - (setq index (1+ index)) - (setq phase (lunar-phase index))) - (if (calendar-date-equal (car phase) date) - (concat (lunar-phase-name (car (cdr (cdr phase)))) " " - (car (cdr phase)))))) - - -;; For the Chinese calendar the calculations for the new moon need to be more -;; accurate than those above, so we use more terms in the approximation. - -(defun lunar-new-moon-time (k) - "Astronomical (Julian) day number of K th new moon." - (let* ((T (/ k 1236.85)) - (T2 (* T T)) - (T3 (* T T T)) - (T4 (* T2 T2)) - (JDE (+ 2451550.09765 - (* 29.530588853 k) - (* 0.0001337 T2) - (* -0.000000150 T3) - (* 0.00000000073 T4))) - (E (- 1 (* 0.002516 T) (* 0.0000074 T2))) - (sun-anomaly (+ 2.5534 - (* 29.10535669 k) - (* -0.0000218 T2) - (* -0.00000011 T3))) - (moon-anomaly (+ 201.5643 - (* 385.81693528 k) - (* 0.0107438 T2) - (* 0.00001239 T3) - (* -0.000000058 T4))) - (moon-argument (+ 160.7108 - (* 390.67050274 k) - (* -0.0016341 T2) - (* -0.00000227 T3) - (* 0.000000011 T4))) - (omega (+ 124.7746 - (* -1.56375580 k) - (* 0.0020691 T2) - (* 0.00000215 T3))) - (A1 (+ 299.77 (* 0.107408 k) (* -0.009173 T2))) - (A2 (+ 251.88 (* 0.016321 k))) - (A3 (+ 251.83 (* 26.641886 k))) - (A4 (+ 349.42 (* 36.412478 k))) - (A5 (+ 84.66 (* 18.206239 k))) - (A6 (+ 141.74 (* 53.303771 k))) - (A7 (+ 207.14 (* 2.453732 k))) - (A8 (+ 154.84 (* 7.306860 k))) - (A9 (+ 34.52 (* 27.261239 k))) - (A10 (+ 207.19 (* 0.121824 k))) - (A11 (+ 291.34 (* 1.844379 k))) - (A12 (+ 161.72 (* 24.198154 k))) - (A13 (+ 239.56 (* 25.513099 k))) - (A14 (+ 331.55 (* 3.592518 k))) - (correction - (+ (* -0.40720 (solar-sin-degrees moon-anomaly)) - (* 0.17241 E (solar-sin-degrees sun-anomaly)) - (* 0.01608 (solar-sin-degrees (* 2 moon-anomaly))) - (* 0.01039 (solar-sin-degrees (* 2 moon-argument))) - (* 0.00739 E (solar-sin-degrees (- moon-anomaly sun-anomaly))) - (* -0.00514 E (solar-sin-degrees (+ moon-anomaly sun-anomaly))) - (* 0.00208 E E (solar-sin-degrees (* 2 sun-anomaly))) - (* -0.00111 (solar-sin-degrees - (- moon-anomaly (* 2 moon-argument)))) - (* -0.00057 (solar-sin-degrees - (+ moon-anomaly (* 2 moon-argument)))) - (* 0.00056 E (solar-sin-degrees - (+ (* 2 moon-anomaly) sun-anomaly))) - (* -0.00042 (solar-sin-degrees (* 3 moon-anomaly))) - (* 0.00042 E (solar-sin-degrees - (+ sun-anomaly (* 2 moon-argument)))) - (* 0.00038 E (solar-sin-degrees - (- sun-anomaly (* 2 moon-argument)))) - (* -0.00024 E (solar-sin-degrees - (- (* 2 moon-anomaly) sun-anomaly))) - (* -0.00017 (solar-sin-degrees omega)) - (* -0.00007 (solar-sin-degrees - (+ moon-anomaly (* 2 sun-anomaly)))) - (* 0.00004 (solar-sin-degrees - (- (* 2 moon-anomaly) (* 2 moon-argument)))) - (* 0.00004 (solar-sin-degrees (* 3 sun-anomaly))) - (* 0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly - (* -2 moon-argument)))) - (* 0.00003 (solar-sin-degrees - (+ (* 2 moon-anomaly) (* 2 moon-argument)))) - (* -0.00003 (solar-sin-degrees (+ moon-anomaly sun-anomaly - (* 2 moon-argument)))) - (* 0.00003 (solar-sin-degrees (- moon-anomaly sun-anomaly - (* -2 moon-argument)))) - (* -0.00002 (solar-sin-degrees (- moon-anomaly sun-anomaly - (* 2 moon-argument)))) - (* -0.00002 (solar-sin-degrees - (+ (* 3 moon-anomaly) sun-anomaly))) - (* 0.00002 (solar-sin-degrees (* 4 moon-anomaly))))) - (additional - (+ (* 0.000325 (solar-sin-degrees A1)) - (* 0.000165 (solar-sin-degrees A2)) - (* 0.000164 (solar-sin-degrees A3)) - (* 0.000126 (solar-sin-degrees A4)) - (* 0.000110 (solar-sin-degrees A5)) - (* 0.000062 (solar-sin-degrees A6)) - (* 0.000060 (solar-sin-degrees A7)) - (* 0.000056 (solar-sin-degrees A8)) - (* 0.000047 (solar-sin-degrees A9)) - (* 0.000042 (solar-sin-degrees A10)) - (* 0.000040 (solar-sin-degrees A11)) - (* 0.000037 (solar-sin-degrees A12)) - (* 0.000035 (solar-sin-degrees A13)) - (* 0.000023 (solar-sin-degrees A14)))) - (newJDE (+ JDE correction additional))) - (+ newJDE - (- (solar-ephemeris-correction - (extract-calendar-year - (calendar-gregorian-from-absolute - (floor (calendar-absolute-from-astro newJDE)))))) - (/ calendar-time-zone 60.0 24.0)))) - -(defun lunar-new-moon-on-or-after (d) - "Astronomical (Julian) day number of first new moon on or after astronomical -\(Julian) day number d. The fractional part is the time of day. - -The date and time are local time, including any daylight savings rules, -as governed by the values of calendar-daylight-savings-starts, -calendar-daylight-savings-starts-time, calendar-daylight-savings-ends, -calendar-daylight-savings-ends-time, calendar-daylight-time-offset, and -calendar-time-zone." - (let* ((date (calendar-gregorian-from-absolute - (floor (calendar-absolute-from-astro d)))) - (year (+ (extract-calendar-year date) - (/ (calendar-day-number date) 365.25))) - (k (floor (* (- year 2000.0) 12.3685))) - (date (lunar-new-moon-time k))) - (while (< date d) - (setq k (1+ k)) - (setq date (lunar-new-moon-time k))) - (let* ((a-date (calendar-absolute-from-astro date)) - (time (* 24 (- a-date (truncate a-date)))) - (date (calendar-gregorian-from-absolute (truncate a-date))) - (adj (dst-adjust-time date time))) - (calendar-astro-from-absolute - (+ (calendar-absolute-from-gregorian (car adj)) - (/ (car (cdr adj)) 24.0)))))) - -(provide 'lunar) - -;;; lunar.el ends here diff --git a/lisp/calendar/solar.el b/lisp/calendar/solar.el deleted file mode 100644 index 936f78501b1..00000000000 --- a/lisp/calendar/solar.el +++ /dev/null @@ -1,1045 +0,0 @@ -;;; solar.el --- calendar functions for solar events. - -;; Copyright (C) 1992, 1993, 1995 Free Software Foundation, Inc. - -;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> -;; Denis B. Roegel <Denis.Roegel@loria.fr> -;; Keywords: calendar -;; Human-Keywords: sunrise, sunset, equinox, solstice, calendar, diary, -;; holidays - -;; This file is part of GNU Emacs. - -;; GNU Emacs 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. - -;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. - -;;; Commentary: - -;; This collection of functions implements the features of calendar.el, -;; diary.el, and holiday.el that deal with times of day, sunrise/sunset, and -;; equinoxes/solstices. - -;; Based on the ``Almanac for Computers 1984,'' prepared by the Nautical -;; Almanac Office, United States Naval Observatory, Washington, 1984, on -;; ``Astronomical Formulae for Calculators,'' 3rd ed., by Jean Meeus, -;; Willmann-Bell, Inc., 1985, on ``Astronomical Algorithms'' by Jean Meeus, -;; Willmann-Bell, Inc., 1991, and on ``Planetary Programs and Tables from -;; -4000 to +2800'' by Pierre Bretagnon and Jean-Louis Simon, Willmann-Bell, -;; Inc., 1986. - -;; -;; Accuracy: -;; 1. Sunrise/sunset times will be accurate to the minute for years -;; 1951--2050. For other years the times will be within +/- 2 minutes. -;; -;; 2. Equinox/solstice times will be accurate to the minute for years -;; 1951--2050. For other years the times will be within +/- 1 minute. - -;; 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 - -;;; Code: - -(if (fboundp 'atan) - (require 'lisp-float-type) - (error "Solar/lunar calculations impossible since floating point is unavailable.")) - -(require 'cal-dst) -(require 'cal-julian) - -;;;###autoload -(defvar calendar-time-display-form - '(12-hours ":" minutes am-pm - (if time-zone " (") time-zone (if time-zone ")")) - "*The pseudo-pattern that governs the way a time of day is formatted. - -A pseudo-pattern is a list of expressions that can involve the keywords -`12-hours', `24-hours', and `minutes', all numbers in string form, -and `am-pm' and `time-zone', both alphabetic strings. - -For example, the form - - '(24-hours \":\" minutes - (if time-zone \" (\") time-zone (if time-zone \")\")) - -would give military-style times like `21:07 (UTC)'.") - -;;;###autoload -(defvar calendar-latitude nil - "*Latitude of `calendar-location-name' in degrees. - -The value can be either a decimal fraction (one place of accuracy is -sufficient), + north, - south, such as 40.7 for New York City, or the value -can be a vector [degrees minutes north/south] such as [40 50 north] for New -York City. - -This variable should be set in `site-start'.el.") - -;;;###autoload -(defvar calendar-longitude nil - "*Longitude of `calendar-location-name' in degrees. - -The value can be either a decimal fraction (one place of accuracy is -sufficient), + east, - west, such as -73.9 for New York City, or the value -can be a vector [degrees minutes east/west] such as [73 55 west] for New -York City. - -This variable should be set in `site-start'.el.") - -(defsubst calendar-latitude () - "Convert calendar-latitude to a signed decimal fraction, if needed." - (if (numberp calendar-latitude) - calendar-latitude - (let ((lat (+ (aref calendar-latitude 0) - (/ (aref calendar-latitude 1) 60.0)))) - (if (equal (aref calendar-latitude 2) 'north) - lat - (- lat))))) - -(defsubst calendar-longitude () - "Convert calendar-longitude to a signed decimal fraction, if needed." - (if (numberp calendar-longitude) - calendar-longitude - (let ((long (+ (aref calendar-longitude 0) - (/ (aref calendar-longitude 1) 60.0)))) - (if (equal (aref calendar-longitude 2) 'east) - long - (- long))))) - -;;;###autoload -(defvar calendar-location-name - '(let ((float-output-format "%.1f")) - (format "%s%s, %s%s" - (if (numberp calendar-latitude) - (abs calendar-latitude) - (+ (aref calendar-latitude 0) - (/ (aref calendar-latitude 1) 60.0))) - (if (numberp calendar-latitude) - (if (> calendar-latitude 0) "N" "S") - (if (equal (aref calendar-latitude 2) 'north) "N" "S")) - (if (numberp calendar-longitude) - (abs calendar-longitude) - (+ (aref calendar-longitude 0) - (/ (aref calendar-longitude 1) 60.0))) - (if (numberp calendar-longitude) - (if (> calendar-longitude 0) "E" "W") - (if (equal (aref calendar-longitude 2) 'east) "E" "W")))) - "*Expression evaluating to name of `calendar-longitude', calendar-latitude'. -For example, \"New York City\". Default value is just the latitude, longitude -pair. - -This variable should be set in `site-start'.el.") - -(defvar solar-error 0.5 -"*Tolerance (in minutes) for sunrise/sunset calculations. - -A larger value makes the calculations for sunrise/sunset faster, but less -accurate. The default is half a minute (30 seconds), so that sunrise/sunset -times will be correct to the minute. - -It is useless to set the value smaller than 4*delta, where delta is the -accuracy in the longitude of the sun (given by the function -`solar-ecliptic-coordinates') in degrees since (delta/360) x (86400/60) = 4 x -delta. At present, delta = 0.01 degrees, so the value of the variable -`solar-error' should be at least 0.04 minutes (about 2.5 seconds).") - -(defvar solar-n-hemi-seasons - '("Vernal Equinox" "Summer Solstice" "Autumnal Equinox" "Winter Solstice") - "List of season changes for the northern hemisphere.") - -(defvar solar-s-hemi-seasons - '("Autumnal Equinox" "Winter Solstice" "Vernal Equinox" "Summer Solstice") - "List of season changes for the southern hemisphere.") - -(defvar solar-sidereal-time-greenwich-midnight - nil - "Sidereal time at Greenwich at midnight (universal time).") - -(defvar solar-spring-or-summer-season nil - "T if spring or summer and nil otherwise. -Needed for polar areas, in order to know whether the day lasts 0 or 24 hours.") - -(defun solar-setup () - "Prompt user for latitude, longitude, and time zone." - (beep) - (if (not calendar-longitude) - (setq calendar-longitude - (solar-get-number - "Enter longitude (decimal fraction; + east, - west): "))) - (if (not calendar-latitude) - (setq calendar-latitude - (solar-get-number - "Enter latitude (decimal fraction; + north, - south): "))) - (if (not calendar-time-zone) - (setq calendar-time-zone - (solar-get-number - "Enter difference from Coordinated Universal Time (in minutes): ")))) - -(defun solar-get-number (prompt) - "Return a number from the minibuffer, prompting with PROMPT. -Returns nil if nothing was entered." - (let ((x (read-string prompt ""))) - (if (not (string-equal x "")) - (string-to-int x)))) - -;; The condition-case stuff is needed to catch bogus arithmetic -;; exceptions that occur on some machines (like Sparcs) -(defun solar-sin-degrees (x) - (condition-case nil - (sin (degrees-to-radians (mod x 360.0))) - (solar-sin-degrees x))) -(defun solar-cosine-degrees (x) - (condition-case nil - (cos (degrees-to-radians (mod x 360.0))) - (solar-cosine-degrees x))) -(defun solar-tangent-degrees (x) - (condition-case nil - (tan (degrees-to-radians (mod x 360.0))) - (solar-tangent-degrees x))) - -(defun solar-xy-to-quadrant (x y) - "Determines the quadrant of the point X, Y." - (if (> x 0) - (if (> y 0) 1 4) - (if (> y 0) 2 3))) - -(defun solar-degrees-to-quadrant (angle) - "Determines the quadrant of ANGLE." - (1+ (floor (mod angle 360) 90))) - -(defun solar-arctan (x quad) - "Arctangent of X in quadrant QUAD." - (let ((deg (radians-to-degrees (atan x)))) - (cond ((equal quad 2) (+ deg 180)) - ((equal quad 3) (+ deg 180)) - ((equal quad 4) (+ deg 360)) - (t deg)))) - -(defun solar-atn2 (x y) - "Arctan of point X, Y." - (if (= x 0) - (if (> y 0) 90 270) - (solar-arctan (/ y x) x))) - -(defun solar-arccos (x) - "Arcos of X." - (let ((y (sqrt (- 1 (* x x))))) - (solar-atn2 x y))) - -(defun solar-arcsin (y) - "Arcsin of Y." - (let ((x (sqrt (- 1 (* y y))))) - (solar-atn2 x y) - )) - -(defsubst solar-degrees-to-hours (degrees) - "Convert DEGREES to hours." - (/ degrees 15.0)) - -(defsubst solar-hours-to-days (hour) - "Convert HOUR to decimal fraction of a day." - (/ hour 24.0)) - -(defun solar-right-ascension (longitude obliquity) - "Right ascension of the sun, in hours, given LONGITUDE and OBLIQUITY. -Both arguments are in degrees." - (solar-degrees-to-hours - (solar-arctan - (* (solar-cosine-degrees obliquity) (solar-tangent-degrees longitude)) - (solar-degrees-to-quadrant longitude)))) - -(defun solar-declination (longitude obliquity) - "Declination of the sun, in degrees, given LONGITUDE and OBLIQUITY. -Both arguments are in degrees." - (solar-arcsin - (* (solar-sin-degrees obliquity) - (solar-sin-degrees longitude)))) - -(defun solar-sunrise-and-sunset (time latitude longitude) - "Sunrise, sunset and length of day. -Parameters are the midday TIME and the LATITUDE, LONGITUDE of the location. - -TIME is a pair with the first component being the number of Julian centuries -elapsed at 0 Universal Time, and the second component being the universal -time. For instance, the pair corresponding to November 28, 1995 at 16 UT is -\(-0.040945 16), -0.040945 being the number of julian centuries elapsed between -Jan 1, 2000 at 12 UT and November 28, 1995 at 0 UT. - -Coordinates are included because this function is called with latitude=10 -degrees to find out if polar regions have 24 hours of sun or only night." - (let* ((rise-time (solar-moment -1 latitude longitude time)) - (set-time (solar-moment 1 latitude longitude time)) - (day-length)) - (if (not (and rise-time set-time)) - (if (or (and (> latitude 0) solar-spring-or-summer-season) - (and (< latitude 0) (not solar-spring-or-summer-season))) - (setq day-length 24) - (setq day-length 0)) - (setq day-length (- set-time rise-time))) - (list (if rise-time (+ rise-time (/ calendar-time-zone 60.0)) nil) - (if set-time (+ set-time (/ calendar-time-zone 60.0)) nil) - day-length))) - -(defun solar-moment (direction latitude longitude time) - "Sunrise/sunset at location. -Sunrise if DIRECTION =-1 or sunset if =1 at LATITUDE, LONGITUDE, with midday -being TIME. - -TIME is a pair with the first component being the number of Julian centuries -elapsed at 0 Universal Time, and the second component being the universal -time. For instance, the pair corresponding to November 28, 1995 at 16 UT is -\(-0.040945 16), -0.040945 being the number of julian centuries elapsed between -Jan 1, 2000 at 12 UT and November 28, 1995 at 0 UT. - -Uses binary search." - (let* ((ut (car (cdr time))) - (possible 1) ; we assume that rise or set are possible - (utmin (+ ut (* direction 12.0))) - (utmax ut) ; the time searched is between utmin and utmax - ; utmin and utmax are in hours - (utmoment-old 0.0) ; rise or set approximation - (utmoment 1.0) ; rise or set approximation - (hut 0) ; sun height at utmoment - (t0 (car time)) - (hmin (car (cdr - (solar-horizontal-coordinates (list t0 utmin) - latitude longitude t)))) - (hmax (car (cdr - (solar-horizontal-coordinates (list t0 utmax) - latitude longitude t))))) - ; -0.61 degrees is the height of the middle of the sun, when it rises - ; or sets. - (if (< hmin -0.61) - (if (> hmax -0.61) - (while ;(< i 20) ; we perform a simple dichotomy - ; (> (abs (+ hut 0.61)) epsilon) - (>= (abs (- utmoment utmoment-old)) - (/ solar-error 60)) - (setq utmoment-old utmoment) - (setq utmoment (/ (+ utmin utmax) 2)) - (setq hut (car (cdr - (solar-horizontal-coordinates - (list t0 utmoment) latitude longitude t)))) - (if (< hut -0.61) (setq utmin utmoment)) - (if (> hut -0.61) (setq utmax utmoment)) - ) - (setq possible 0)) ; the sun never rises - (setq possible 0)) ; the sun never sets - (if (equal possible 0) nil utmoment))) - -(defun solar-time-string (time time-zone) - "Printable form for decimal fraction TIME in TIME-ZONE. -Format used is given by `calendar-time-display-form'." - (let* ((time (round (* 60 time))) - (24-hours (/ time 60)) - (minutes (format "%02d" (% time 60))) - (12-hours (format "%d" (1+ (% (+ 24-hours 11) 12)))) - (am-pm (if (>= 24-hours 12) "pm" "am")) - (24-hours (format "%02d" 24-hours))) - (mapconcat 'eval calendar-time-display-form ""))) - - -(defun solar-daylight (time) - "Printable form for time expressed in hours." - (format "%d:%02d" - (floor time) - (floor (* 60 (- time (floor time)))))) - -(defun solar-exact-local-noon (date) - "Date and Universal Time of local noon at *local date* date. - -The date may be different from the one asked for, but it will be the right -local date. The second component of date should be an integer." - (let* ((nd date) - (ut (- 12.0 (/ (calendar-longitude) 15))) - (te (solar-time-equation date ut))) - (setq ut (- ut te)) - (if (>= ut 24) - (progn - (setq nd (list (car date) (+ 1 (car (cdr date))) - (car (cdr (cdr date))))) - (setq ut (- ut 24)))) - (if (< ut 0) - (progn - (setq nd (list (car date) (- (car (cdr date)) 1) - (car (cdr (cdr date))))) - (setq ut (+ ut 24)))) - (setq nd (calendar-gregorian-from-absolute - (calendar-absolute-from-gregorian nd))) - ; date standardization - (list nd ut))) - -(defun solar-sunrise-sunset (date) - "List of *local* times of sunrise, sunset, and daylight on Gregorian DATE. - -Corresponding value is nil if there is no sunrise/sunset." - (let* (; first, get the exact moment of local noon. - (exact-local-noon (solar-exact-local-noon date)) - ; get the the time from the 2000 epoch. - (t0 (solar-julian-ut-centuries (car exact-local-noon))) - ; store the sidereal time at Greenwich at midnight of UT time. - ; find if summer or winter slightly above the equator - (equator-rise-set - (progn (setq solar-sidereal-time-greenwich-midnight - (solar-sidereal-time t0)) - (solar-sunrise-and-sunset - (list t0 (car (cdr exact-local-noon))) - 10.0 - (calendar-longitude)))) - ; store the spring/summer information, - ; compute sunrise and sunset (two first components of rise-set). - ; length of day is the third component (it is only the difference - ; between sunset and sunrise when there is a sunset and a sunrise) - (rise-set - (progn - (setq solar-spring-or-summer-season - (if (> (car (cdr (cdr equator-rise-set))) 12) 1 0)) - (solar-sunrise-and-sunset - (list t0 (car (cdr exact-local-noon))) - (calendar-latitude) - (calendar-longitude)))) - (rise (car rise-set)) - (adj-rise (if rise (dst-adjust-time date rise) nil)) - (set (car (cdr rise-set))) - (adj-set (if set (dst-adjust-time date set) nil)) - (length (car (cdr (cdr rise-set)))) ) - (list - (and rise (calendar-date-equal date (car adj-rise)) (cdr adj-rise)) - (and set (calendar-date-equal date (car adj-set)) (cdr adj-set)) - (solar-daylight length)))) - -(defun solar-sunrise-sunset-string (date) - "String of *local* times of sunrise, sunset, and daylight on Gregorian DATE." - (let ((l (solar-sunrise-sunset date))) - (format - "%s, %s at %s (%s hours daylight)" - (if (car l) - (concat "Sunrise " (apply 'solar-time-string (car l))) - "No sunrise") - (if (car (cdr l)) - (concat "sunset " (apply 'solar-time-string (car (cdr l)))) - "no sunset") - (eval calendar-location-name) - (car (cdr (cdr l)))))) - -(defun solar-julian-ut-centuries (date) - "Number of Julian centuries elapsed since 1 Jan, 2000 at noon U.T. for Gregorian DATE." - (/ (- (calendar-absolute-from-gregorian date) - (calendar-absolute-from-gregorian '(1 1.5 2000))) - 36525.0)) - -(defun solar-ephemeris-time(time) - "Ephemeris Time at moment TIME. - -TIME is a pair with the first component being the number of Julian centuries -elapsed at 0 Universal Time, and the second component being the universal -time. For instance, the pair corresponding to November 28, 1995 at 16 UT is -\(-0.040945 16), -0.040945 being the number of julian centuries elapsed between -Jan 1, 2000 at 12 UT and November 28, 1995 at 0 UT. - -Result is in julian centuries of ephemeris time." - (let* ((t0 (car time)) - (ut (car (cdr time))) - (t1 (+ t0 (/ (/ ut 24.0) 36525))) - (y (+ 2000 (* 100 t1))) - (dt (* 86400 (solar-ephemeris-correction (floor y))))) - (+ t1 (/ (/ dt 86400) 36525)))) - -(defun solar-date-next-longitude (d l) - "First moment on or after Julian day number D when sun's longitude is a -multiple of L degrees at calendar-location-name with that location's -local time (including any daylight savings rules). - -L must be an integer divisor of 360. - -Result is in local time expressed astronomical (Julian) day numbers. - -The values of calendar-daylight-savings-starts, -calendar-daylight-savings-starts-time, calendar-daylight-savings-ends, -calendar-daylight-savings-ends-time, calendar-daylight-time-offset, and -calendar-time-zone are used to interpret local time." - (let* ((long) - (start d) - (start-long (solar-longitude d)) - (next (mod (* l (1+ (floor (/ start-long l)))) 360)) - (end (+ d (* (/ l 360.0) 400))) - (end-long (solar-longitude end))) - (while ;; bisection search for nearest minute - (< 0.00001 (- end start)) - ;; start <= d < end - ;; start-long <= next < end-long when next != 0 - ;; when next = 0, we look for the discontinuity (start-long is near 360 - ;; and end-long is small (less than l). - (setq d (/ (+ start end) 2.0)) - (setq long (solar-longitude d)) - (if (or (and (/= next 0) (< long next)) - (and (= next 0) (< l long))) - (progn - (setq start d) - (setq start-long long)) - (setq end d) - (setq end-long long))) - (/ (+ start end) 2.0))) - -(defun solar-horizontal-coordinates - (time latitude longitude for-sunrise-sunset) - "Azimuth and height of the sun at TIME, LATITUDE, and LONGITUDE. - -TIME is a pair with the first component being the number of Julian centuries -elapsed at 0 Universal Time, and the second component being the universal -time. For instance, the pair corresponding to November 28, 1995 at 16 UT is -\(-0.040945 16), -0.040945 being the number of julian centuries elapsed between -Jan 1, 2000 at 12 UT and November 28, 1995 at 0 UT. - -The azimuth is given in degrees as well as the height (between -180 and 180)." - (let* ((ut (car (cdr time))) - (ec (solar-equatorial-coordinates time for-sunrise-sunset)) - (st (+ solar-sidereal-time-greenwich-midnight - (* ut 1.00273790935))) - (ah (- (* st 15) (* 15 (car ec)) (* -1 (calendar-longitude)))) - ; hour angle (in degrees) - (de (car (cdr ec))) - (azimuth (solar-atn2 (- (* (solar-cosine-degrees ah) - (solar-sin-degrees latitude)) - (* (solar-tangent-degrees de) - (solar-cosine-degrees latitude))) - (solar-sin-degrees ah))) - (height (solar-arcsin - (+ (* (solar-sin-degrees latitude) (solar-sin-degrees de)) - (* (solar-cosine-degrees latitude) - (solar-cosine-degrees de) - (solar-cosine-degrees ah)))))) - (if (> height 180) (setq height (- height 360))) - (list azimuth height))) - -(defun solar-equatorial-coordinates (time for-sunrise-sunset) - "Right ascension (in hours) and declination (in degrees) of the sun at TIME. - -TIME is a pair with the first component being the number of Julian centuries -elapsed at 0 Universal Time, and the second component being the universal -time. For instance, the pair corresponding to November 28, 1995 at 16 UT is -\(-0.040945 16), -0.040945 being the number of julian centuries elapsed between -Jan 1, 2000 at 12 UT and November 28, 1995 at 0 UT." - (let* ((tm (solar-ephemeris-time time)) - (ec (solar-ecliptic-coordinates tm for-sunrise-sunset))) - (list (solar-right-ascension (car ec) (car (cdr ec))) - (solar-declination (car ec) (car (cdr ec)))))) - -(defun solar-ecliptic-coordinates (time for-sunrise-sunset) - "Apparent longitude of the sun, ecliptic inclination, (both in degrees) -equation of time (in hours) and nutation in longitude (in seconds) -at moment `time', expressed in julian centuries of Ephemeris Time -since January 1st, 2000, at 12 ET." - (let* ((l (+ 280.46645 - (* 36000.76983 time) - (* 0.0003032 time time))) ; sun mean longitude - (ml (+ 218.3165 - (* 481267.8813 time))) ; moon mean longitude - (m (+ 357.52910 - (* 35999.05030 time) - (* -0.0001559 time time) - (* -0.00000048 time time time))) ; sun mean anomaly - (i (+ 23.43929111 (* -0.013004167 time) - (* -0.00000016389 time time) - (* 0.0000005036 time time time))); mean inclination - (c (+ (* (+ 1.914600 - (* -0.004817 time) - (* -0.000014 time time)) - (solar-sin-degrees m)) - (* (+ 0.019993 (* -0.000101 time)) - (solar-sin-degrees (* 2 m))) - (* 0.000290 - (solar-sin-degrees (* 3 m))))) ; center equation - (L (+ l c)) ; total longitude - (omega (+ 125.04 - (* -1934.136 time))) ; longitude of moon's ascending node - ; on the ecliptic - (nut (if (not for-sunrise-sunset) - (+ (* -17.20 (solar-sin-degrees omega)) - (* -1.32 (solar-sin-degrees (* 2 l))) - (* -0.23 (solar-sin-degrees (* 2 ml))) - (* 0.21 (solar-sin-degrees (* 2 omega)))) - nil)) - ; nut = nutation in longitude, measured in seconds of angle. - (ecc (if (not for-sunrise-sunset) - (+ 0.016708617 - (* -0.000042037 time) - (* -0.0000001236 time time)) ; eccentricity of earth's orbit - nil)) - (app (+ L - -0.00569 - (* -0.00478 - (solar-sin-degrees omega)))) ; apparent longitude of sun - (y (if (not for-sunrise-sunset) - (* (solar-tangent-degrees (/ i 2)) - (solar-tangent-degrees (/ i 2))) - nil)) - (time-eq (if (not for-sunrise-sunset) - (/ (* 12 (+ (* y (solar-sin-degrees (* 2 l))) - (* -2 ecc (solar-sin-degrees m)) - (* 4 ecc y (solar-sin-degrees m) - (solar-cosine-degrees (* 2 l))) - (* -0.5 y y (solar-sin-degrees (* 4 l))) - (* -1.25 ecc ecc (solar-sin-degrees (* 2 m))))) - 3.1415926535) - nil))) - ; equation of time, in hours - (list app i time-eq nut))) - -(defun solar-longitude (d) - "Longitude of sun on astronomical (Julian) day number D. -Accurary is about 0.0006 degree (about 365.25*24*60*0.0006/360 = 1 minutes). - -The values of calendar-daylight-savings-starts, -calendar-daylight-savings-starts-time, calendar-daylight-savings-ends, -calendar-daylight-savings-ends-time, calendar-daylight-time-offset, and -calendar-time-zone are used to interpret local time." - (let* ((a-d (calendar-absolute-from-astro d)) - ;; get Universal Time - (date (calendar-astro-from-absolute - (- a-d - (if (dst-in-effect a-d) - (/ calendar-daylight-time-offset 24.0 60.0) 0) - (/ calendar-time-zone 60.0 24.0)))) - ;; get Ephemeris Time - (date (+ date (solar-ephemeris-correction - (extract-calendar-year - (calendar-gregorian-from-absolute - (floor - (calendar-absolute-from-astro - date))))))) - (U (/ (- date 2451545) 3652500)) - (longitude - (+ 4.9353929 - (* 62833.1961680 U) - (* 0.0000001 - (apply '+ - (mapcar '(lambda (x) - (* (car x) - (sin (mod - (+ (car (cdr x)) - (* (car (cdr (cdr x))) U)) - (* 2 pi))))) - solar-data-list))))) - (aberration - (* 0.0000001 (- (* 17 (cos (+ 3.10 (* 62830.14 U)))) 973))) - (A1 (mod (+ 2.18 (* U (+ -3375.70 (* 0.36 U)))) (* 2 pi))) - (A2 (mod (+ 3.51 (* U (+ 125666.39 (* 0.10 U)))) (* 2 pi))) - (nutation (* -0.0000001 (+ (* 834 (sin A1)) (* 64 (sin A2)))))) - (mod (radians-to-degrees (+ longitude aberration nutation)) 360.0))) - -(defconst solar-data-list - '((403406 4.721964 1.621043) - (195207 5.937458 62830.348067) - (119433 1.115589 62830.821524) - (112392 5.781616 62829.634302) - (3891 5.5474 125660.5691) - (2819 1.5120 125660.984) - (1721 4.1897 62832.4766) - (0 1.163 0.813) - (660 5.415 125659.31) - (350 4.315 57533.85) - (334 4.553 -33.931) - (314 5.198 777137.715) - (268 5.989 78604.191) - (242 2.911 5.412) - (234 1.423 39302.098) - (158 0.061 -34.861) - (132 2.317 115067.698) - (129 3.193 15774.337) - (114 2.828 5296.670) - (99 0.52 58849.27) - (93 4.65 5296.11) - (86 4.35 -3980.70) - (78 2.75 52237.69) - (72 4.50 55076.47) - (68 3.23 261.08) - (64 1.22 15773.85) - (46 0.14 188491.03) - (38 3.44 -7756.55) - (37 4.37 264.89) - (32 1.14 117906.27) - (29 2.84 55075.75) - (28 5.96 -7961.39) - (27 5.09 188489.81) - (27 1.72 2132.19) - (25 2.56 109771.03) - (24 1.92 54868.56) - (21 0.09 25443.93) - (21 5.98 -55731.43) - (20 4.03 60697.74) - (18 4.47 2132.79) - (17 0.79 109771.63) - (14 4.24 -7752.82) - (13 2.01 188491.91) - (13 2.65 207.81) - (13 4.98 29424.63) - (12 0.93 -7.99) - (10 2.21 46941.14) - (10 3.59 -68.29) - (10 1.50 21463.25) - (10 2.55 157208.40))) - -(defun solar-ephemeris-correction (year) - "Ephemeris time minus Universal Time during Gregorian year. -Result is in days. - -For the years 1800-1987, the maximum error is 1.9 seconds. -For the other years, the maximum error is about 30 seconds." - (cond ((and (<= 1988 year) (< year 2020)) - (/ (+ year -2000 67.0) 60.0 60.0 24.0)) - ((and (<= 1900 year) (< year 1988)) - (let* ((theta (/ (- (calendar-astro-from-absolute - (calendar-absolute-from-gregorian - (list 7 1 year))) - (calendar-astro-from-absolute - (calendar-absolute-from-gregorian - '(1 1 1900)))) - 36525.0)) - (theta2 (* theta theta)) - (theta3 (* theta2 theta)) - (theta4 (* theta2 theta2)) - (theta5 (* theta3 theta2))) - (+ -0.00002 - (* 0.000297 theta) - (* 0.025184 theta2) - (* -0.181133 theta3) - (* 0.553040 theta4) - (* -0.861938 theta5) - (* 0.677066 theta3 theta3) - (* -0.212591 theta4 theta3)))) - ((and (<= 1800 year) (< year 1900)) - (let* ((theta (/ (- (calendar-astro-from-absolute - (calendar-absolute-from-gregorian - (list 7 1 year))) - (calendar-astro-from-absolute - (calendar-absolute-from-gregorian - '(1 1 1900)))) - 36525.0)) - (theta2 (* theta theta)) - (theta3 (* theta2 theta)) - (theta4 (* theta2 theta2)) - (theta5 (* theta3 theta2))) - (+ -0.000009 - (* 0.003844 theta) - (* 0.083563 theta2) - (* 0.865736 theta3) - (* 4.867575 theta4) - (* 15.845535 theta5) - (* 31.332267 theta3 theta3) - (* 38.291999 theta4 theta3) - (* 28.316289 theta4 theta4) - (* 11.636204 theta4 theta5) - (* 2.043794 theta5 theta5)))) - ((and (<= 1620 year) (< year 1800)) - (let ((x (/ (- year 1600) 10.0))) - (/ (+ (* 2.19167 x x) (* -40.675 x) 196.58333) 60.0 60.0 24.0))) - (t (let* ((tmp (- (calendar-astro-from-absolute - (calendar-absolute-from-gregorian - (list 1 1 year))) - 2382148)) - (second (- (/ (* tmp tmp) 41048480.0) 15))) - (/ second 60.0 60.0 24.0))))) - -(defun solar-sidereal-time (t0) - "Sidereal time (in hours) in Greenwich. - -At T0=Julian centuries of universal time. -T0 must correspond to 0 hours UT." - (let* ((mean-sid-time (+ 6.6973746 - (* 2400.051337 t0) - (* 0.0000258622 t0 t0) - (* -0.0000000017222 t0 t0 t0))) - (et (solar-ephemeris-time (list t0 0.0))) - (nut-i (solar-ecliptic-coordinates et nil)) - (nut (car (cdr (cdr (cdr nut-i))))) ; nutation - (i (car (cdr nut-i)))) ; inclination - (mod (+ (mod (+ mean-sid-time - (/ (/ (* nut (solar-cosine-degrees i)) 15) 3600)) 24.0) - 24.0) - 24.0))) - -(defun solar-time-equation (date ut) - "Equation of time expressed in hours at Gregorian DATE at Universal time UT." - (let* ((et (solar-date-to-et date ut)) - (ec (solar-ecliptic-coordinates et nil))) - (car (cdr (cdr ec))))) - -(defun solar-date-to-et (date ut) - "Ephemeris Time at Gregorian DATE at Universal Time UT (in hours). -Expressed in julian centuries of Ephemeris Time." - (let ((t0 (solar-julian-ut-centuries date))) - (solar-ephemeris-time (list t0 ut)))) - -;;;###autoload -(defun sunrise-sunset (&optional arg) - "Local time of sunrise and sunset for today. Accurate to a few seconds. -If called with an optional prefix argument, prompt for date. - -If called with an optional double prefix argument, prompt for longitude, -latitude, time zone, and date, and always use standard time. - -This function is suitable for execution in a .emacs file." - (interactive "p") - (or arg (setq arg 1)) - (if (and (< arg 16) - (not (and calendar-latitude calendar-longitude calendar-time-zone))) - (solar-setup)) - (let* ((calendar-longitude - (if (< arg 16) calendar-longitude - (solar-get-number - "Enter longitude (decimal fraction; + east, - west): "))) - (calendar-latitude - (if (< arg 16) calendar-latitude - (solar-get-number - "Enter latitude (decimal fraction; + north, - south): "))) - (calendar-time-zone - (if (< arg 16) calendar-time-zone - (solar-get-number - "Enter difference from Coordinated Universal Time (in minutes): "))) - (calendar-location-name - (if (< arg 16) calendar-location-name - (let ((float-output-format "%.1f")) - (format "%s%s, %s%s" - (if (numberp calendar-latitude) - (abs calendar-latitude) - (+ (aref calendar-latitude 0) - (/ (aref calendar-latitude 1) 60.0))) - (if (numberp calendar-latitude) - (if (> calendar-latitude 0) "N" "S") - (if (equal (aref calendar-latitude 2) 'north) "N" "S")) - (if (numberp calendar-longitude) - (abs calendar-longitude) - (+ (aref calendar-longitude 0) - (/ (aref calendar-longitude 1) 60.0))) - (if (numberp calendar-longitude) - (if (> calendar-longitude 0) "E" "W") - (if (equal (aref calendar-longitude 2) 'east) - "E" "W")))))) - (calendar-standard-time-zone-name - (if (< arg 16) calendar-standard-time-zone-name - (cond ((= calendar-time-zone 0) "UTC") - ((< calendar-time-zone 0) - (format "UTC%dmin" calendar-time-zone)) - (t (format "UTC+%dmin" calendar-time-zone))))) - (calendar-daylight-savings-starts - (if (< arg 16) calendar-daylight-savings-starts)) - (calendar-daylight-savings-ends - (if (< arg 16) calendar-daylight-savings-ends)) - (date (if (< arg 4) (calendar-current-date) (calendar-read-date))) - (date-string (calendar-date-string date t)) - (time-string (solar-sunrise-sunset-string date)) - (msg (format "%s: %s" date-string time-string)) - (one-window (one-window-p t))) - (if (<= (length msg) (frame-width)) - (message "%s" msg) - (with-output-to-temp-buffer "*temp*" - (princ (concat date-string "\n" time-string))) - (message "%s" - (substitute-command-keys - (if one-window - (if pop-up-windows - "Type \\[delete-other-windows] to remove temp window." - "Type \\[switch-to-buffer] RET to remove temp window.") - "Type \\[switch-to-buffer-other-window] RET to restore old contents of temp window.")))))) - -(defun calendar-sunrise-sunset () - "Local time of sunrise and sunset for date under cursor. -Accurate to a few seconds." - (interactive) - (if (not (and calendar-latitude calendar-longitude calendar-time-zone)) - (solar-setup)) - (let ((date (calendar-cursor-to-date t))) - (message "%s: %s" - (calendar-date-string date t t) - (solar-sunrise-sunset-string date)))) - -(defun diary-sunrise-sunset () - "Local time of sunrise and sunset as a diary entry. -Accurate to a few seconds." - (if (not (and calendar-latitude calendar-longitude calendar-time-zone)) - (solar-setup)) - (solar-sunrise-sunset-string date)) - -(defun diary-sabbath-candles () - "Local time of candle lighting diary entry--applies if date is a Friday. -No diary entry if there is no sunset on that date." - (if (not (and calendar-latitude calendar-longitude calendar-time-zone)) - (solar-setup)) - (if (= (% (calendar-absolute-from-gregorian date) 7) 5);; Friday - (let* ((sunset (car (cdr (solar-sunrise-sunset date)))) - (light (if sunset - (cons (- (car sunset) (/ 18.0 60.0)) (cdr sunset))))) - (if sunset - (format "%s Sabbath candle lighting" - (apply 'solar-time-string light)))))) - -(defun solar-equinoxes/solstices (k year) - "Date of equinox/solstice K for YEAR. -K=0, spring equinox; K=1, summer solstice; K=2, fall equinox; -K=3, winter solstice. -RESULT is a gregorian local date. - -Accurate to less than a minute between 1951 and 2050." - (let* ((JDE0 (solar-mean-equinoxes/solstices k year)) - (T (/ (- JDE0 2451545.0) 36525)) - (W (- (* 35999.373 T) 2.47)) - (Delta-lambda (+ 1 (* 0.0334 (solar-cosine-degrees W)) - (* 0.0007 (solar-cosine-degrees (* 2 W))))) - (S (apply '+ (mapcar '(lambda(x) - (* (car x) (solar-cosine-degrees - (+ (* (car (cdr (cdr x))) T) - (car (cdr x)))))) - solar-seasons-data))) - (JDE (+ JDE0 (/ (* 0.00001 S) Delta-lambda))) - (correction (+ 102.3 (* 123.5 T) (* 32.5 T T))) - ; ephemeris time correction - (JD (- JDE (/ correction 86400))) - (date (calendar-gregorian-from-absolute (floor (- JD 1721424.5)))) - (time (- (- JD 0.5) (floor (- JD 0.5)))) - ) - (list (car date) (+ (car (cdr date)) time - (/ (/ calendar-time-zone 60.0) 24.0)) - (car (cdr (cdr date)))))) - -; from Meeus, 1991, page 166 -(defun solar-mean-equinoxes/solstices (k year) - "Julian day of mean equinox/solstice K for YEAR. -K=0, spring equinox; K=1, summer solstice; K=2, fall equinox; K=3, winter -solstice. These formulas are only to be used between 1000 BC and 3000 AD." - (let ((y (/ year 1000.0)) - (z (/ (- year 2000) 1000.0))) - (if (< year 1000) ; actually between -1000 and 1000 - (cond ((equal k 0) (+ 1721139.29189 - (* 365242.13740 y) - (* 0.06134 y y) - (* 0.00111 y y y) - (* -0.00071 y y y y))) - ((equal k 1) (+ 1721233.25401 - (* 365241.72562 y) - (* -0.05323 y y) - (* 0.00907 y y y) - (* 0.00025 y y y y))) - ((equal k 2) (+ 1721325.70455 - (* 365242.49558 y) - (* -0.11677 y y) - (* -0.00297 y y y) - (* 0.00074 y y y y))) - ((equal k 3) (+ 1721414.39987 - (* 365242.88257 y) - (* -0.00769 y y) - (* -0.00933 y y y) - (* -0.00006 y y y y)))) - ; actually between 1000 and 3000 - (cond ((equal k 0) (+ 2451623.80984 - (* 365242.37404 z) - (* 0.05169 z z) - (* -0.00411 z z z) - (* -0.00057 z z z z))) - ((equal k 1) (+ 2451716.56767 - (* 365241.62603 z) - (* 0.00325 z z) - (* 0.00888 z z z) - (* -0.00030 z z z z))) - ((equal k 2) (+ 2451810.21715 - (* 365242.01767 z) - (* -0.11575 z z) - (* 0.00337 z z z) - (* 0.00078 z z z z))) - ((equal k 3) (+ 2451900.05952 - (* 365242.74049 z) - (* -0.06223 z z) - (* -0.00823 z z z) - (* 0.00032 z z z z))))))) - -; from Meeus, 1991, page 167 -(defconst solar-seasons-data - '((485 324.96 1934.136) - (203 337.23 32964.467) - (199 342.08 20.186) - (182 27.85 445267.112) - (156 73.14 45036.886) - (136 171.52 22518.443) - (77 222.54 65928.934) - (74 296.72 3034.906) - (70 243.58 9037.513) - (58 119.81 33718.147) - (52 297.17 150.678) - (50 21.02 2281.226) - (45 247.54 29929.562) - (44 325.15 31555.956) - (29 60.93 4443.417) - (18 155.12 67555.328) - (17 288.79 4562.452) - (16 198.04 62894.029) - (14 199.76 31436.921) - (12 95.39 14577.848) - (12 287.11 31931.756) - (12 320.81 34777.259) - (9 227.73 1222.114) - (8 15.45 16859.074))) - -;;;###autoload -(defun solar-equinoxes-solstices () - "*local* date and time of equinoxes and solstices, if visible in the calendar window. -Requires floating point." - (let ((m displayed-month) - (y displayed-year)) - (increment-calendar-month m y (cond ((= 1 (% m 3)) -1) - ((= 2 (% m 3)) 1) - (t 0))) - (let* ((calendar-standard-time-zone-name - (if calendar-time-zone calendar-standard-time-zone-name "UTC")) - (calendar-daylight-savings-starts - (if calendar-time-zone calendar-daylight-savings-starts)) - (calendar-daylight-savings-ends - (if calendar-time-zone calendar-daylight-savings-ends)) - (calendar-time-zone (if calendar-time-zone calendar-time-zone 0)) - (k (1- (/ m 3))) - (d0 (solar-equinoxes/solstices k y)) - (d1 (list (car d0) (floor (car (cdr d0))) (car (cdr (cdr d0))))) - (h0 (* 24 (- (car (cdr d0)) (floor (car (cdr d0)))))) - (adj (dst-adjust-time d1 h0)) - (d (list (car d1) (+ (car (cdr d1)) - (/ (car (cdr adj)) 24.0)) - (car (cdr (cdr d1))))) - ; The following is nearly as accurate, but not quite: - ;(d0 (solar-date-next-longitude - ; (calendar-astro-from-absolute - ; (calendar-absolute-from-gregorian - ; (list (+ 3 (* k 3)) 15 y))) - ; 90)) - ;(abs-day (calendar-absolute-from-astro d))) - (abs-day (calendar-absolute-from-gregorian d))) - (list - (list (calendar-gregorian-from-absolute (floor abs-day)) - (format "%s %s" - (nth k (if (and calendar-latitude - (< (calendar-latitude) 0)) - solar-s-hemi-seasons - solar-n-hemi-seasons)) - (solar-time-string - (* 24 (- abs-day (floor abs-day))) - (if (dst-in-effect abs-day) - calendar-daylight-time-zone-name - calendar-standard-time-zone-name)))))))) - - -(provide 'solar) - -;;; solar.el ends here |