lisp/calendar/holidays.el

   1 ;;; holidays.el --- holiday functions for the calendar package
   2
   3 ;; Copyright (C) 1989, 90, 92, 93, 94, 1997 Free Software Foundation, Inc.
   4
   5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   6 ;; Keywords: holidays, calendar
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; This collection of functions implements the holiday features as described
  28 ;; in calendar.el.
  29
  30 ;; Technical details of all the calendrical calculations can be found in
  31 ;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold,
  32 ;; Cambridge University Press (1997).
  33
  34 ;; An earlier version of the technical details appeared in
  35 ;; ``Calendrical Calculations'' by Nachum Dershowitz and Edward M. Reingold,
  36 ;; Software--Practice and Experience, Volume 20, Number 9 (September, 1990),
  37 ;; pages 899-928.  ``Calendrical Calculations, Part II: Three Historical
  38 ;; Calendars'' by E. M. Reingold,  N. Dershowitz, and S. M. Clamen,
  39 ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
  40 ;; pages 383-404.
  41
  42 ;; Hard copies of these two papers can be obtained by sending email to
  43 ;; reingold@cs.uiuc.edu with the SUBJECT "send-paper-cal" (no quotes) and
  44 ;; the message BODY containing your mailing address (snail).
  45
  46 ;; Comments, corrections, and improvements should be sent to
  47 ;;  Edward M. Reingold               Department of Computer Science
  48 ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  49 ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  50 ;;                                   Urbana, Illinois 61801
  51
  52 ;;; Code:
  53
  54 (require 'calendar)
  55
  56 (autoload 'holiday-julian "cal-julian"
  57   "Holiday on MONTH, DAY  (Julian) called STRING."
  58   t)
  59
  60 (autoload 'holiday-hebrew "cal-hebrew"
  61   "Holiday on MONTH, DAY (Hebrew) called STRING."
  62   t)
  63
  64 (autoload 'holiday-rosh-hashanah-etc "cal-hebrew"
  65   "List of dates related to Rosh Hashanah, as visible in calendar window."
  66   t)
  67
  68 (autoload 'holiday-hanukkah "cal-hebrew"
  69   "List of dates related to Hanukkah, as visible in calendar window."
  70   t)
  71
  72 (autoload 'holiday-passover-etc "cal-hebrew"
  73   "List of dates related to Passover, as visible in calendar window."
  74   t)
  75
  76 (autoload 'holiday-tisha-b-av-etc "cal-hebrew"
  77   "List of dates around Tisha B'Av, as visible in calendar window."
  78   t)
  79
  80 (autoload 'holiday-islamic "cal-islam"
  81   "Holiday on MONTH, DAY (Islamic) called STRING."
  82   t)
  83
  84 (autoload 'holiday-chinese-new-year "cal-china"
  85   "Date of Chinese New Year."
  86   t)
  87
  88 (autoload 'solar-equinoxes-solstices "solar"
  89   "Date and time of equinoxes and solstices, if visible in the calendar window.
  90 Requires floating point."
  91   t)
  92
  93 ;;;###autoload
  94 (defun holidays (&optional arg)
  95   "Display the holidays for last month, this month, and next month.
  96 If called with an optional prefix argument, prompts for month and year.
  97
  98 This function is suitable for execution in a .emacs file."
  99   (interactive "P")
 100   (save-excursion
 101     (let* ((completion-ignore-case t)
 102            (date (if arg
 103                      (calendar-read-date t)
 104                    (calendar-current-date)))
 105            (displayed-month (extract-calendar-month date))
 106            (displayed-year (extract-calendar-year date)))
 107       (list-calendar-holidays))))
 108
 109 ;;;###autoload
 110 (defun list-holidays (y1 y2 &optional l label)
 111   "Display holidays for years Y1 to Y2 (inclusive).
 112
 113 The optional list of holidays L defaults to `calendar-holidays'.  See the
 114 documentation for that variable for a description of holiday lists.
 115
 116 The optional LABEL is used to label the buffer created."
 117   (interactive
 118    (let* ((start-year (calendar-read
 119                        "Starting year of holidays (>0): "
 120                        '(lambda (x) (> x 0))
 121                        (int-to-string (extract-calendar-year
 122                                        (calendar-current-date)))))
 123           (end-year (calendar-read
 124                        (format "Ending year (inclusive) of holidays (>=%s): "
 125                                start-year)
 126                        '(lambda (x) (>= x start-year))
 127                        (int-to-string start-year)))
 128           (completion-ignore-case t)
 129           (lists
 130            (list
 131             (cons "All" calendar-holidays)
 132             (if (fboundp 'atan)
 133                 (cons "Equinoxes/Solstices"
 134                       (list (list 'solar-equinoxes-solstices))))
 135             (if general-holidays (cons "General" general-holidays))
 136             (if local-holidays (cons "Local" local-holidays))
 137             (if other-holidays (cons "Other" other-holidays))
 138             (if christian-holidays (cons "Christian" christian-holidays))
 139             (if hebrew-holidays (cons "Hebrew" hebrew-holidays))
 140             (if islamic-holidays (cons "Islamic" islamic-holidays))
 141             (if oriental-holidays (cons "Oriental" oriental-holidays))
 142             (if solar-holidays (cons "Solar" solar-holidays))
 143             (cons "Ask" nil)))
 144           (choice (capitalize
 145                    (completing-read "List (TAB for choices): " lists nil t)))
 146           (which (if (string-equal choice "Ask")
 147                      (eval (read-variable "Enter list name: "))
 148                    (cdr (assoc choice lists))))
 149           (name (if (string-equal choice "Equinoxes/Solstices")
 150                     choice
 151                   (if (member choice '("Ask" ""))
 152                       "Holidays"
 153                     (format "%s Holidays" choice)))))
 154      (list start-year end-year which name)))
 155   (message "Computing holidays...")
 156   (let* ((holiday-buffer "*Holidays*")
 157          (calendar-holidays (if l l calendar-holidays))
 158          (title (or label "Holidays"))
 159          (holiday-list nil)
 160          (s (calendar-absolute-from-gregorian (list 2 1 y1)))
 161          (e (calendar-absolute-from-gregorian (list 11 1 y2)))
 162          (d s)
 163          (never t)
 164          (displayed-month 2)
 165          (displayed-year y1))
 166     (while (or never (<= d e))
 167       (setq holiday-list (append holiday-list (calendar-holiday-list)))
 168       (setq never nil)
 169       (increment-calendar-month displayed-month displayed-year 3)
 170       (setq d (calendar-absolute-from-gregorian
 171                (list displayed-month 1 displayed-year))))
 172     (save-excursion
 173       (set-buffer (get-buffer-create holiday-buffer))
 174       (setq buffer-read-only nil)
 175       (calendar-set-mode-line
 176        (if (= y1 y2)
 177            (format "%s for %s" title y1)
 178          (format "%s for %s-%s" title y1 y2)))
 179       (erase-buffer)
 180       (goto-char (point-min))
 181       (insert
 182        (mapconcat
 183         '(lambda (x) (concat (calendar-date-string (car x))
 184                              ": " (car (cdr x))))
 185         holiday-list "\n"))
 186       (goto-char (point-min))
 187       (set-buffer-modified-p nil)
 188       (setq buffer-read-only t)
 189       (display-buffer holiday-buffer)
 190       (message "Computing holidays...done"))))
 191
 192
 193 (defun check-calendar-holidays (date)
 194   "Check the list of holidays for any that occur on DATE.
 195 The value returned is a list of strings of relevant holiday descriptions.
 196 The holidays are those in the list calendar-holidays."
 197   (let* ((displayed-month (extract-calendar-month date))
 198          (displayed-year (extract-calendar-year date))
 199          (h (calendar-holiday-list))
 200          (holiday-list))
 201     (while h
 202       (if (calendar-date-equal date (car (car h)))
 203           (setq holiday-list (append holiday-list (cdr (car h)))))
 204       (setq h (cdr h)))
 205     holiday-list))
 206
 207 (defun calendar-cursor-holidays ()
 208   "Find holidays for the date specified by the cursor in the calendar window."
 209   (interactive)
 210   (message "Checking holidays...")
 211   (let* ((date (calendar-cursor-to-date t))
 212          (date-string (calendar-date-string date))
 213          (holiday-list (check-calendar-holidays date))
 214          (holiday-string (mapconcat 'identity holiday-list ";  "))
 215          (msg (format "%s:  %s" date-string holiday-string)))
 216     (if (not holiday-list)
 217         (message "No holidays known for %s" date-string)
 218       (if (<= (length msg) (frame-width))
 219           (message "%s" msg)
 220         (set-buffer (get-buffer-create holiday-buffer))
 221         (setq buffer-read-only nil)
 222         (calendar-set-mode-line date-string)
 223         (erase-buffer)
 224         (insert (mapconcat 'identity holiday-list "\n"))
 225         (goto-char (point-min))
 226         (set-buffer-modified-p nil)
 227         (setq buffer-read-only t)
 228         (display-buffer holiday-buffer)
 229         (message "Checking holidays...done")))))
 230
 231 (defun mark-calendar-holidays ()
 232   "Mark notable days in the calendar window."
 233   (interactive)
 234   (setq mark-holidays-in-calendar t)
 235   (message "Marking holidays...")
 236   (let ((holiday-list (calendar-holiday-list)))
 237     (while holiday-list
 238       (mark-visible-calendar-date
 239        (car (car holiday-list)) calendar-holiday-marker)
 240       (setq holiday-list (cdr holiday-list))))
 241   (message "Marking holidays...done"))
 242
 243 (defun list-calendar-holidays ()
 244   "Create a buffer containing the holidays for the current calendar window.
 245 The holidays are those in the list calendar-notable-days.  Returns t if any
 246 holidays are found, nil if not."
 247   (interactive)
 248   (message "Looking up holidays...")
 249   (let ((holiday-list (calendar-holiday-list))
 250         (m1 displayed-month)
 251         (y1 displayed-year)
 252         (m2 displayed-month)
 253         (y2 displayed-year))
 254     (if (not holiday-list)
 255         (progn
 256           (message "Looking up holidays...none found")
 257           nil)
 258       (set-buffer (get-buffer-create holiday-buffer))
 259       (setq buffer-read-only nil)
 260       (increment-calendar-month m1 y1 -1)
 261       (increment-calendar-month m2 y2 1)
 262       (calendar-set-mode-line
 263        (if (= y1 y2)
 264            (format "Notable Dates from %s to %s, %d%%-"
 265                    (calendar-month-name m1) (calendar-month-name m2) y2)
 266          (format "Notable Dates from %s, %d to %s, %d%%-"
 267                  (calendar-month-name m1) y1 (calendar-month-name m2) y2)))
 268       (erase-buffer)
 269       (insert
 270        (mapconcat
 271         '(lambda (x) (concat (calendar-date-string (car x))
 272                              ": " (car (cdr x))))
 273         holiday-list "\n"))
 274       (goto-char (point-min))
 275       (set-buffer-modified-p nil)
 276       (setq buffer-read-only t)
 277       (display-buffer holiday-buffer)
 278       (message "Looking up holidays...done")
 279       t)))
 280
 281 (defun calendar-holiday-list ()
 282   "Form the list of holidays that occur on dates in the calendar window.
 283 The holidays are those in the list calendar-holidays."
 284   (let ((p calendar-holidays)
 285         (holiday-list))
 286     (while p
 287       (let* ((holidays
 288               (if calendar-debug-sexp
 289                   (let ((stack-trace-on-error t))
 290                     (eval (car p)))
 291                 (condition-case nil
 292                     (eval (car p))
 293                   (error (beep)
 294                          (message "Bad holiday list item: %s" (car p))
 295                          (sleep-for 2))))))
 296         (if holidays
 297             (setq holiday-list (append holidays holiday-list))))
 298       (setq p (cdr p)))
 299     (setq holiday-list (sort holiday-list 'calendar-date-compare))))
 300
 301 ;; Below are the functions that calculate the dates of holidays; these
 302 ;; are eval'ed in the function calendar-holiday-list.  If you
 303 ;; write other such functions, be sure to imitate the style used below.
 304 ;; Remember that each function must return a list of items of the form
 305 ;; ((month day year) string) of VISIBLE dates in the calendar window.
 306
 307 (defun holiday-fixed (month day string)
 308   "Holiday on MONTH, DAY (Gregorian) called STRING.
 309 If MONTH, DAY is visible, the value returned is the list (((MONTH DAY year)
 310 STRING)).  Returns nil if it is not visible in the current calendar window."
 311   (let ((m displayed-month)
 312         (y displayed-year))
 313     (increment-calendar-month m y (- 11 month))
 314     (if (> m 9)
 315       (list (list (list month day y) string)))))
 316
 317 (defun holiday-float (month dayname n string &optional day)
 318   "Holiday on MONTH, DAYNAME (Nth occurrence) called STRING.
 319 If the Nth DAYNAME in MONTH is visible, the value returned is the list
 320 \(((MONTH DAY year) STRING)).
 321
 322 If N<0, count backward from the end of MONTH.
 323
 324 An optional parameter DAY means the Nth DAYNAME on or after/before MONTH DAY.
 325
 326 Returns nil if it is not visible in the current calendar window."
 327 ;; This is messy because the holiday may be visible, while the date on which
 328 ;; it is based is not.  For example, the first Monday after December 30 may be
 329 ;; visible when January is not.  For large values of |n| the problem is more
 330 ;; grotesque.  If we didn't have to worry about such cases, we could just use
 331
 332 ;;  (let ((m displayed-month)
 333 ;;        (y displayed-year))
 334 ;;    (increment-calendar-month m y (- 11 month))
 335 ;;    (if (> m 9); month in year y is visible
 336 ;;      (list (list (calendar-nth-named-day n dayname month y day) string)))))
 337
 338 ;; which is the way the function was originally written.
 339
 340   (let* ((m1 displayed-month)
 341          (y1 displayed-year)
 342          (m2 m1)
 343          (y2 y1))
 344     (increment-calendar-month m1 y1 -1)
 345     (increment-calendar-month m2 y2 1)
 346     (let* ((d1;  first possible base date for holiday
 347             (+ (calendar-nth-named-absday 1 dayname m1 y1)
 348                (* -7 n)
 349                (if (> n 0) 1 -7)))
 350            (d2;  last possible base date for holiday
 351             (+ (calendar-nth-named-absday -1 dayname m2 y2)
 352                (* -7 n)
 353                (if (> n 0) 7 -1)))
 354            (y1 (extract-calendar-year (calendar-gregorian-from-absolute d1)))
 355            (y2 (extract-calendar-year (calendar-gregorian-from-absolute d2)))
 356            (y; year of base date
 357             (if (or (= y1 y2) (> month 9))
 358                   y1
 359                 y2))
 360            (d; day of base date
 361             (or day (if (> n 0)
 362                         1
 363                       (calendar-last-day-of-month month y))))
 364            (date; base date for holiday
 365             (calendar-absolute-from-gregorian (list month d y))))
 366       (if (and (<= d1 date) (<= date d2))
 367           (list (list (calendar-nth-named-day n dayname month y d)
 368                       string))))))
 369
 370 (defun holiday-sexp (sexp string)
 371   "Sexp holiday for dates in the calendar window.
 372 SEXP is an expression in variable `year' evaluates to `date'.
 373
 374 STRING is an expression in `date' that evaluates to the holiday description
 375 of `date'.
 376
 377 If `date' is visible in the calendar window, the holiday STRING is on that
 378 date.  If date is nil, or if the date is not visible, there is no holiday."
 379   (let ((m displayed-month)
 380         (y displayed-year))
 381     (increment-calendar-month m y -1)
 382     (filter-visible-calendar-holidays
 383      (append
 384       (let* ((year y)
 385              (date (eval sexp))
 386              (string (if date (eval string))))
 387         (list (list date string)))
 388       (let* ((year (1+ y))
 389              (date (eval sexp))
 390              (string (if date (eval string))))
 391         (list (list date string)))))))
 392
 393 (defun holiday-advent ()
 394   "Date of Advent, if visible in calendar window."
 395   (let ((year displayed-year)
 396         (month displayed-month))
 397     (increment-calendar-month month year -1)
 398     (let ((advent (calendar-gregorian-from-absolute
 399                    (calendar-dayname-on-or-before 0
 400                     (calendar-absolute-from-gregorian
 401                      (list 12 3 year))))))
 402       (if (calendar-date-is-visible-p advent)
 403           (list (list advent "Advent"))))))
 404
 405 (defun holiday-easter-etc ()
 406   "List of dates related to Easter, as visible in calendar window."
 407  (if (and (> displayed-month 5) (not all-christian-calendar-holidays))
 408      nil;; Ash Wednesday, Good Friday, and Easter are not visible.
 409    (let* ((century (1+ (/ displayed-year 100)))
 410           (shifted-epact        ;; Age of moon for April 5...
 411            (% (+ 14 (* 11 (% displayed-year 19));;     ...by Nicaean rule
 412                  (-           ;; ...corrected for the Gregorian century rule
 413                   (/ (* 3 century) 4))
 414                  (/    ;; ...corrected for Metonic cycle inaccuracy.
 415                   (+ 5 (* 8 century)) 25)
 416                  (* 30 century));;              Keeps value positive.
 417               30))
 418           (adjusted-epact       ;;  Adjust for 29.5 day month.
 419            (if (or (= shifted-epact 0)
 420                    (and (= shifted-epact 1) (< 10 (% displayed-year 19))))
 421                (1+ shifted-epact)
 422              shifted-epact))
 423           (paschal-moon       ;; Day after the full moon on or after March 21.
 424            (- (calendar-absolute-from-gregorian (list 4 19 displayed-year))
 425               adjusted-epact))
 426           (abs-easter (calendar-dayname-on-or-before 0 (+ paschal-moon 7)))
 427           (mandatory
 428            (list
 429             (list (calendar-gregorian-from-absolute abs-easter)
 430                   "Easter Sunday")
 431             (list (calendar-gregorian-from-absolute (- abs-easter 2))
 432                   "Good Friday")
 433             (list (calendar-gregorian-from-absolute (- abs-easter 46))
 434                   "Ash Wednesday")))
 435           (optional
 436            (list
 437             (list (calendar-gregorian-from-absolute (- abs-easter 63))
 438                   "Septuagesima Sunday")
 439             (list (calendar-gregorian-from-absolute (- abs-easter 56))
 440                   "Sexagesima Sunday")
 441             (list (calendar-gregorian-from-absolute (- abs-easter 49))
 442                   "Shrove Sunday")
 443             (list (calendar-gregorian-from-absolute (- abs-easter 48))
 444                   "Shrove Monday")
 445             (list (calendar-gregorian-from-absolute (- abs-easter 47))
 446                   "Shrove Tuesday")
 447             (list (calendar-gregorian-from-absolute (- abs-easter 14))
 448                   "Passion Sunday")
 449             (list (calendar-gregorian-from-absolute (- abs-easter 7))
 450                   "Palm Sunday")
 451             (list (calendar-gregorian-from-absolute (- abs-easter 3))
 452                   "Maundy Thursday")
 453             (list (calendar-gregorian-from-absolute (+ abs-easter 35))
 454                   "Rogation Sunday")
 455             (list (calendar-gregorian-from-absolute (+ abs-easter 39))
 456                   "Ascension Day")
 457             (list (calendar-gregorian-from-absolute (+ abs-easter 49))
 458                   "Pentecost (Whitsunday)")
 459             (list (calendar-gregorian-from-absolute (+ abs-easter 50))
 460                   "Whitmonday")
 461             (list (calendar-gregorian-from-absolute (+ abs-easter 56))
 462                   "Trinity Sunday")
 463             (list (calendar-gregorian-from-absolute (+ abs-easter 60))
 464                   "Corpus Christi")))
 465           (output-list
 466            (filter-visible-calendar-holidays mandatory)))
 467      (if all-christian-calendar-holidays
 468          (setq output-list
 469                (append
 470                 (filter-visible-calendar-holidays optional)
 471                 output-list)))
 472      output-list)))
 473
 474 (defun holiday-greek-orthodox-easter ()
 475   "Date of Easter according to the rule of the Council of Nicaea."
 476   (let ((m displayed-month)
 477         (y displayed-year))
 478     (increment-calendar-month m y 1)
 479     (let* ((julian-year
 480             (extract-calendar-year
 481              (calendar-julian-from-absolute
 482               (calendar-absolute-from-gregorian
 483                (list m (calendar-last-day-of-month m y) y)))))
 484            (shifted-epact ;; Age of moon for April 5.
 485             (% (+ 14
 486                   (* 11 (% julian-year 19)))
 487                30))
 488            (paschal-moon  ;; Day after full moon on or after March 21.
 489             (- (calendar-absolute-from-julian (list 4 19 julian-year))
 490                shifted-epact))
 491            (nicaean-easter;; Sunday following the Paschal moon
 492             (calendar-gregorian-from-absolute
 493              (calendar-dayname-on-or-before 0 (+ paschal-moon 7)))))
 494       (if (calendar-date-is-visible-p nicaean-easter)
 495           (list (list nicaean-easter "Pascha (Greek Orthodox Easter)"))))))
 496
 497 (defun filter-visible-calendar-holidays (l)
 498   "Return a list of all visible holidays of those on L."
 499   (let ((visible)
 500         (p l))
 501     (while p
 502       (and (car (car p))
 503            (calendar-date-is-visible-p (car (car p)))
 504            (setq visible (append (list (car p)) visible)))
 505       (setq p (cdr p)))
 506     visible))
 507
 508 (provide 'holidays)
 509
 510 ;;; holidays.el ends here