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