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