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