1 ;;; cal-china.el --- calendar functions for the Chinese calendar
3 ;; Copyright (C) 1995, 1997 Free Software Foundation, Inc.
5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
7 ;; Human-Keywords: Chinese calendar, calendar, holidays, diary
9 ;; This file is part of GNU Emacs.
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)
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.
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., 51 Franklin Street, Fifth Floor,
24 ;; Boston, MA 02110-1301, USA.
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.
40 ;; Technical details of all the calendrical calculations can be found in
41 ;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold
42 ;; and Nachum Dershowitz, Cambridge University Press (2001).
44 ;; Comments, corrections, and improvements should be sent to
45 ;; Edward M. Reingold Department of Computer Science
46 ;; (217) 333-6733 University of Illinois at Urbana-Champaign
47 ;; reingold@cs.uiuc.edu 1304 West Springfield Avenue
48 ;; Urbana, Illinois 61801
53 (defvar displayed-month
)
54 (defvar displayed-year
)
58 (defvar chinese-calendar-celestial-stem
59 ["Jia" "Yi" "Bing" "Ding" "Wu" "Ji" "Geng" "Xin" "Ren" "Gui"])
61 (defvar chinese-calendar-terrestrial-branch
62 ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"])
64 (defcustom chinese-calendar-time-zone
68 "*Number of minutes difference between local standard time for Chinese
69 calendar and Coordinated Universal (Greenwich) Time. Default is for Beijing.
70 This is an expression in `year' since it changed at 1928-01-01 00:00:00 from
73 :group
'chinese-calendar
)
75 (defcustom chinese-calendar-location-name
"Beijing"
76 "*Name of location used for calculation of Chinese calendar."
78 :group
'chinese-calendar
)
80 (defcustom chinese-calendar-daylight-time-offset
0
81 ; The correct value is as follows, but the Chinese calendrical
82 ; authorities do NOT use DST in determining astronomical events:
84 "*Number of minutes difference between daylight savings and standard time
85 for Chinese calendar. Default is for no daylight savings time."
87 :group
'chinese-calendar
)
89 (defcustom chinese-calendar-standard-time-zone-name
93 "*Abbreviated name of standard time zone used for Chinese calendar.
94 This is an expression depending on `year' because it changed
95 at 1928-01-01 00:00:00 from `PMT' to `CST'."
97 :group
'chinese-calendar
)
99 (defcustom chinese-calendar-daylight-time-zone-name
"CDT"
100 "*Abbreviated name of daylight-savings time zone used for Chinese calendar."
102 :group
'chinese-calendar
)
104 (defcustom chinese-calendar-daylight-savings-starts nil
105 ; The correct value is as follows, but the Chinese calendrical
106 ; authorities do NOT use DST in determining astronomical events:
107 ; '(cond ((< 1986 year) (calendar-nth-named-day 1 0 4 year 10))
108 ; ((= 1986 year) '(5 4 1986))
110 "*Sexp giving the date on which daylight savings time starts for Chinese
111 calendar. Default is for no daylight savings time. See documentation of
112 `calendar-daylight-savings-starts'."
114 :group
'chinese-calendar
)
116 (defcustom chinese-calendar-daylight-savings-ends nil
117 ; The correct value is as follows, but the Chinese calendrical
118 ; authorities do NOT use DST in determining astronomical events:
119 ; '(if (<= 1986 year) (calendar-nth-named-day 1 0 9 year 11))
120 "*Sexp giving the date on which daylight savings time ends for Chinese
121 calendar. Default is for no daylight savings time. See documentation of
122 `calendar-daylight-savings-ends'."
124 :group
'chinese-calendar
)
126 (defcustom chinese-calendar-daylight-savings-starts-time
0
127 "*Number of minutes after midnight that daylight savings time starts for
128 Chinese calendar. Default is for no daylight savings time."
130 :group
'chinese-calendar
)
132 (defcustom chinese-calendar-daylight-savings-ends-time
0
133 "*Number of minutes after midnight that daylight savings time ends for
134 Chinese calendar. Default is for no daylight savings time."
136 :group
'chinese-calendar
)
138 (defun chinese-zodiac-sign-on-or-after (d)
139 "Absolute date of first new Zodiac sign on or after absolute date d.
140 The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
141 (let* ((year (extract-calendar-year
142 (calendar-gregorian-from-absolute d
)))
143 (calendar-time-zone (eval chinese-calendar-time-zone
))
144 (calendar-daylight-time-offset
145 chinese-calendar-daylight-time-offset
)
146 (calendar-standard-time-zone-name
147 chinese-calendar-standard-time-zone-name
)
148 (calendar-daylight-time-zone-name
149 chinese-calendar-daylight-time-zone-name
)
150 (calendar-calendar-daylight-savings-starts
151 chinese-calendar-daylight-savings-starts
)
152 (calendar-daylight-savings-ends
153 chinese-calendar-daylight-savings-ends
)
154 (calendar-daylight-savings-starts-time
155 chinese-calendar-daylight-savings-starts-time
)
156 (calendar-daylight-savings-ends-time
157 chinese-calendar-daylight-savings-ends-time
))
159 (calendar-absolute-from-astro
160 (solar-date-next-longitude
161 (calendar-astro-from-absolute d
)
164 (defun chinese-new-moon-on-or-after (d)
165 "Absolute date of first new moon on or after absolute date d."
166 (let* ((year (extract-calendar-year
167 (calendar-gregorian-from-absolute d
)))
168 (calendar-time-zone (eval chinese-calendar-time-zone
))
169 (calendar-daylight-time-offset
170 chinese-calendar-daylight-time-offset
)
171 (calendar-standard-time-zone-name
172 chinese-calendar-standard-time-zone-name
)
173 (calendar-daylight-time-zone-name
174 chinese-calendar-daylight-time-zone-name
)
175 (calendar-calendar-daylight-savings-starts
176 chinese-calendar-daylight-savings-starts
)
177 (calendar-daylight-savings-ends
178 chinese-calendar-daylight-savings-ends
)
179 (calendar-daylight-savings-starts-time
180 chinese-calendar-daylight-savings-starts-time
)
181 (calendar-daylight-savings-ends-time
182 chinese-calendar-daylight-savings-ends-time
))
184 (calendar-absolute-from-astro
185 (lunar-new-moon-on-or-after
186 (calendar-astro-from-absolute d
))))))
188 (defvar chinese-year-cache
189 '((1990 (12 726464) (1 726494) (2 726523) (3 726553) (4 726582) (5 726611)
190 (5.5
726641) (6 726670) (7 726699) (8 726729) (9 726758) (10 726788)
192 (1991 (12 726848) (1 726878) (2 726907) (3 726937) (4 726966) (5 726995)
193 (6 727025) (7 727054) (8 727083) (9 727113) (10 727142) (11 727172))
194 (1992 (12 727202) (1 727232) (2 727261) (3 727291) (4 727321) (5 727350)
195 (6 727379) (7 727409) (8 727438) (9 727467) (10 727497) (11 727526))
196 (1993 (12 727556) (1 727586) (2 727615) (3 727645) (3.5
727675) (4 727704)
197 (5 727734) (6 727763) (7 727793) (8 727822) (9 727851) (10 727881)
199 (1994 (12 727940) (1 727969) (2 727999) (3 728029) (4 728059) (5 728088)
200 (6 728118) (7 728147) (8 728177) (9 728206) (10 728235) (11 728265))
201 (1995 (12 728294) (1 728324) (2 728353) (3 728383) (4 728413) (5 728442)
202 (6 728472) (7 728501) (8 728531) (8.5
728561) (9 728590) (10 728619)
204 (1996 (12 728678) (1 728708) (2 728737) (3 728767) (4 728796) (5 728826)
205 (6 728856) (7 728885) (8 728915) (9 728944) (10 728974) (11 729004))
206 (1997 (12 729033) (1 729062) (2 729092) (3 729121) (4 729151) (5 729180)
207 (6 729210) (7 729239) (8 729269) (9 729299) (10 729328) (11 729358))
208 (1998 (12 729388) (1 729417) (2 729447) (3 729476) (4 729505) (5 729535)
209 (5.5
729564) (6 729593) (7 729623) (8 729653) (9 729682) (10 729712)
211 (1999 (12 729771) (1 729801) (2 729831) (3 729860) (4 729889) (5 729919)
212 (6 729948) (7 729977) (8 730007) (9 730036) (10 730066) (11 730096))
213 (2000 (12 730126) (1 730155) (2 730185) (3 730215) (4 730244) (5 730273)
214 (6 730303) (7 730332) (8 730361) (9 730391) (10 730420) (11 730450))
215 (2001 (12 730480) (1 730509) (2 730539) (3 730569) (4 730598) (4.5
730628)
216 (5 730657) (6 730687) (7 730716) (8 730745) (9 730775) (10 730804)
218 (2002 (12 730863) (1 730893) (2 730923) (3 730953) (4 730982) (5 731012)
219 (6 731041) (7 731071) (8 731100) (9 731129) (10 731159) (11 731188))
220 (2003 (12 731218) (1 731247) (2 731277) (3 731307) (4 731336) (5 731366)
221 (6 731396) (7 731425) (8 731455) (9 731484) (10 731513) (11 731543))
222 (2004 (12 731572) (1 731602) (2 731631) (2.5
731661) (3 731690) (4 731720)
223 (5 731750) (6 731779) (7 731809) (8 731838) (9 731868) (10 731897)
225 (2005 (12 731956) (1 731986) (2 732015) (3 732045) (4 732074) (5 732104)
226 (6 732133) (7 732163) (8 732193) (9 732222) (10 732252) (11 732281))
227 (2006 (12 732311) (1 732340) (2 732370) (3 732399) (4 732429) (5 732458)
228 (6 732488) (7 732517) (7.5
732547) (8 732576) (9 732606) (10 732636)
230 (2007 (12 732695) (1 732725) (2 732754) (3 732783) (4 732813) (5 732842)
231 (6 732871) (7 732901) (8 732930) (9 732960) (10 732990) (11 733020))
232 (2008 (12 733049) (1 733079) (2 733109) (3 733138) (4 733167) (5 733197)
233 (6 733226) (7 733255) (8 733285) (9 733314) (10 733344) (11 733374))
234 (2009 (12 733403) (1 733433) (2 733463) (3 733493) (4 733522) (5 733551)
235 (5.5
733581) (6 733610) (7 733639) (8 733669) (9 733698) (10 733728)
237 (2010 (12 733787) (1 733817) (2 733847) (3 733876) (4 733906) (5 733935)
238 (6 733965) (7 733994) (8 734023) (9 734053) (10 734082) (11 734112)))
239 "An assoc list of Chinese year structures as determined by `chinese-year'.
241 Values are computed as needed, but to save time, the initial value consists
242 of the precomputed years 1990-2010. The code works just as well with this
243 set to nil initially (which is how the value for 1990-2010 was computed).")
245 (defun chinese-year (y)
246 "The structure of the Chinese year for Gregorian year Y.
247 The result is a list of pairs (i d), where month i begins on absolute date d,
248 of the Chinese months from the Chinese month following the solstice in
249 Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y.
251 The list is cached for further use."
252 (let ((list (cdr (assoc y chinese-year-cache
))))
255 (setq list
(compute-chinese-year y
))
256 (setq chinese-year-cache
257 (append chinese-year-cache
(list (cons y list
))))))
260 (defun number-chinese-months (list start
)
261 "Assign month numbers to the lunar months in LIST, starting with START.
262 Numbers are assigned sequentially, START, START+1, ..., 11, with half
263 numbers used for leap months.
265 First month of list will never be a leap month, nor will the last."
267 (if (zerop (- 12 start
(length list
)))
268 ;; List is too short for a leap month
269 (cons (list start
(car list
))
270 (number-chinese-months (cdr list
) (1+ start
)))
273 (list start
(car list
))
275 (if (and (cdr (cdr list
));; at least two more months...
276 (<= (car (cdr (cdr list
)))
277 (chinese-zodiac-sign-on-or-after (car (cdr list
)))))
278 ;; Next month is a leap month
279 (cons (list (+ start
0.5) (car (cdr list
)))
280 (number-chinese-months (cdr (cdr list
)) (1+ start
)))
281 ;; Next month is not a leap month
282 (number-chinese-months (cdr list
) (1+ start
)))))))
284 (defun chinese-month-list (start end
)
285 "List of starting dates of Chinese months from START to END."
287 (let ((new-moon (chinese-new-moon-on-or-after start
)))
288 (if (<= new-moon end
)
290 (chinese-month-list (1+ new-moon
) end
))))))
292 (defun compute-chinese-year (y)
293 "Compute the structure of the Chinese year for Gregorian year Y.
294 The result is a list of pairs (i d), where month i begins on absolute date d,
295 of the Chinese months from the Chinese month following the solstice in
296 Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y."
297 (let* ((next-solstice (chinese-zodiac-sign-on-or-after
298 (calendar-absolute-from-gregorian
300 (list (chinese-month-list (1+ (chinese-zodiac-sign-on-or-after
301 (calendar-absolute-from-gregorian
302 (list 12 15 (1- y
)))))
304 (next-sign (chinese-zodiac-sign-on-or-after (car list
))))
305 (if (= (length list
) 12)
306 ;; No room for a leap month, just number them 12, 1, 2, ..., 11
307 (cons (list 12 (car list
))
308 (number-chinese-months (cdr list
) 1))
309 ;; Now we can assign numbers to the list for y
310 ;; The first month or two are special
311 (if (or (> (car list
) next-sign
) (>= next-sign
(car (cdr list
))))
312 ;; First month on list is a leap month, second is not
313 (append (list (list 11.5 (car list
))
314 (list 12 (car (cdr list
))))
315 (number-chinese-months (cdr (cdr list
)) 1))
316 ;; First month on list is not a leap month
317 (append (list (list 12 (car list
)))
318 (if (>= (chinese-zodiac-sign-on-or-after (car (cdr list
)))
319 (car (cdr (cdr list
))))
320 ;; Second month on list is a leap month
321 (cons (list 12.5 (car (cdr list
)))
322 (number-chinese-months (cdr (cdr list
)) 1))
323 ;; Second month on list is not a leap month
324 (number-chinese-months (cdr list
) 1)))))))
326 (defun calendar-absolute-from-chinese (date)
327 "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
328 The Gregorian date Sunday, December 31, 1 BC is imaginary."
329 (let* ((cycle (car date
))
330 (year (car (cdr date
)))
331 (month (car (cdr (cdr date
))))
332 (day (car (cdr (cdr (cdr date
)))))
333 (g-year (+ (* (1- cycle
) 60);; years in prior cycles
334 (1- year
) ;; prior years this cycle
335 -
2636))) ;; years before absolute date 0
336 (+ (1- day
);; prior days this month
338 (cdr ;; absolute date of start of this month
339 (assoc month
(append (memq (assoc 1 (chinese-year g-year
))
340 (chinese-year g-year
))
341 (chinese-year (1+ g-year
)))))))))
343 (defun calendar-chinese-from-absolute (date)
344 "Compute Chinese date (cycle year month day) corresponding to absolute DATE.
345 The absolute date is the number of days elapsed since the (imaginary)
346 Gregorian date Sunday, December 31, 1 BC."
347 (let* ((g-year (extract-calendar-year
348 (calendar-gregorian-from-absolute date
)))
349 (c-year (+ g-year
2695))
350 (list (append (chinese-year (1- g-year
))
351 (chinese-year g-year
)
352 (chinese-year (1+ g-year
)))))
353 (while (<= (car (cdr (car (cdr list
)))) date
)
354 ;; the first month on the list is in Chinese year c-year
355 ;; date is on or after start of second month on list...
356 (if (= 1 (car (car (cdr list
))))
357 ;; second month on list is a new Chinese year
358 (setq c-year
(1+ c-year
)))
359 ;; ...so first month on list is of no interest
360 (setq list
(cdr list
)))
361 (list (/ (1- c-year
) 60)
362 (calendar-mod c-year
60)
364 (1+ (- date
(car (cdr (car list
))))))))
366 (defun holiday-chinese-new-year ()
367 "Date of Chinese New Year."
368 (let ((m displayed-month
)
370 (increment-calendar-month m y
1)
372 (let ((chinese-new-year
373 (calendar-gregorian-from-absolute
374 (car (cdr (assoc 1 (chinese-year y
)))))))
375 (if (calendar-date-is-visible-p chinese-new-year
)
377 (list chinese-new-year
378 (format "Chinese New Year (%s)"
379 (calendar-chinese-sexagesimal-name (+ y
57))))))))))
381 (defun calendar-chinese-date-string (&optional date
)
382 "String of Chinese date of Gregorian DATE.
383 Defaults to today's date if DATE is not given."
384 (let* ((a-date (calendar-absolute-from-gregorian
385 (or date
(calendar-current-date))))
386 (c-date (calendar-chinese-from-absolute a-date
))
388 (year (car (cdr c-date
)))
389 (month (car (cdr (cdr c-date
))))
390 (day (car (cdr (cdr (cdr c-date
)))))
391 (this-month (calendar-absolute-from-chinese
392 (list cycle year month
1)))
393 (next-month (calendar-absolute-from-chinese
394 (list (if (= year
60) (1+ cycle
) cycle
)
395 (if (= (floor month
) 12) (1+ year
) year
)
396 (calendar-mod (1+ (floor month
)) 12)
398 (m-cycle (%
(+ (* year
5) (floor month
)) 60)))
399 (format "Cycle %s, year %s (%s), %smonth %s%s, day %s (%s)"
401 year
(calendar-chinese-sexagesimal-name year
)
402 (if (not (integerp month
))
404 (if (< 30 (- next-month this-month
))
409 (format " (%s)" (calendar-chinese-sexagesimal-name
410 (+ (* 12 year
) month
50)))
412 day
(calendar-chinese-sexagesimal-name (+ a-date
15)))))
414 (defun calendar-chinese-sexagesimal-name (n)
415 "The N-th name of the Chinese sexagesimal cycle.
416 N congruent to 1 gives the first name, N congruent to 2 gives the second name,
417 ..., N congruent to 60 gives the sixtieth name."
419 (aref chinese-calendar-celestial-stem
(%
(1- n
) 10))
420 (aref chinese-calendar-terrestrial-branch
(%
(1- n
) 12))))
422 (defun calendar-print-chinese-date ()
423 "Show the Chinese date equivalents of date."
425 (message "Computing Chinese date...")
426 (message "Chinese date: %s"
427 (calendar-chinese-date-string (calendar-cursor-to-date t
))))
429 (defun calendar-goto-chinese-date (date &optional noecho
)
430 "Move cursor to Chinese date DATE.
431 Echo Chinese date unless NOECHO is t."
433 (let* ((c (calendar-chinese-from-absolute
434 (calendar-absolute-from-gregorian
435 (calendar-current-date))))
436 (cycle (calendar-read
437 "Chinese calendar cycle number (>44): "
438 '(lambda (x) (> x
44))
439 (int-to-string (car c
))))
441 "Year in Chinese cycle (1..60): "
442 '(lambda (x) (and (<= 1 x
) (<= x
60)))
443 (int-to-string (car (cdr c
)))))
444 (month-list (make-chinese-month-assoc-list
445 (chinese-months cycle year
)))
447 (completing-read "Chinese calendar month: "
452 (calendar-chinese-from-absolute
454 (calendar-absolute-from-chinese
455 (list cycle year month
1))))))))
459 (format "Chinese calendar day (1-%d): " last
)
460 '(lambda (x) (and (<= 1 x
) (<= x last
))))))
461 (list (list cycle year month day
))))
462 (calendar-goto-date (calendar-gregorian-from-absolute
463 (calendar-absolute-from-chinese date
)))
464 (or noecho
(calendar-print-chinese-date)))
466 (defun chinese-months (c y
)
467 "A list of the months in cycle C, year Y of the Chinese calendar."
468 (let* ((l (memq 1 (append
471 (chinese-year (extract-calendar-year
472 (calendar-gregorian-from-absolute
473 (calendar-absolute-from-chinese
476 (if (> (car x
) 11) (car x
)))
477 (chinese-year (extract-calendar-year
478 (calendar-gregorian-from-absolute
479 (calendar-absolute-from-chinese
480 (list (if (= y
60) (1+ c
) c
)
485 (defun make-chinese-month-assoc-list (l)
486 "Make list of months L into an assoc list."
488 (if (and (cdr l
) (car (cdr l
)))
489 (if (= (car l
) (floor (car (cdr l
))))
491 (list (cons (format "%s (first)" (car l
)) (car l
))
492 (cons (format "%s (second)" (car l
)) (car (cdr l
))))
493 (make-chinese-month-assoc-list (cdr (cdr l
))))
495 (list (cons (int-to-string (car l
)) (car l
)))
496 (make-chinese-month-assoc-list (cdr l
))))
497 (list (cons (int-to-string (car l
)) (car l
))))))
499 (defun diary-chinese-date ()
500 "Chinese calendar equivalent of date diary entry."
501 (format "Chinese date: %s" (calendar-chinese-date-string date
)))
505 ;;; arch-tag: 7e5b7e0d-676c-47e3-8696-93e7ea0ab644
506 ;;; cal-china.el ends here