X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/a1506d2977a8c2eb982ad0b59416009cdfaa6f51..5fceaf9cab889a1c15d332f1a6485faec0bfda5e:/lisp/calendar/holidays.el diff --git a/lisp/calendar/holidays.el b/lisp/calendar/holidays.el index c6e7f11c7c..eaa6e4cb47 100644 --- a/lisp/calendar/holidays.el +++ b/lisp/calendar/holidays.el @@ -1,15 +1,17 @@ ;;; holidays.el --- holiday functions for the calendar package -;; Copyright (C) 1989, 90, 92, 93, 94, 1997 Free Software Foundation, Inc. +;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1997, 2001, 2002, 2003, +;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. ;; Author: Edward M. Reingold +;; Maintainer: Glenn Morris ;; 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) +;; the Free Software Foundation; either version 3, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, @@ -19,8 +21,8 @@ ;; 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. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: @@ -28,8 +30,8 @@ ;; in calendar.el. ;; Technical details of all the calendrical calculations can be found in -;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, -;; Cambridge University Press (1997). +;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold +;; and Nachum Dershowitz, Cambridge University Press (2001). ;; An earlier version of the technical details appeared in ;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold, @@ -43,14 +45,11 @@ ;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and ;; the message BODY containing your mailing address (snail). -;; 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: +(defvar displayed-month) +(defvar displayed-year) + (require 'calendar) (autoload 'holiday-julian "cal-julian" @@ -81,6 +80,10 @@ "Holiday on MONTH, DAY (Islamic) called STRING." t) +(autoload 'holiday-bahai "cal-bahai" + "Holiday on MONTH, DAY (Baha'i) called STRING." + t) + (autoload 'holiday-chinese-new-year "cal-china" "Date of Chinese New Year." t) @@ -104,14 +107,29 @@ This function is suitable for execution in a .emacs file." (calendar-current-date))) (displayed-month (extract-calendar-month date)) (displayed-year (extract-calendar-year date))) - (list-calendar-holidays)))) + (calendar-list-holidays)))) +;; rms: "Emacs commands to display a list of something generally start +;; with `list-'. Please make `list-holidays' the principal name." ;;;###autoload (defun list-holidays (y1 y2 &optional l label) "Display holidays for years Y1 to Y2 (inclusive). -The optional list of holidays L defaults to `calendar-holidays'. See the -documentation for that variable for a description of holiday lists. +The optional list of holidays L defaults to `calendar-holidays'. +If you want to control what holidays are displayed, use a +different list. For example, + + (list-holidays 2006 2006 + (append general-holidays local-holidays other-holidays)) + +will display holidays for the year 2006 defined in the 3 +mentioned lists, and nothing else. + +When called interactively, this command offers a choice of +holidays, based on the variables `solar-holidays' etc. See the +documentation of `calendar-holidays' for a list of the variables +that control the choices, as well as a description of the format +of a holiday list. The optional LABEL is used to label the buffer created." (interactive @@ -138,6 +156,7 @@ The optional LABEL is used to label the buffer created." (if christian-holidays (cons "Christian" christian-holidays)) (if hebrew-holidays (cons "Hebrew" hebrew-holidays)) (if islamic-holidays (cons "Islamic" islamic-holidays)) + (if bahai-holidays (cons "Baha'i" bahai-holidays)) (if oriental-holidays (cons "Oriental" oriental-holidays)) (if solar-holidays (cons "Solar" solar-holidays)) (cons "Ask" nil))) @@ -189,19 +208,18 @@ The optional LABEL is used to label the buffer created." (display-buffer holiday-buffer) (message "Computing holidays...done")))) +(defalias 'holiday-list 'list-holidays) -(defun check-calendar-holidays (date) +(defun calendar-check-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))) +The holidays are those in the list `calendar-holidays'." + (let ((displayed-month (extract-calendar-month date)) + (displayed-year (extract-calendar-year date)) + (holiday-list)) + (dolist (h (calendar-holiday-list)) + (if (calendar-date-equal date (car h)) + (setq holiday-list (append holiday-list (cdr h))))) holiday-list)) (defun calendar-cursor-holidays () @@ -210,7 +228,7 @@ The holidays are those in the list calendar-holidays." (message "Checking holidays...") (let* ((date (calendar-cursor-to-date t)) (date-string (calendar-date-string date)) - (holiday-list (check-calendar-holidays date)) + (holiday-list (calendar-check-holidays date)) (holiday-string (mapconcat 'identity holiday-list "; ")) (msg (format "%s: %s" date-string holiday-string))) (if (not holiday-list) @@ -228,21 +246,19 @@ The holidays are those in the list calendar-holidays." (display-buffer holiday-buffer) (message "Checking holidays...done"))))) -(defun mark-calendar-holidays () +(defun calendar-mark-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)))) + (dolist (holiday (calendar-holiday-list)) + (mark-visible-calendar-date + (car holiday) calendar-holiday-marker)) (message "Marking holidays...done")) -(defun list-calendar-holidays () +(defun calendar-list-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 +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...") @@ -280,22 +296,20 @@ holidays are found, nil if not." (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 +The holidays are those in the list `calendar-holidays'." + (let ((holiday-list ())) + (dolist (p calendar-holidays) (let* ((holidays (if calendar-debug-sexp (let ((stack-trace-on-error t)) - (eval (car p))) + (eval p)) (condition-case nil - (eval (car p)) + (eval p) (error (beep) - (message "Bad holiday list item: %s" (car p)) + (message "Bad holiday list item: %s" p) (sleep-for 2)))))) (if holidays - (setq holiday-list (append holidays holiday-list)))) - (setq p (cdr p))) + (setq holiday-list (append holidays holiday-list))))) (setq holiday-list (sort holiday-list 'calendar-date-compare)))) ;; Below are the functions that calculate the dates of holidays; these @@ -379,97 +393,99 @@ 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 + (holiday-filter-visible-calendar + (list (let* ((year y) (date (eval sexp)) (string (if date (eval string)))) - (list (list date string))) + (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))) + (list date string)))))) + +(defun holiday-advent (&optional n string) + "Date of Nth day after advent (named STRING), if visible in calendar window. +Negative values of N are interpreted as days before advent. +STRING is used purely for display purposes. The return value has +the form ((MONTH DAY YEAR) STRING), where the date is that of the +Nth day before or after advent. + +For backwards compatibility, if this function is called with no +arguments, then it returns the value appropriate for advent itself." + ;; Backwards compatibility layer. + (if (not n) + (holiday-advent 0 "Advent") + (let ((year displayed-year) + (month displayed-month)) + (increment-calendar-month month year -1) + (let ((advent (calendar-gregorian-from-absolute + (+ n + (calendar-dayname-on-or-before + 0 + (calendar-absolute-from-gregorian + (list 12 3 year))))))) + (if (calendar-date-is-visible-p advent) + (list (list advent string))))))) + +(defun holiday-easter-etc (&optional n string) + "Date of Nth day after Easter (named STRING), if visible in calendar window. +Negative values of N are interpreted as days before Easter. +STRING is used purely for display purposes. The return value has +the form ((MONTH DAY YEAR) STRING), where the date is that of the +Nth day before or after Easter. + +For backwards compatibility, if this function is called with no +arguments, then it returns a list of \"standard\" Easter-related +holidays (with more entries if `all-christian-calendar-holidays' +is non-nil)." + ;; Backwards compatibility layer. + (if (not n) + (let (res-list res) + (dolist (elem (append + (if all-christian-calendar-holidays + '((-63 . "Septuagesima Sunday") + (-56 . "Sexagesima Sunday") + (-49 . "Shrove Sunday") + (-48 . "Shrove Monday") + (-47 . "Shrove Tuesday") + (-14 . "Passion Sunday") + (-7 . "Palm Sunday") + (-3 . "Maundy Thursday") + (35 . "Rogation Sunday") + (39 . "Ascension Day") + (49 . "Pentecost (Whitsunday)") + (50 . "Whitmonday") + (56 . "Trinity Sunday") + (60 . "Corpus Christi"))) + '((0 . "Easter Sunday") + (-2 . "Good Friday") + (-46 . "Ash Wednesday"))) + res-list) + ;; Filter out nil (not visible) values. + (if (setq res (holiday-easter-etc (car elem) (cdr elem))) + (setq res-list (append res res-list))))) + (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 (zerop shifted-epact) + (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)))) + (holiday-filter-visible-calendar + (list (list (calendar-gregorian-from-absolute (+ abs-easter n)) + string)))))) (defun holiday-greek-orthodox-easter () "Date of Easter according to the rule of the Council of Nicaea." @@ -494,17 +510,28 @@ date. If date is nil, or if the date is not visible, there is no holiday." (if (calendar-date-is-visible-p nicaean-easter) (list (list nicaean-easter "Pascha (Greek Orthodox Easter)")))))) -(defun filter-visible-calendar-holidays (l) +(defun holiday-filter-visible-calendar (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))) + (let ((visible ())) + (dolist (p l) + (and (car p) + (calendar-date-is-visible-p (car p)) + (push p visible))) visible)) +;; Backward compatibility. +(define-obsolete-function-alias + 'filter-visible-calendar-holidays 'holiday-filter-visible-calendar "23.1") +(define-obsolete-function-alias + 'list-calendar-holidays 'calendar-list-holidays "23.1") +(define-obsolete-function-alias + 'mark-calendar-holidays 'calendar-mark-holidays "23.1") +(define-obsolete-function-alias + 'check-calendar-holidays 'calendar-check-holidays "23.1") +;;;###autoload +(define-obsolete-function-alias 'list-holidays 'holiday-list "23.1") + (provide 'holidays) +;; arch-tag: 48eb3117-75a7-4dbe-8fd9-873c3cbb0d37 ;;; holidays.el ends here