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