Require calendar, not cal-julian.
[bpt/emacs.git] / lisp / calendar / cal-china.el
CommitLineData
3afbc435 1;;; cal-china.el --- calendar functions for the Chinese calendar
0808d911 2
4785bf2c
GM
3;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
4;; 2008 Free Software Foundation, Inc.
0808d911
ER
5
6;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
dbfca9c4 7;; Maintainer: Glenn Morris <rgm@gnu.org>
0808d911
ER
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
075969b4 15;; the Free Software Foundation; either version 3, or (at your option)
0808d911
ER
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
b578f267 24;; along with GNU Emacs; see the file COPYING. If not, write to the
3a35cf56
LK
25;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
26;; Boston, MA 02110-1301, USA.
0808d911
ER
27
28;;; Commentary:
29
30;; This collection of functions implements the features of calendar.el,
0031509c
ER
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
67d80173
ER
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.
0031509c 41
a96a5fca 42;; Technical details of all the calendrical calculations can be found in
fffaba77
PE
43;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold
44;; and Nachum Dershowitz, Cambridge University Press (2001).
a96a5fca 45
465323b6
GM
46;; Note to maintainers:
47;; Use `chinese-year-cache-init' every few years to recenter the default
48;; value of `chinese-year-cache'.
0808d911 49
465323b6 50;;; Code:
0b0f8fa4 51
0808d911
ER
52(require 'lunar)
53
bfcb5172
GM
54(defgroup chinese-calendar nil
55 "Chinese calendar support."
56 :group 'calendar)
00e3e480 57
a1506d29 58(defcustom chinese-calendar-time-zone
0808d911
ER
59 '(if (< year 1928)
60 (+ 465 (/ 40.0 60.0))
61 480)
67a9fd0d 62 "Minutes difference between local standard time for Chinese calendar and UTC.
465323b6
GM
63Default is for Beijing. This is an expression in `year' since it changed at
641928-01-01 00:00:00 from UT+7:45:40 to UT+8."
9e935048 65 :type 'sexp
8db540c5 66 :group 'chinese-calendar)
0808d911 67
8db540c5 68(defcustom chinese-calendar-location-name "Beijing"
08f7d912 69 "Name of location used for calculation of Chinese calendar."
8db540c5
RS
70 :type 'string
71 :group 'chinese-calendar)
0808d911 72
8db540c5 73(defcustom chinese-calendar-daylight-time-offset 0
4785bf2c
GM
74;; The correct value is as follows, but the Chinese calendrical
75;; authorities do NOT use DST in determining astronomical events:
76;; 60
67a9fd0d
GM
77 "Minutes difference between daylight saving and standard time.
78Default is for no daylight saving time."
8db540c5
RS
79 :type 'integer
80 :group 'chinese-calendar)
0808d911 81
8db540c5 82(defcustom chinese-calendar-standard-time-zone-name
0808d911
ER
83 '(if (< year 1928)
84 "PMT"
85 "CST")
08f7d912 86 "Abbreviated name of standard time zone used for Chinese calendar.
9e935048
RS
87This is an expression depending on `year' because it changed
88at 1928-01-01 00:00:00 from `PMT' to `CST'."
89 :type 'sexp
8db540c5 90 :group 'chinese-calendar)
0808d911 91
8db540c5 92(defcustom chinese-calendar-daylight-time-zone-name "CDT"
08f7d912 93 "Abbreviated name of daylight saving time zone used for Chinese calendar."
8db540c5
RS
94 :type 'string
95 :group 'chinese-calendar)
0808d911 96
8db540c5 97(defcustom chinese-calendar-daylight-savings-starts nil
4785bf2c
GM
98;; The correct value is as follows, but the Chinese calendrical
99;; authorities do NOT use DST in determining astronomical events:
100;; '(cond ((< 1986 year) (calendar-nth-named-day 1 0 4 year 10))
101;; ((= 1986 year) '(5 4 1986))
102;; (t nil))
67a9fd0d
GM
103 "Sexp giving the date on which daylight saving time starts.
104Default is for no daylight saving time. See documentation of
8db540c5
RS
105`calendar-daylight-savings-starts'."
106 :type 'sexp
107 :group 'chinese-calendar)
0808d911 108
8db540c5 109(defcustom chinese-calendar-daylight-savings-ends nil
4785bf2c
GM
110;; The correct value is as follows, but the Chinese calendrical
111;; authorities do NOT use DST in determining astronomical events:
112;; '(if (<= 1986 year) (calendar-nth-named-day 1 0 9 year 11))
67a9fd0d
GM
113 "Sexp giving the date on which daylight saving time ends.
114Default is for no daylight saving time. See documentation of
8db540c5
RS
115`calendar-daylight-savings-ends'."
116 :type 'sexp
117 :group 'chinese-calendar)
0808d911 118
8db540c5 119(defcustom chinese-calendar-daylight-savings-starts-time 0
67a9fd0d
GM
120 "Number of minutes after midnight that daylight saving time starts.
121Default is for no daylight saving time."
8db540c5
RS
122 :type 'integer
123 :group 'chinese-calendar)
0808d911 124
8db540c5 125(defcustom chinese-calendar-daylight-savings-ends-time 0
67a9fd0d
GM
126 "Number of minutes after midnight that daylight saving time ends.
127Default is for no daylight saving time."
8db540c5
RS
128 :type 'integer
129 :group 'chinese-calendar)
0808d911 130
a8774f05 131(defcustom chinese-calendar-celestial-stem
465323b6 132 ["Jia" "Yi" "Bing" "Ding" "Wu" "Ji" "Geng" "Xin" "Ren" "Gui"]
a8774f05
GM
133 "Prefixes used by `calendar-chinese-sexagesimal-name'."
134 :group 'chinese-calendar
135 :type '(vector (string :tag "Jia")
136 (string :tag "Yi")
137 (string :tag "Bing")
138 (string :tag "Ding")
139 (string :tag "Wu")
140 (string :tag "Ji")
141 (string :tag "Geng")
142 (string :tag "Xin")
143 (string :tag "Ren")
144 (string :tag "Gui")))
145
146(defcustom chinese-calendar-terrestrial-branch
465323b6 147 ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"]
a8774f05
GM
148 "Suffixes used by `calendar-chinese-sexagesimal-name'."
149 :group 'chinese-calendar
150 :type '(vector (string :tag "Zi")
151 (string :tag "Chou")
152 (string :tag "Yin")
153 (string :tag "Mao")
154 (string :tag "Chen")
155 (string :tag "Si")
156 (string :tag "Wu")
157 (string :tag "Wei")
158 (string :tag "Shen")
159 (string :tag "You")
160 (string :tag "Xu")
161 (string :tag "Hai")))
162
163;;; End of user options.
164
465323b6
GM
165
166(defun calendar-chinese-sexagesimal-name (n)
167 "The N-th name of the Chinese sexagesimal cycle.
168N congruent to 1 gives the first name, N congruent to 2 gives the second name,
169..., N congruent to 60 gives the sixtieth name."
170 (format "%s-%s"
171 (aref chinese-calendar-celestial-stem (% (1- n) 10))
172 (aref chinese-calendar-terrestrial-branch (% (1- n) 12))))
bfcb5172 173
0808d911 174(defun chinese-zodiac-sign-on-or-after (d)
67a9fd0d 175 "Absolute date of first new Zodiac sign on or after absolute date D.
0808d911 176The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
465323b6
GM
177 (let* ((year (extract-calendar-year (calendar-gregorian-from-absolute d)))
178 (calendar-time-zone (eval chinese-calendar-time-zone)) ; uses year
0808d911
ER
179 (calendar-daylight-time-offset
180 chinese-calendar-daylight-time-offset)
181 (calendar-standard-time-zone-name
182 chinese-calendar-standard-time-zone-name)
183 (calendar-daylight-time-zone-name
184 chinese-calendar-daylight-time-zone-name)
185 (calendar-calendar-daylight-savings-starts
186 chinese-calendar-daylight-savings-starts)
187 (calendar-daylight-savings-ends
188 chinese-calendar-daylight-savings-ends)
189 (calendar-daylight-savings-starts-time
190 chinese-calendar-daylight-savings-starts-time)
191 (calendar-daylight-savings-ends-time
192 chinese-calendar-daylight-savings-ends-time))
193 (floor
194 (calendar-absolute-from-astro
465323b6 195 (solar-date-next-longitude (calendar-astro-from-absolute d) 30)))))
0808d911
ER
196
197(defun chinese-new-moon-on-or-after (d)
67a9fd0d 198 "Absolute date of first new moon on or after absolute date D."
465323b6 199 (let* ((year (extract-calendar-year (calendar-gregorian-from-absolute d)))
0808d911
ER
200 (calendar-time-zone (eval chinese-calendar-time-zone))
201 (calendar-daylight-time-offset
202 chinese-calendar-daylight-time-offset)
203 (calendar-standard-time-zone-name
204 chinese-calendar-standard-time-zone-name)
205 (calendar-daylight-time-zone-name
206 chinese-calendar-daylight-time-zone-name)
207 (calendar-calendar-daylight-savings-starts
208 chinese-calendar-daylight-savings-starts)
209 (calendar-daylight-savings-ends
210 chinese-calendar-daylight-savings-ends)
211 (calendar-daylight-savings-starts-time
212 chinese-calendar-daylight-savings-starts-time)
213 (calendar-daylight-savings-ends-time
214 chinese-calendar-daylight-savings-ends-time))
215 (floor
216 (calendar-absolute-from-astro
465323b6 217 (lunar-new-moon-on-or-after (calendar-astro-from-absolute d))))))
0031509c
ER
218
219(defun chinese-month-list (start end)
220 "List of starting dates of Chinese months from START to END."
221 (if (<= start end)
222 (let ((new-moon (chinese-new-moon-on-or-after start)))
223 (if (<= new-moon end)
00e3e480
ER
224 (cons new-moon
225 (chinese-month-list (1+ new-moon) end))))))
0031509c 226
465323b6
GM
227(defun number-chinese-months (list start)
228 "Assign month numbers to the lunar months in LIST, starting with START.
229Numbers are assigned sequentially, START, START+1, ..., 11, with
230half numbers used for leap months. First and last months of list
231are never leap months."
232 (when list
233 (cons (list start (car list)) ; first month
234 ;; Remaining months.
235 (if (zerop (- 12 start (length list)))
236 ;; List is too short for a leap month.
237 (number-chinese-months (cdr list) (1+ start))
238 (if (and (cddr list) ; at least two more months...
706531d9 239 (<= (nth 2 list)
465323b6
GM
240 (chinese-zodiac-sign-on-or-after (cadr list))))
241 ;; Next month is a leap month.
242 (cons (list (+ start 0.5) (cadr list))
243 (number-chinese-months (cddr list) (1+ start)))
244 ;; Next month is not a leap month.
245 (number-chinese-months (cdr list) (1+ start)))))))
246
0031509c
ER
247(defun compute-chinese-year (y)
248 "Compute the structure of the Chinese year for Gregorian year Y.
00e3e480 249The result is a list of pairs (i d), where month i begins on absolute date d,
0031509c
ER
250of the Chinese months from the Chinese month following the solstice in
251Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y."
252 (let* ((next-solstice (chinese-zodiac-sign-on-or-after
253 (calendar-absolute-from-gregorian
254 (list 12 15 y))))
255 (list (chinese-month-list (1+ (chinese-zodiac-sign-on-or-after
256 (calendar-absolute-from-gregorian
257 (list 12 15 (1- y)))))
67d80173
ER
258 next-solstice))
259 (next-sign (chinese-zodiac-sign-on-or-after (car list))))
0031509c 260 (if (= (length list) 12)
4785bf2c 261 ;; No room for a leap month, just number them 12, 1, 2, ..., 11.
00e3e480 262 (cons (list 12 (car list))
67d80173 263 (number-chinese-months (cdr list) 1))
4785bf2c
GM
264 ;; Now we can assign numbers to the list for y.
265 ;; The first month or two are special.
465323b6 266 (if (or (> (car list) next-sign) (>= next-sign (cadr list)))
4785bf2c 267 ;; First month on list is a leap month, second is not.
00e3e480 268 (append (list (list 11.5 (car list))
465323b6
GM
269 (list 12 (cadr list)))
270 (number-chinese-months (cddr list) 1))
4785bf2c 271 ;; First month on list is not a leap month.
00e3e480 272 (append (list (list 12 (car list)))
465323b6
GM
273 (if (>= (chinese-zodiac-sign-on-or-after (cadr list))
274 (nth 2 list))
4785bf2c 275 ;; Second month on list is a leap month.
465323b6
GM
276 (cons (list 12.5 (cadr list))
277 (number-chinese-months (cddr list) 1))
4785bf2c 278 ;; Second month on list is not a leap month.
67d80173 279 (number-chinese-months (cdr list) 1)))))))
0031509c 280
465323b6
GM
281(defvar chinese-year-cache
282 ;; Maintainers: delete existing value, position point at start of
283 ;; empty line, then call M-: (chinese-year-cache-init N)
284 '((2000 (12 730126) (1 730155) (2 730185) (3 730215) (4 730244) (5 730273)
285 (6 730303) (7 730332) (8 730361) (9 730391) (10 730420) (11 730450))
286 (2001 (12 730480) (1 730509) (2 730539) (3 730569) (4 730598) (4.5 730628)
287 (5 730657) (6 730687) (7 730716) (8 730745) (9 730775) (10 730804)
288 (11 730834))
289 (2002 (12 730863) (1 730893) (2 730923) (3 730953) (4 730982) (5 731012)
290 (6 731041) (7 731071) (8 731100) (9 731129) (10 731159) (11 731188))
291 (2003 (12 731218) (1 731247) (2 731277) (3 731307) (4 731336) (5 731366)
292 (6 731396) (7 731425) (8 731455) (9 731484) (10 731513) (11 731543))
293 (2004 (12 731572) (1 731602) (2 731631) (2.5 731661) (3 731690) (4 731720)
294 (5 731750) (6 731779) (7 731809) (8 731838) (9 731868) (10 731897)
295 (11 731927))
296 (2005 (12 731956) (1 731986) (2 732015) (3 732045) (4 732074) (5 732104)
297 (6 732133) (7 732163) (8 732193) (9 732222) (10 732252) (11 732281))
298 (2006 (12 732311) (1 732340) (2 732370) (3 732399) (4 732429) (5 732458)
299 (6 732488) (7 732517) (7.5 732547) (8 732576) (9 732606) (10 732636)
300 (11 732665))
301 (2007 (12 732695) (1 732725) (2 732754) (3 732783) (4 732813) (5 732842)
302 (6 732871) (7 732901) (8 732930) (9 732960) (10 732990) (11 733020))
303 (2008 (12 733049) (1 733079) (2 733109) (3 733138) (4 733167) (5 733197)
304 (6 733226) (7 733255) (8 733285) (9 733314) (10 733344) (11 733374))
305 (2009 (12 733403) (1 733433) (2 733463) (3 733493) (4 733522) (5 733551)
306 (5.5 733581) (6 733610) (7 733639) (8 733669) (9 733698) (10 733728)
307 (11 733757))
308 (2010 (12 733787) (1 733817) (2 733847) (3 733876) (4 733906) (5 733935)
309 (6 733965) (7 733994) (8 734023) (9 734053) (10 734082) (11 734112))
310 (2011 (12 734141) (1 734171) (2 734201) (3 734230) (4 734260) (5 734290)
311 (6 734319) (7 734349) (8 734378) (9 734407) (10 734437) (11 734466))
312 (2012 (12 734496) (1 734525) (2 734555) (3 734584) (4 734614) (4.5 734644)
313 (5 734673) (6 734703) (7 734732) (8 734762) (9 734791) (10 734821)
314 (11 734850))
315 (2013 (12 734880) (1 734909) (2 734939) (3 734968) (4 734998) (5 735027)
316 (6 735057) (7 735087) (8 735116) (9 735146) (10 735175) (11 735205))
317 (2014 (12 735234) (1 735264) (2 735293) (3 735323) (4 735352) (5 735382)
318 (6 735411) (7 735441) (8 735470) (9 735500) (9.5 735530) (10 735559)
319 (11 735589))
320 (2015 (12 735618) (1 735648) (2 735677) (3 735707) (4 735736) (5 735765)
321 (6 735795) (7 735824) (8 735854) (9 735884) (10 735914) (11 735943))
322 (2016 (12 735973) (1 736002) (2 736032) (3 736061) (4 736091) (5 736120)
323 (6 736149) (7 736179) (8 736208) (9 736238) (10 736268) (11 736297))
324 (2017 (12 736327) (1 736357) (2 736386) (3 736416) (4 736445) (5 736475)
325 (6 736504) (6.5 736533) (7 736563) (8 736592) (9 736622) (10 736651)
326 (11 736681))
327 (2018 (12 736711) (1 736741) (2 736770) (3 736800) (4 736829) (5 736859)
328 (6 736888) (7 736917) (8 736947) (9 736976) (10 737006) (11 737035))
329 (2019 (12 737065) (1 737095) (2 737125) (3 737154) (4 737184) (5 737213)
330 (6 737243) (7 737272) (8 737301) (9 737331) (10 737360) (11 737389))
331 (2020 (12 737419) (1 737449) (2 737478) (3 737508) (4 737538) (4.5 737568)
332 (5 737597) (6 737627) (7 737656) (8 737685) (9 737715) (10 737744)
333 (11 737774)))
334 "Alist of Chinese year structures as determined by `chinese-year'.
335The default can be nil, but some values are precomputed for efficiency.")
336
337(defun chinese-year (y)
338 "The structure of the Chinese year for Gregorian year Y.
339The result is a list of pairs (i d), where month i begins on absolute date d,
340of the Chinese months from the Chinese month following the solstice in
341Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y.
342The list is cached in `chinese-year-cache' for further use."
343 (let ((list (cdr (assoc y chinese-year-cache))))
344 (or list
345 (setq list (compute-chinese-year y)
346 chinese-year-cache (append chinese-year-cache
347 (list (cons y list)))))
348 list))
349
350;; Maintainer use.
351(defun chinese-year-cache-init (year)
352 "Insert an initialization value for `chinese-year-cache' after point.
353Computes values for 10 years either side of YEAR."
354 (setq year (- year 10))
355 (let (chinese-year-cache end)
356 (save-excursion
357 (insert "'(")
358 (dotimes (n 21)
359 (princ (cons year (compute-chinese-year year)) (current-buffer))
360 (insert (if (= n 20) ")" "\n"))
361 (setq year (1+ year)))
362 (setq end (point)))
363 (save-excursion
364 ;; fill-column -/+ 5.
365 (while (and (< (point) end)
366 (re-search-forward "^.\\{65,75\\})" end t))
367 (delete-char 1)
368 (insert "\n")))
369 (indent-region (point) end)))
370
0808d911
ER
371(defun calendar-absolute-from-chinese (date)
372 "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
465323b6
GM
373DATE is a Chinese date (cycle year month day). The Gregorian date
374Sunday, December 31, 1 BC is imaginary."
0808d911 375 (let* ((cycle (car date))
465323b6
GM
376 (year (cadr date))
377 (month (nth 2 date))
378 (day (nth 3 date))
4785bf2c
GM
379 (g-year (+ (* (1- cycle) 60) ; years in prior cycles
380 (1- year) ; prior years this cycle
381 -2636))) ; years before absolute date 0
382 (+ (1- day) ; prior days this month
465323b6
GM
383 (cadr ; absolute date of start of this month
384 (assoc month (append (memq (assoc 1 (chinese-year g-year))
385 (chinese-year g-year))
386 (chinese-year (1+ g-year))))))))
0808d911
ER
387
388(defun calendar-chinese-from-absolute (date)
389 "Compute Chinese date (cycle year month day) corresponding to absolute DATE.
390The absolute date is the number of days elapsed since the (imaginary)
391Gregorian date Sunday, December 31, 1 BC."
0031509c
ER
392 (let* ((g-year (extract-calendar-year
393 (calendar-gregorian-from-absolute date)))
00e3e480 394 (c-year (+ g-year 2695))
0031509c
ER
395 (list (append (chinese-year (1- g-year))
396 (chinese-year g-year)
397 (chinese-year (1+ g-year)))))
706531d9 398 (while (<= (cadr (cadr list)) date)
4785bf2c
GM
399 ;; The first month on the list is in Chinese year c-year.
400 ;; Date is on or after start of second month on list...
706531d9 401 (if (= 1 (caar (cdr list)))
4785bf2c 402 ;; Second month on list is a new Chinese year...
00e3e480 403 (setq c-year (1+ c-year)))
4785bf2c 404 ;; ...so first month on list is of no interest.
0031509c 405 (setq list (cdr list)))
00e3e480 406 (list (/ (1- c-year) 60)
c97663f6
GM
407 ;; Remainder of c-year/60 with 60 instead of 0.
408 (1+ (mod (1- c-year) 60))
706531d9
GM
409 (caar list)
410 (1+ (- date (cadr (car list)))))))
0808d911 411
465323b6
GM
412;; Bound in generate-calendar.
413(defvar displayed-month)
414(defvar displayed-year)
415
1d0c7fdf 416;;;###holiday-autoload
0808d911
ER
417(defun holiday-chinese-new-year ()
418 "Date of Chinese New Year."
419 (let ((m displayed-month)
420 (y displayed-year))
421 (increment-calendar-month m y 1)
422 (if (< m 5)
423 (let ((chinese-new-year
424 (calendar-gregorian-from-absolute
465323b6 425 (cadr (assoc 1 (chinese-year y))))))
0808d911 426 (if (calendar-date-is-visible-p chinese-new-year)
b4cb70c4
ER
427 (list
428 (list chinese-new-year
429 (format "Chinese New Year (%s)"
ba2a1fb0 430 (calendar-chinese-sexagesimal-name (+ y 57))))))))))
0808d911 431
1d0c7fdf 432;;;###cal-autoload
0808d911
ER
433(defun calendar-chinese-date-string (&optional date)
434 "String of Chinese date of Gregorian DATE.
435Defaults to today's date if DATE is not given."
436 (let* ((a-date (calendar-absolute-from-gregorian
437 (or date (calendar-current-date))))
438 (c-date (calendar-chinese-from-absolute a-date))
439 (cycle (car c-date))
465323b6
GM
440 (year (cadr c-date))
441 (month (nth 2 c-date))
442 (day (nth 3 c-date))
0808d911
ER
443 (this-month (calendar-absolute-from-chinese
444 (list cycle year month 1)))
445 (next-month (calendar-absolute-from-chinese
67d80173
ER
446 (list (if (= year 60) (1+ cycle) cycle)
447 (if (= (floor month) 12) (1+ year) year)
c97663f6
GM
448 ;; Remainder of (1+(floor month))/12, with
449 ;; 12 instead of 0.
450 (1+ (mod (floor month) 12))
67d80173 451 1)))
0031509c 452 (m-cycle (% (+ (* year 5) (floor month)) 60)))
b4cb70c4 453 (format "Cycle %s, year %s (%s), %smonth %s%s, day %s (%s)"
0808d911 454 cycle
ba2a1fb0 455 year (calendar-chinese-sexagesimal-name year)
0808d911
ER
456 (if (not (integerp month))
457 "second "
458 (if (< 30 (- next-month this-month))
459 "first "
460 ""))
0031509c 461 (floor month)
b4cb70c4 462 (if (integerp month)
ba2a1fb0 463 (format " (%s)" (calendar-chinese-sexagesimal-name
cc6e0522 464 (+ (* 12 year) month 50)))
b4cb70c4 465 "")
ba2a1fb0 466 day (calendar-chinese-sexagesimal-name (+ a-date 15)))))
b4cb70c4 467
1d0c7fdf 468;;;###cal-autoload
0808d911
ER
469(defun calendar-print-chinese-date ()
470 "Show the Chinese date equivalents of date."
471 (interactive)
472 (message "Computing Chinese date...")
473 (message "Chinese date: %s"
474 (calendar-chinese-date-string (calendar-cursor-to-date t))))
475
465323b6
GM
476(defun make-chinese-month-assoc-list (l)
477 "Make list of months L into an assoc list."
478 (and l (car l)
479 (if (and (cdr l) (cadr l))
480 (if (= (car l) (floor (cadr l)))
481 (append
482 (list (cons (format "%s (first)" (car l)) (car l))
483 (cons (format "%s (second)" (car l)) (cadr l)))
484 (make-chinese-month-assoc-list (cddr l)))
485 (append
486 (list (cons (int-to-string (car l)) (car l)))
487 (make-chinese-month-assoc-list (cdr l))))
488 (list (cons (int-to-string (car l)) (car l))))))
489
490(defun chinese-months (c y)
491 "A list of the months in cycle C, year Y of the Chinese calendar."
492 (memq 1 (append
493 (mapcar (lambda (x)
494 (car x))
495 (chinese-year (extract-calendar-year
496 (calendar-gregorian-from-absolute
497 (calendar-absolute-from-chinese
498 (list c y 1 1))))))
499 (mapcar (lambda (x)
500 (if (> (car x) 11) (car x)))
501 (chinese-year (extract-calendar-year
502 (calendar-gregorian-from-absolute
503 (calendar-absolute-from-chinese
504 (list (if (= y 60) (1+ c) c)
505 (if (= y 60) 1 y)
506 1 1)))))))))
507
1d0c7fdf 508;;;###cal-autoload
0808d911
ER
509(defun calendar-goto-chinese-date (date &optional noecho)
510 "Move cursor to Chinese date DATE.
465323b6 511Echo Chinese date unless NOECHO is non-nil."
0808d911
ER
512 (interactive
513 (let* ((c (calendar-chinese-from-absolute
465323b6 514 (calendar-absolute-from-gregorian (calendar-current-date))))
0808d911 515 (cycle (calendar-read
0031509c 516 "Chinese calendar cycle number (>44): "
bfcb5172 517 (lambda (x) (> x 44))
0808d911
ER
518 (int-to-string (car c))))
519 (year (calendar-read
0031509c 520 "Year in Chinese cycle (1..60): "
bfcb5172 521 (lambda (x) (and (<= 1 x) (<= x 60)))
465323b6 522 (int-to-string (cadr c))))
0031509c
ER
523 (month-list (make-chinese-month-assoc-list
524 (chinese-months cycle year)))
525 (month (cdr (assoc
526 (completing-read "Chinese calendar month: "
527 month-list nil t)
528 month-list)))
529 (last (if (= month
465323b6
GM
530 (nth 2
531 (calendar-chinese-from-absolute
532 (+ 29
533 (calendar-absolute-from-chinese
534 (list cycle year month 1))))))
0031509c
ER
535 30
536 29))
537 (day (calendar-read
538 (format "Chinese calendar day (1-%d): " last)
bfcb5172 539 (lambda (x) (and (<= 1 x) (<= x last))))))
0808d911
ER
540 (list (list cycle year month day))))
541 (calendar-goto-date (calendar-gregorian-from-absolute
542 (calendar-absolute-from-chinese date)))
543 (or noecho (calendar-print-chinese-date)))
544
d7af270b
GM
545(defvar date)
546
547;; To be called from list-sexp-diary-entries, where DATE is bound.
1d0c7fdf 548;;;###diary-autoload
0808d911
ER
549(defun diary-chinese-date ()
550 "Chinese calendar equivalent of date diary entry."
551 (format "Chinese date: %s" (calendar-chinese-date-string date)))
552
c86b6d44 553(provide 'cal-china)
0808d911 554
bfcb5172 555;; arch-tag: 7e5b7e0d-676c-47e3-8696-93e7ea0ab644
c86b6d44 556;;; cal-china.el ends here