lisp/calendar/holidays.el

   1 ;;; holidays.el --- holiday functions for the calendar package
   2
   3 ;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1997, 2001, 2002, 2003,
   4 ;;   2004, 2005, 2006, 2007, 2008  Free Software Foundation, Inc.
   5
   6 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   7 ;; Maintainer: Glenn Morris <rgm@gnu.org>
   8 ;; Keywords: holidays, calendar
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  25 ;; Boston, MA 02110-1301, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; See calendar.el.
  30
  31 ;;; Code:
  32
  33 (require 'calendar)
  34 (require 'hol-loaddefs)
  35
  36 ;;;###diary-autoload
  37 (defun calendar-holiday-list ()
  38   "Form the list of holidays that occur on dates in the calendar window.
  39 The holidays are those in the list `calendar-holidays'."
  40   (let (res h)
  41     (sort
  42      (dolist (p calendar-holidays res)
  43        (if (setq h (if calendar-debug-sexp
  44                        (let ((stack-trace-on-error t))
  45                          (eval p))
  46                      (condition-case nil
  47                          (eval p)
  48                        (error (beep)
  49                               (message "Bad holiday list item: %s" p)
  50                               (sleep-for 2)))))
  51            (setq res (append h res))))
  52      'calendar-date-compare)))
  53
  54 (defvar displayed-month)                ; from generate-calendar
  55 (defvar displayed-year)
  56
  57 ;;;###cal-autoload
  58 (defun calendar-list-holidays ()
  59   "Create a buffer containing the holidays for the current calendar window.
  60 The holidays are those in the list `calendar-notable-days'.
  61 Returns non-nil if any holidays are found."
  62   (interactive)
  63   (message "Looking up holidays...")
  64   (let ((holiday-list (calendar-holiday-list))
  65         (m1 displayed-month)
  66         (y1 displayed-year)
  67         (m2 displayed-month)
  68         (y2 displayed-year))
  69     (if (not holiday-list)
  70         (message "Looking up holidays...none found")
  71       (calendar-in-read-only-buffer holiday-buffer
  72         (increment-calendar-month m1 y1 -1)
  73         (increment-calendar-month m2 y2 1)
  74         (calendar-set-mode-line
  75          (if (= y1 y2)
  76              (format "Notable Dates from %s to %s, %d%%-"
  77                      (calendar-month-name m1) (calendar-month-name m2) y2)
  78            (format "Notable Dates from %s, %d to %s, %d%%-"
  79                    (calendar-month-name m1) y1 (calendar-month-name m2) y2)))
  80         (insert
  81          (mapconcat
  82           (lambda (x) (concat (calendar-date-string (car x))
  83                               ": " (cadr x)))
  84           holiday-list "\n")))
  85       (message "Looking up holidays...done"))
  86     holiday-list))
  87
  88 (define-obsolete-function-alias
  89   'list-calendar-holidays 'calendar-list-holidays "23.1")
  90
  91 ;;;###autoload
  92 (defun holidays (&optional arg)
  93   "Display the holidays for last month, this month, and next month.
  94 If called with an optional prefix argument ARG, prompts for month and year.
  95 This function is suitable for execution in a .emacs file."
  96   (interactive "P")
  97   (save-excursion
  98     (let* ((completion-ignore-case t)
  99            (date (if arg (calendar-read-date t)
 100                    (calendar-current-date)))
 101            (displayed-month (extract-calendar-month date))
 102            (displayed-year (extract-calendar-year date)))
 103       (calendar-list-holidays))))
 104
 105 ;; rms: "Emacs commands to display a list of something generally start
 106 ;; with `list-'.  Please make `list-holidays' the principal name."
 107 ;;;###autoload
 108 (defun list-holidays (y1 &optional y2 l label)
 109   "Display holidays for years Y1 to Y2 (inclusive).
 110 Y2 defaults to Y1.  The optional list of holidays L defaults to
 111 `calendar-holidays'.  If you want to control what holidays are
 112 displayed, use a different list.  For example,
 113
 114   (list-holidays 2006 2006
 115     (append general-holidays local-holidays other-holidays))
 116
 117 will display holidays for the year 2006 defined in the 3
 118 mentioned lists, and nothing else.
 119
 120 When called interactively, this command offers a choice of
 121 holidays, based on the variables `solar-holidays' etc.  See the
 122 documentation of `calendar-holidays' for a list of the variables
 123 that control the choices, as well as a description of the format
 124 of a holiday list.
 125
 126 The optional LABEL is used to label the buffer created."
 127   (interactive
 128    (let* ((start-year (calendar-read
 129                        "Starting year of holidays (>0): "
 130                        (lambda (x) (> x 0))
 131                        (int-to-string (extract-calendar-year
 132                                        (calendar-current-date)))))
 133           (end-year (calendar-read
 134                      (format "Ending year (inclusive) of holidays (>=%s): "
 135                              start-year)
 136                      (lambda (x) (>= x start-year))
 137                      (int-to-string start-year)))
 138           (completion-ignore-case t)
 139           (lists
 140            (list
 141             (cons "All" calendar-holidays)
 142             (cons "Equinoxes/Solstices"
 143                   (list (list 'solar-equinoxes-solstices)))
 144             (if general-holidays (cons "General" general-holidays))
 145             (if local-holidays (cons "Local" local-holidays))
 146             (if other-holidays (cons "Other" other-holidays))
 147             (if christian-holidays (cons "Christian" christian-holidays))
 148             (if hebrew-holidays (cons "Hebrew" hebrew-holidays))
 149             (if islamic-holidays (cons "Islamic" islamic-holidays))
 150             (if bahai-holidays (cons "Baha'i" bahai-holidays))
 151             (if oriental-holidays (cons "Oriental" oriental-holidays))
 152             (if solar-holidays (cons "Solar" solar-holidays))
 153             (cons "Ask" nil)))
 154           (choice (capitalize
 155                    (completing-read "List (TAB for choices): " lists nil t)))
 156           (which (if (string-equal choice "Ask")
 157                      (eval (read-variable "Enter list name: "))
 158                    (cdr (assoc choice lists))))
 159           (name (if (string-equal choice "Equinoxes/Solstices")
 160                     choice
 161                   (if (member choice '("Ask" ""))
 162                       "Holidays"
 163                     (format "%s Holidays" choice)))))
 164      (list start-year end-year which name)))
 165   (unless y2 (setq y2 y1))
 166   (message "Computing holidays...")
 167   (let ((calendar-holidays (or l calendar-holidays))
 168         (title (or label "Holidays"))
 169         (s (calendar-absolute-from-gregorian (list 2 1 y1)))
 170         (e (calendar-absolute-from-gregorian (list 11 1 y2)))
 171         (displayed-month 2)
 172         (displayed-year y1)
 173         holiday-list)
 174     (while (<= s e)
 175       (setq holiday-list (append holiday-list (calendar-holiday-list)))
 176       (increment-calendar-month displayed-month displayed-year 3)
 177       (setq s (calendar-absolute-from-gregorian
 178                (list displayed-month 1 displayed-year))))
 179     (save-excursion
 180       (calendar-in-read-only-buffer holiday-buffer
 181         (calendar-set-mode-line
 182          (if (= y1 y2)
 183              (format "%s for %s" title y1)
 184            (format "%s for %s-%s" title y1 y2)))
 185         (insert
 186          (mapconcat
 187           (lambda (x) (concat (calendar-date-string (car x))
 188                               ": " (cadr x)))
 189           holiday-list "\n")))
 190       (message "Computing holidays...done"))))
 191
 192 ;;;###autoload
 193 (defalias 'holiday-list 'list-holidays)
 194
 195 ;;;###diary-autoload
 196 (defun calendar-check-holidays (date)
 197   "Check the list of holidays for any that occur on DATE.
 198 The value returned is a list of strings of relevant holiday descriptions.
 199 The holidays are those in the list `calendar-holidays'."
 200   (let ((displayed-month (extract-calendar-month date))
 201         (displayed-year (extract-calendar-year date))
 202         holiday-list)
 203     (dolist (h (calendar-holiday-list) holiday-list)
 204       (if (calendar-date-equal date (car h))
 205           (setq holiday-list (append holiday-list (cdr h)))))))
 206
 207 (define-obsolete-function-alias
 208   'check-calendar-holidays 'calendar-check-holidays "23.1")
 209
 210 ;;;###cal-autoload
 211 (defun calendar-cursor-holidays ()
 212   "Find holidays for the date specified by the cursor in the calendar window."
 213   (interactive)
 214   (message "Checking holidays...")
 215   (let* ((date (calendar-cursor-to-date t))
 216          (date-string (calendar-date-string date))
 217          (holiday-list (calendar-check-holidays date))
 218          (holiday-string (mapconcat 'identity holiday-list ";  "))
 219          (msg (format "%s:  %s" date-string holiday-string)))
 220     (if (not holiday-list)
 221         (message "No holidays known for %s" date-string)
 222       (if (<= (length msg) (frame-width))
 223           (message "%s" msg)
 224         (calendar-in-read-only-buffer holiday-buffer
 225           (calendar-set-mode-line date-string)
 226           (insert (mapconcat 'identity holiday-list "\n")))
 227         (message "Checking holidays...done")))))
 228
 229 ;;;###cal-autoload
 230 (defun calendar-mark-holidays ()
 231   "Mark notable days in the calendar window."
 232   (interactive)
 233   (setq mark-holidays-in-calendar t)
 234   (message "Marking holidays...")
 235   (dolist (holiday (calendar-holiday-list))
 236     (mark-visible-calendar-date (car holiday) calendar-holiday-marker))
 237   (message "Marking holidays...done"))
 238
 239 (define-obsolete-function-alias
 240   'mark-calendar-holidays 'calendar-mark-holidays "23.1")
 241
 242 ;; Below are the functions that calculate the dates of holidays; these
 243 ;; are eval'ed in the function calendar-holiday-list.  If you
 244 ;; write other such functions, be sure to imitate the style used below.
 245 ;; Remember that each function must return a list of items of the form
 246 ;; ((month day year) string) of VISIBLE dates in the calendar window.
 247
 248 (defun holiday-fixed (month day string)
 249   "Holiday on MONTH, DAY (Gregorian) called STRING.
 250 If MONTH, DAY is visible, the value returned is the list (((MONTH DAY year)
 251 STRING)).  Returns nil if it is not visible in the current calendar window."
 252   ;; This determines whether a given month is visible in the calendar.
 253   ;; cf calendar-date-is-visible-p (which also checks the year part).
 254   ;; The day is irrelevant since only full months are displayed.
 255   ;; Since the calendar displays three months at a time, month N
 256   ;; is visible if displayed-month = N-1, N, N+1.
 257   ;; In particular, November is visible if d-m = 10, 11, 12.
 258   ;; This is useful, because we can do a one-sided test:
 259   ;; November is visible if d-m > 9. (Similarly, February is visible if
 260   ;; d-m < 4.)
 261   ;; To determine if December is visible, we can shift the calendar
 262   ;; back a month and ask if November is visible; to determine if
 263   ;; October is visible, we can shift it forward a month and ask if
 264   ;; November is visible; etc.
 265   (let ((m displayed-month)
 266         (y displayed-year))
 267     (increment-calendar-month m y (- 11 month))
 268     (if (> m 9)                         ; is november visible?
 269         (list (list (list month day y) string)))))
 270
 271 (defun holiday-float (month dayname n string &optional day)
 272   "Holiday on MONTH, DAYNAME (Nth occurrence) called STRING.
 273 If the Nth DAYNAME in MONTH is visible, the value returned is the list
 274 \(((MONTH DAY year) STRING)).
 275
 276 If N<0, count backward from the end of MONTH.
 277
 278 An optional parameter DAY means the Nth DAYNAME on or after/before MONTH DAY.
 279
 280 Returns nil if it is not visible in the current calendar window."
 281   ;; This is messy because the holiday may be visible, while the date
 282   ;; on which it is based is not.  For example, the first Monday after
 283   ;; December 30 may be visible when January is not.  For large values
 284   ;; of |n| the problem is more grotesque.  If we didn't have to worry
 285   ;; about such cases, we could just use the original version of this
 286   ;; function:
 287   ;;  (let ((m displayed-month)
 288   ;;        (y displayed-year))
 289   ;;    (increment-calendar-month m y (- 11 month))
 290   ;;    (if (> m 9); month in year y is visible
 291   ;;      (list (list (calendar-nth-named-day n dayname month y day) string)))))
 292   (let* ((m1 displayed-month)
 293          (y1 displayed-year)
 294          (m2 displayed-month)
 295          (y2 displayed-year)
 296          (d1 (progn             ; first possible base date for holiday
 297                (increment-calendar-month m1 y1 -1)
 298                (+ (calendar-nth-named-absday 1 dayname m1 y1)
 299                   (* -7 n)
 300                   (if (> n 0) 1 -7))))
 301          (d2                     ; last possible base date for holiday
 302           (progn
 303             (increment-calendar-month m2 y2 1)
 304             (+ (calendar-nth-named-absday -1 dayname m2 y2)
 305                (* -7 n)
 306                (if (> n 0) 7 -1))))
 307          (y1 (extract-calendar-year (calendar-gregorian-from-absolute d1)))
 308          (y2 (extract-calendar-year (calendar-gregorian-from-absolute d2)))
 309          (y                             ; year of base date
 310           (if (or (= y1 y2) (> month 9))
 311               y1
 312             y2))
 313          (d                             ; day of base date
 314           (or day (if (> n 0)
 315                       1
 316                     (calendar-last-day-of-month month y))))
 317          (date                        ; base date for holiday
 318           (calendar-absolute-from-gregorian (list month d y))))
 319     (and (<= d1 date) (<= date d2)
 320          (list (list (calendar-nth-named-day n dayname month y d)
 321                      string)))))
 322
 323 (defun holiday-filter-visible-calendar (hlist)
 324   "Filter list of holidays HLIST, and return only the visible ones.
 325 HLIST is a list of elements of the form (DATE) TEXT."
 326   (delq nil (mapcar (lambda (p)
 327                       (and (car p) (calendar-date-is-visible-p (car p)) p))
 328                     hlist)))
 329
 330 (define-obsolete-function-alias
 331   'filter-visible-calendar-holidays 'holiday-filter-visible-calendar "23.1")
 332
 333 (defun holiday-sexp (sexp string)
 334   "Sexp holiday for dates in the calendar window.
 335 SEXP is an expression in variable `year' that is evaluated to
 336 give `date'.  STRING is an expression in `date' that evaluates to
 337 the holiday description of `date'.  If `date' is visible in the
 338 calendar window, the holiday STRING is on that date.  If date is
 339 nil, or if the date is not visible, there is no holiday."
 340   (let ((m displayed-month)
 341         (y displayed-year)
 342         year date)
 343     (increment-calendar-month m y -1)
 344     (holiday-filter-visible-calendar
 345      (list
 346       (progn
 347         (setq year y
 348               date (eval sexp))
 349         (list date (if date (eval string))))
 350       (progn
 351         (setq year (1+ y)
 352               date (eval sexp))
 353         (list date (if date (eval string))))))))
 354
 355
 356 (defun holiday-advent (&optional n string)
 357   "Date of Nth day after advent (named STRING), if visible in calendar window.
 358 Negative values of N are interpreted as days before advent.
 359 STRING is used purely for display purposes.  The return value has
 360 the form ((MONTH DAY YEAR) STRING), where the date is that of the
 361 Nth day before or after advent.
 362
 363 For backwards compatibility, if this function is called with no
 364 arguments, then it returns the value appropriate for advent itself."
 365   ;; Backwards compatibility layer.
 366   (if (not n)
 367       (holiday-advent 0 "Advent")
 368     (let* ((year displayed-year)
 369            (month displayed-month)
 370            (advent (progn
 371                      (increment-calendar-month month year -1)
 372                      (calendar-gregorian-from-absolute
 373                       (+ n
 374                          (calendar-dayname-on-or-before
 375                           0
 376                           (calendar-absolute-from-gregorian
 377                            (list 12 3 year))))))))
 378       (if (calendar-date-is-visible-p advent)
 379           (list (list advent string))))))
 380
 381 (defun holiday-easter-etc (&optional n string)
 382   "Date of Nth day after Easter (named STRING), if visible in calendar window.
 383 Negative values of N are interpreted as days before Easter.
 384 STRING is used purely for display purposes.  The return value has
 385 the form ((MONTH DAY YEAR) STRING), where the date is that of the
 386 Nth day before or after Easter.
 387
 388 For backwards compatibility, if this function is called with no
 389 arguments, then it returns a list of \"standard\" Easter-related
 390 holidays (with more entries if `calendar-christian-all-holidays-flag'
 391 is non-nil)."
 392   ;; Backwards compatibility layer.
 393   (if (not n)
 394       (apply 'append
 395              (mapcar (lambda (e)
 396                        (apply 'holiday-easter-etc e))
 397                      ;; The combined list is not in order.
 398                      (append
 399                       (if calendar-christian-all-holidays-flag
 400                           '((-63 "Septuagesima Sunday")
 401                             (-56 "Sexagesima Sunday")
 402                             (-49 "Shrove Sunday")
 403                             (-48 "Shrove Monday")
 404                             (-47 "Shrove Tuesday")
 405                             (-14 "Passion Sunday")
 406                             (-7 "Palm Sunday")
 407                             (-3 "Maundy Thursday")
 408                             (35 "Rogation Sunday")
 409                             (39 "Ascension Day")
 410                             (49 "Pentecost (Whitsunday)")
 411                             (50 "Whitmonday")
 412                             (56 "Trinity Sunday")
 413                             (60 "Corpus Christi")))
 414                       '((-46 "Ash Wednesday")
 415                         (-2 "Good Friday")
 416                         (0 "Easter Sunday")))))
 417     (let* ((century (1+ (/ displayed-year 100)))
 418            (shifted-epact               ; age of moon for April 5...
 419             (% (+ 14 (* 11 (% displayed-year 19)) ; ...by Nicaean rule
 420                   (-     ; ...corrected for the Gregorian century rule
 421                    (/ (* 3 century) 4))
 422                   (/       ; ...corrected for Metonic cycle inaccuracy
 423                    (+ 5 (* 8 century)) 25)
 424                   (* 30 century))       ; keeps value positive
 425                30))
 426            (adjusted-epact              ; adjust for 29.5 day month
 427             (if (or (zerop shifted-epact)
 428                     (and (= shifted-epact 1) (< 10 (% displayed-year 19))))
 429                 (1+ shifted-epact)
 430               shifted-epact))
 431            (paschal-moon ; day after the full moon on or after March 21
 432             (- (calendar-absolute-from-gregorian (list 4 19 displayed-year))
 433                adjusted-epact))
 434            (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7)))
 435            (greg (calendar-gregorian-from-absolute (+ abs-easter n))))
 436       (if (calendar-date-is-visible-p greg)
 437           (list (list greg string))))))
 438
 439 ;; Prior call to calendar-julian-from-absolute will autoload cal-julian.
 440 (declare-function calendar-julian-to-absolute "cal-julian" (date))
 441
 442 (defun holiday-greek-orthodox-easter ()
 443   "Date of Easter according to the rule of the Council of Nicaea."
 444   (let* ((m displayed-month)
 445          (y displayed-year)
 446          (julian-year (progn
 447                         (increment-calendar-month m y 1)
 448                         (extract-calendar-year
 449                          (calendar-julian-from-absolute
 450                           (calendar-absolute-from-gregorian
 451                            (list m (calendar-last-day-of-month m y) y))))))
 452          (shifted-epact                 ; age of moon for April 5
 453           (% (+ 14
 454                 (* 11 (% julian-year 19)))
 455              30))
 456          (paschal-moon      ; day after full moon on or after March 21
 457           (- (calendar-julian-to-absolute (list 4 19 julian-year))
 458              shifted-epact))
 459          (nicaean-easter           ; Sunday following the Paschal moon
 460           (calendar-gregorian-from-absolute
 461            (calendar-dayname-on-or-before 0 (+ paschal-moon 7)))))
 462     (if (calendar-date-is-visible-p nicaean-easter)
 463         (list (list nicaean-easter "Pascha (Greek Orthodox Easter)")))))
 464
 465 (provide 'holidays)
 466
 467 ;; arch-tag: 48eb3117-75a7-4dbe-8fd9-873c3cbb0d37
 468 ;;; holidays.el ends here