lisp/calendar/cal-china.el

   1 ;;; cal-china.el --- calendar functions for the Chinese calendar.
   2
   3 ;; Copyright (C) 1995 Free Software Foundation, Inc.
   4
   5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   6 ;; Keywords: calendar
   7 ;; Human-Keywords: Chinese calendar, calendar, holidays, diary
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation; either version 2, or (at your option)
  14 ;; any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This collection of functions implements the features of calendar.el,
  29 ;; diary.el, and holidays.el that deal with the Chinese calendar.  The rules
  30 ;; used for the Chinese calendar are those of Baolin Liu (see L. E. Doggett's
  31 ;; article "Calendars" in the Explanatory Supplement to the Astronomical
  32 ;; Almanac, second edition, 1992) for the calendar as revised at the beginning
  33 ;; of the Qing dynasty in 1644.  The nature of the astronomical calculations
  34 ;; is such that precise calculations cannot be made without great expense in
  35 ;; time, so that the calendars produced may not agree perfectly with published
  36 ;; tables--but no two pairs of published tables agree perfectly either!  Liu's
  37 ;; rules produce a calendar for 2033 which is not accepted by all authorities.
  38 ;; The date of Chinese New Year is correct from 1644-2051.
  39
  40 ;; Comments, corrections, and improvements should be sent to
  41 ;;  Edward M. Reingold               Department of Computer Science
  42 ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  43 ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  44 ;;                                   Urbana, Illinois 61801
  45
  46 ;;; Code:
  47
  48 (require 'lunar)
  49
  50 (defvar chinese-calendar-celestial-stem
  51   ["Jia" "Yi" "Bing" "Ding" "Wu" "Ji" "Geng" "Xin" "Ren" "Gui"])
  52
  53 (defvar chinese-calendar-terrestrial-branch
  54   ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"])
  55
  56 (defcustom chinese-calendar-time-zone
  57   '(if (< year 1928)
  58        (+ 465 (/ 40.0 60.0))
  59      480)
  60   "*Number of minutes difference between local standard time for Chinese
  61 calendar and Coordinated Universal (Greenwich) Time.  Default is for Beijing.
  62 This is an expression in `year' since it changed at 1928-01-01 00:00:00 from
  63 UT+7:45:40 to UT+8."
  64   :type 'sexp
  65   :group 'chinese-calendar)
  66
  67 (defcustom chinese-calendar-location-name "Beijing"
  68   "*Name of location used for calculation of Chinese calendar."
  69   :type 'string
  70   :group 'chinese-calendar)
  71
  72 (defcustom chinese-calendar-daylight-time-offset 0
  73 ; The correct value is as follows, but the Chinese calendrical
  74 ; authorities do NOT use DST in determining astronomical events:
  75 ;  60
  76   "*Number of minutes difference between daylight savings and standard time
  77 for Chinese calendar.  Default is for no daylight savings time."
  78   :type 'integer
  79   :group 'chinese-calendar)
  80
  81 (defcustom chinese-calendar-standard-time-zone-name
  82   '(if (< year 1928)
  83        "PMT"
  84      "CST")
  85   "*Abbreviated name of standard time zone used for Chinese calendar.
  86 This is an expression depending on `year' because it changed
  87 at 1928-01-01 00:00:00 from `PMT' to `CST'."
  88   :type 'sexp
  89   :group 'chinese-calendar)
  90
  91 (defcustom chinese-calendar-daylight-time-zone-name "CDT"
  92   "*Abbreviated name of daylight-savings time zone used for Chinese calendar."
  93   :type 'string
  94   :group 'chinese-calendar)
  95
  96 (defcustom chinese-calendar-daylight-savings-starts nil
  97 ; The correct value is as follows, but the Chinese calendrical
  98 ; authorities do NOT use DST in determining astronomical events:
  99 ;  '(cond ((< 1986 year) (calendar-nth-named-day 1 0 4 year 10))
 100 ;         ((= 1986 year) '(5 4 1986))
 101 ;         (t nil))
 102   "*Sexp giving the date on which daylight savings time starts for Chinese
 103 calendar.  Default is for no daylight savings time.  See documentation of
 104 `calendar-daylight-savings-starts'."
 105   :type 'sexp
 106   :group 'chinese-calendar)
 107
 108 (defcustom chinese-calendar-daylight-savings-ends nil
 109 ; The correct value is as follows, but the Chinese calendrical
 110 ; authorities do NOT use DST in determining astronomical events:
 111 ;  '(if (<= 1986 year) (calendar-nth-named-day 1 0 9 year 11))
 112   "*Sexp giving the date on which daylight savings time ends for Chinese
 113 calendar.  Default is for no daylight savings time.  See documentation of
 114 `calendar-daylight-savings-ends'."
 115   :type 'sexp
 116   :group 'chinese-calendar)
 117
 118 (defcustom chinese-calendar-daylight-savings-starts-time 0
 119   "*Number of minutes after midnight that daylight savings time starts for
 120 Chinese calendar.  Default is for no daylight savings time."
 121   :type 'integer
 122   :group 'chinese-calendar)
 123
 124 (defcustom chinese-calendar-daylight-savings-ends-time 0
 125   "*Number of minutes after midnight that daylight savings time ends for
 126 Chinese calendar.  Default is for no daylight savings time."
 127   :type 'integer
 128   :group 'chinese-calendar)
 129
 130 (defun chinese-zodiac-sign-on-or-after (d)
 131   "Absolute date of first new Zodiac sign on or after absolute date d.
 132 The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
 133  (let* ((year (extract-calendar-year
 134                 (calendar-gregorian-from-absolute d)))
 135          (calendar-time-zone (eval chinese-calendar-time-zone))
 136          (calendar-daylight-time-offset
 137           chinese-calendar-daylight-time-offset)
 138          (calendar-standard-time-zone-name
 139           chinese-calendar-standard-time-zone-name)
 140          (calendar-daylight-time-zone-name
 141           chinese-calendar-daylight-time-zone-name)
 142          (calendar-calendar-daylight-savings-starts
 143           chinese-calendar-daylight-savings-starts)
 144          (calendar-daylight-savings-ends
 145           chinese-calendar-daylight-savings-ends)
 146          (calendar-daylight-savings-starts-time
 147           chinese-calendar-daylight-savings-starts-time)
 148          (calendar-daylight-savings-ends-time
 149           chinese-calendar-daylight-savings-ends-time))
 150    (floor
 151     (calendar-absolute-from-astro
 152      (solar-date-next-longitude
 153       (calendar-astro-from-absolute d)
 154       30)))))
 155
 156 (defun chinese-new-moon-on-or-after (d)
 157   "Absolute date of first new moon on or after absolute date d."
 158   (let* ((year (extract-calendar-year
 159                 (calendar-gregorian-from-absolute d)))
 160          (calendar-time-zone (eval chinese-calendar-time-zone))
 161          (calendar-daylight-time-offset
 162           chinese-calendar-daylight-time-offset)
 163          (calendar-standard-time-zone-name
 164           chinese-calendar-standard-time-zone-name)
 165          (calendar-daylight-time-zone-name
 166           chinese-calendar-daylight-time-zone-name)
 167          (calendar-calendar-daylight-savings-starts
 168           chinese-calendar-daylight-savings-starts)
 169          (calendar-daylight-savings-ends
 170           chinese-calendar-daylight-savings-ends)
 171          (calendar-daylight-savings-starts-time
 172           chinese-calendar-daylight-savings-starts-time)
 173          (calendar-daylight-savings-ends-time
 174           chinese-calendar-daylight-savings-ends-time))
 175     (floor
 176      (calendar-absolute-from-astro
 177       (lunar-new-moon-on-or-after
 178        (calendar-astro-from-absolute d))))))
 179
 180 (defvar chinese-year-cache
 181   '((1989 (12 726110) (1 726139) (2 726169) (3 726198) (4 726227) (5 726257)
 182           (6 726286) (7 726316) (8 726345) (9 726375) (10 726404) (11 726434))
 183     (1990 (12 726464) (1 726494) (2 726523) (3 726553) (4 726582) (5 726611)
 184           (5.5 726641) (6 726670) (7 726699) (8 726729) (9 726758) (10 726788)
 185           (11 726818))
 186     (1991 (12 726848) (1 726878) (2 726907) (3 726937) (4 726966) (5 726995)
 187           (6 727025) (7 727054) (8 727083) (9 727113) (10 727142) (11 727172))
 188     (1992 (12 727202) (1 727232) (2 727261) (3 727291) (4 727321) (5 727350)
 189           (6 727379) (7 727409) (8 727438) (9 727467) (10 727497) (11 727526))
 190     (1993 (12 727556) (1 727586) (2 727615) (3 727645) (3.5 727675) (4 727704)
 191           (5 727734) (6 727763) (7 727793) (8 727822) (9 727851) (10 727881)
 192           (11 727910))
 193     (1994 (12 727940) (1 727969) (2 727999) (3 728029) (4 728059) (5 728088)
 194           (6 728118) (7 728147) (8 728177) (9 728206) (10 728235) (11 728265))
 195     (1995 (12 728294) (1 728324) (2 728353) (3 728383) (4 728413) (5 728442)
 196           (6 728472) (7 728501) (8 728531) (8.5 728561) (9 728590) (10 728619)
 197           (11 728649))
 198     (1996 (12 728678) (1 728708) (2 728737) (3 728767) (4 728796) (5 728826)
 199           (6 728856) (7 728885) (8 728915) (9 728944) (10 728974) (11 729004))
 200     (1997 (12 729033) (1 729062) (2 729092) (3 729121) (4 729151) (5 729180)
 201           (6 729210) (7 729239) (8 729269) (9 729299) (10 729328) (11 729358))
 202     (1998 (12 729388) (1 729417) (2 729447) (3 729476) (4 729505) (5 729535)
 203           (5.5 729564) (6 729593) (7 729623) (8 729653) (9 729682) (10 729712)
 204           (11 729742))
 205     (1999 (12 729771) (1 729801) (2 729831) (3 729860) (4 729889) (5 729919)
 206           (6 729948) (7 729977) (8 730007) (9 730036) (10 730066) (11 730096))
 207     (2000 (12 730126) (1 730155) (2 730185) (3 730215) (4 730244) (5 730273)
 208           (6 730303) (7 730332) (8 730361) (9 730391) (10 730420) (11 730450)))
 209   "An assoc list of Chinese year structures as determined by `chinese-year'.
 210
 211 Values are computed as needed, but to save time, the initial value consists
 212 of the precomputed years 1989-2000.  The code works just as well with this
 213 set to nil initially (which is how the value for 1989-2000 was computed).")
 214
 215 (defun chinese-year (y)
 216   "The structure of the Chinese year for Gregorian year Y.
 217 The result is a list of pairs (i d), where month i begins on absolute date d,
 218 of the Chinese months from the Chinese month following the solstice in
 219 Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y.
 220
 221 The list is cached for further use."
 222   (let ((list (cdr (assoc y chinese-year-cache))))
 223     (if (not list)
 224         (progn
 225           (setq list (compute-chinese-year y))
 226           (setq chinese-year-cache
 227                 (append chinese-year-cache (list (cons y list))))))
 228     list))
 229
 230 (defun number-chinese-months (list start)
 231   "Assign month numbers to the lunar months in LIST, starting with START.
 232 Numbers are assigned sequentially, START, START+1, ..., 11, with half
 233 numbers used for leap months.
 234
 235 First month of list will never be a leap month, nor will the last."
 236   (if list
 237       (if (zerop (- 12 start (length list)))
 238           ;; List is too short for a leap month
 239           (cons (list start (car list))
 240                 (number-chinese-months (cdr list) (1+ start)))
 241         (cons
 242          ;; First month
 243          (list start (car list))
 244          ;; Remaining months
 245          (if (and (cdr (cdr list));; at least two more months...
 246                   (<= (car (cdr (cdr list)))
 247                       (chinese-zodiac-sign-on-or-after (car (cdr list)))))
 248              ;; Next month is a leap month
 249              (cons (list (+ start 0.5) (car (cdr list)))
 250                    (number-chinese-months (cdr (cdr list)) (1+ start)))
 251            ;; Next month is not a leap month
 252            (number-chinese-months (cdr list) (1+ start)))))))
 253
 254 (defun chinese-month-list (start end)
 255   "List of starting dates of Chinese months from START to END."
 256   (if (<= start end)
 257       (let ((new-moon (chinese-new-moon-on-or-after start)))
 258         (if (<= new-moon end)
 259             (cons new-moon
 260                   (chinese-month-list (1+ new-moon) end))))))
 261
 262 (defun compute-chinese-year (y)
 263   "Compute the structure of the Chinese year for Gregorian year Y.
 264 The result is a list of pairs (i d), where month i begins on absolute date d,
 265 of the Chinese months from the Chinese month following the solstice in
 266 Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y."
 267   (let* ((next-solstice (chinese-zodiac-sign-on-or-after
 268                          (calendar-absolute-from-gregorian
 269                           (list 12 15 y))))
 270          (list (chinese-month-list (1+ (chinese-zodiac-sign-on-or-after
 271                                         (calendar-absolute-from-gregorian
 272                                          (list 12 15 (1- y)))))
 273                                    next-solstice))
 274          (next-sign (chinese-zodiac-sign-on-or-after (car list))))
 275     (if (= (length list) 12)
 276         ;; No room for a leap month, just number them 12, 1, 2, ..., 11
 277         (cons (list 12 (car list))
 278               (number-chinese-months (cdr list) 1))
 279       ;; Now we can assign numbers to the list for y
 280       ;; The first month or two are special
 281       (if (or (> (car list) next-sign) (>= next-sign (car (cdr list))))
 282           ;; First month on list is a leap month, second is not
 283           (append (list (list 11.5 (car list))
 284                         (list 12 (car (cdr list))))
 285                   (number-chinese-months (cdr (cdr list)) 1))
 286         ;; First month on list is not a leap month
 287         (append (list (list 12 (car list)))
 288                 (if (>= (chinese-zodiac-sign-on-or-after (car (cdr list)))
 289                         (car (cdr (cdr list))))
 290                     ;; Second month on list is a leap month
 291                     (cons (list 12.5 (car (cdr list)))
 292                           (number-chinese-months (cdr (cdr list)) 1))
 293                   ;; Second month on list is not a leap month
 294                   (number-chinese-months (cdr list) 1)))))))
 295
 296 (defun calendar-absolute-from-chinese (date)
 297   "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
 298 The Gregorian date Sunday, December 31, 1 BC is imaginary."
 299   (let* ((cycle (car date))
 300          (year (car (cdr date)))
 301          (month (car (cdr (cdr date))))
 302          (day (car (cdr (cdr (cdr date)))))
 303          (g-year (+ (* (1- cycle) 60);; years in prior cycles
 304                     (1- year)        ;; prior years this cycle
 305                     -2636)))         ;; years before absolute date 0
 306     (+ (1- day);; prior days this month
 307        (car
 308         (cdr    ;; absolute date of start of this month
 309          (assoc month (append (memq (assoc 1 (chinese-year g-year))
 310                                     (chinese-year g-year))
 311                               (chinese-year (1+ g-year)))))))))
 312
 313 (defun calendar-chinese-from-absolute (date)
 314   "Compute Chinese date (cycle year month day) corresponding to absolute DATE.
 315 The absolute date is the number of days elapsed since the (imaginary)
 316 Gregorian date Sunday, December 31, 1 BC."
 317   (let* ((g-year (extract-calendar-year
 318                   (calendar-gregorian-from-absolute date)))
 319          (c-year (+ g-year 2695))
 320          (list (append (chinese-year (1- g-year))
 321                        (chinese-year g-year)
 322                        (chinese-year (1+ g-year)))))
 323     (while (<= (car (cdr (car (cdr list)))) date)
 324       ;; the first month on the list is in Chinese year c-year
 325       ;; date is on or after start of second month on list...
 326       (if (= 1 (car (car (cdr list))))
 327           ;; second month on list is a new Chinese year
 328           (setq c-year (1+ c-year)))
 329       ;; ...so first month on list is of no interest
 330       (setq list (cdr list)))
 331     (list (/ (1- c-year) 60)
 332           (calendar-mod c-year 60)
 333           (car (car list))
 334           (1+ (- date (car (cdr (car list))))))))
 335
 336 (defun holiday-chinese-new-year ()
 337   "Date of Chinese New Year."
 338   (let ((m displayed-month)
 339         (y displayed-year))
 340     (increment-calendar-month m y 1)
 341     (if (< m 5)
 342         (let ((chinese-new-year
 343                (calendar-gregorian-from-absolute
 344                 (car (cdr (assoc 1 (chinese-year y)))))))
 345           (if (calendar-date-is-visible-p chinese-new-year)
 346           (list
 347            (list chinese-new-year
 348                  (format "Chinese New Year (%s)"
 349                          (calendar-chinese-sexagesimal-name (+ y 57))))))))))
 350
 351 (defun calendar-chinese-date-string (&optional date)
 352   "String of Chinese date of Gregorian DATE.
 353 Defaults to today's date if DATE is not given."
 354   (let* ((a-date (calendar-absolute-from-gregorian
 355                   (or date (calendar-current-date))))
 356          (c-date (calendar-chinese-from-absolute a-date))
 357          (cycle (car c-date))
 358          (year (car (cdr c-date)))
 359          (month (car (cdr (cdr c-date))))
 360          (day (car (cdr (cdr (cdr c-date)))))
 361          (this-month (calendar-absolute-from-chinese
 362                       (list cycle year month 1)))
 363          (next-month (calendar-absolute-from-chinese
 364                       (list (if (= year 60) (1+ cycle) cycle)
 365                             (if (= (floor month) 12) (1+ year) year)
 366                             (calendar-mod (1+ (floor month)) 12)
 367                             1)))
 368          (m-cycle (% (+ (* year 5) (floor month)) 60)))
 369     (format "Cycle %s, year %s (%s), %smonth %s%s, day %s (%s)"
 370             cycle
 371             year (calendar-chinese-sexagesimal-name year)
 372             (if (not (integerp month))
 373                 "second "
 374               (if (< 30 (- next-month this-month))
 375                   "first "
 376                 ""))
 377             (floor month)
 378             (if (integerp month)
 379                 (format " (%s)" (calendar-chinese-sexagesimal-name
 380                                  (+ (* 5 year) month 44)))
 381               "")
 382             day (calendar-chinese-sexagesimal-name (+ a-date 15)))))
 383
 384 (defun calendar-chinese-sexagesimal-name (n)
 385   "The N-th name of the Chinese sexagesimal cycle.
 386 N congruent to 1 gives the first name, N congruent to 2 gives the second name,
 387 ..., N congruent to 60 gives the sixtieth name."
 388   (format "%s-%s"
 389           (aref chinese-calendar-celestial-stem (% (1- n) 10))
 390           (aref chinese-calendar-terrestrial-branch (% (1- n) 12))))
 391
 392 (defun calendar-print-chinese-date ()
 393   "Show the Chinese date equivalents of date."
 394   (interactive)
 395   (message "Computing Chinese date...")
 396   (message "Chinese date: %s"
 397            (calendar-chinese-date-string (calendar-cursor-to-date t))))
 398
 399 (defun calendar-goto-chinese-date (date &optional noecho)
 400   "Move cursor to Chinese date DATE.
 401 Echo Chinese date unless NOECHO is t."
 402   (interactive
 403    (let* ((c (calendar-chinese-from-absolute
 404               (calendar-absolute-from-gregorian
 405                (calendar-current-date))))
 406           (cycle (calendar-read
 407                   "Chinese calendar cycle number (>44): "
 408                   '(lambda (x) (> x 44))
 409                   (int-to-string (car c))))
 410           (year (calendar-read
 411                  "Year in Chinese cycle (1..60): "
 412                  '(lambda (x) (and (<= 1 x) (<= x 60)))
 413                  (int-to-string (car (cdr c)))))
 414           (month-list (make-chinese-month-assoc-list
 415                        (chinese-months cycle year)))
 416           (month (cdr (assoc
 417                        (completing-read "Chinese calendar month: "
 418                                         month-list nil t)
 419                        month-list)))
 420           (last (if (= month
 421                        (car (cdr (cdr
 422                                   (calendar-chinese-from-absolute
 423                                    (+ 29
 424                                       (calendar-absolute-from-chinese
 425                                        (list cycle year month 1))))))))
 426                     30
 427                   29))
 428           (day (calendar-read
 429                 (format "Chinese calendar day (1-%d): " last)
 430                 '(lambda (x) (and (<= 1 x) (<= x last))))))
 431      (list (list cycle year month day))))
 432   (calendar-goto-date (calendar-gregorian-from-absolute
 433                        (calendar-absolute-from-chinese date)))
 434   (or noecho (calendar-print-chinese-date)))
 435
 436 (defun chinese-months (c y)
 437   "A list of the months in cycle C, year Y of the Chinese calendar."
 438   (let* ((l (memq 1 (append
 439                      (mapcar '(lambda (x)
 440                                 (car x))
 441                              (chinese-year (extract-calendar-year
 442                                             (calendar-gregorian-from-absolute
 443                                              (calendar-absolute-from-chinese
 444                                               (list c y 1 1))))))
 445                      (mapcar '(lambda (x)
 446                                 (if (> (car x) 11) (car x)))
 447                              (chinese-year (extract-calendar-year
 448                                             (calendar-gregorian-from-absolute
 449                                              (calendar-absolute-from-chinese
 450                                               (list (if (= y 60) (1+ c) c)
 451                                                     (if (= y 60) 1 y)
 452                                                     1 1))))))))))
 453     l))
 454
 455 (defun make-chinese-month-assoc-list (l)
 456   "Make list of months L into an assoc list."
 457   (if (and l (car l))
 458       (if (and (cdr l) (car (cdr l)))
 459           (if (= (car l) (floor (car (cdr l))))
 460               (append
 461                (list (cons (format "%s (first)" (car l)) (car l))
 462                      (cons (format "%s (second)" (car l)) (car (cdr l))))
 463                (make-chinese-month-assoc-list (cdr (cdr l))))
 464             (append
 465              (list (cons (int-to-string (car l)) (car l)))
 466              (make-chinese-month-assoc-list (cdr l))))
 467         (list (cons (int-to-string (car l)) (car l))))))
 468
 469 (defun diary-chinese-date ()
 470   "Chinese calendar equivalent of date diary entry."
 471   (format "Chinese date: %s" (calendar-chinese-date-string date)))
 472
 473 (provide 'cal-china)
 474
 475 ;;; cal-china.el ends here