code.delx.au - gnu-emacs/blob - lisp/calendar/cal-china.el

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