Update copyright year to 2015
[emacs.git] / lisp / calendar / cal-china.el
blobb635eb60ababb0967645ed16e93e8ef6ac062a6c
1 ;;; cal-china.el --- calendar functions for the Chinese calendar
3 ;; Copyright (C) 1995, 1997, 2001-2015 Free Software Foundation, Inc.
5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
6 ;; Maintainer: Glenn Morris <rgm@gnu.org>
7 ;; Keywords: calendar
8 ;; Human-Keywords: Chinese calendar, calendar, holidays, diary
9 ;; Package: calendar
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 of the License, or
16 ;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>.
26 ;;; Commentary:
28 ;; See calendar.el.
30 ;; The rules used for the Chinese calendar are those of Baolin Liu
31 ;; (see L. E. Doggett's article "Calendars" in the Explanatory
32 ;; Supplement to the Astronomical Almanac, second edition, 1992) for
33 ;; the calendar as revised at the beginning of the Qing dynasty in
34 ;; 1644. The nature of the astronomical calculations is such that
35 ;; precise calculations cannot be made without great expense in time,
36 ;; so that the calendars produced may not agree perfectly with
37 ;; published tables--but no two pairs of published tables agree
38 ;; perfectly either! Liu's rules produce a calendar for 2033 which is
39 ;; not accepted by all authorities. The date of Chinese New Year is
40 ;; correct from 1644-2051.
42 ;; Note to maintainers:
43 ;; Use `chinese-year-cache-init' every few years to recenter the default
44 ;; value of `chinese-year-cache'.
46 ;;; Code:
48 (require 'calendar)
49 (require 'lunar) ; lunar-new-moon-on-or-after
50 ;; solar-date-next-longitude brought in by lunar.
51 ;;;(require 'solar)
52 ;; calendar-astro-to-absolute and from-absolute are cal-autoloads.
53 ;;;(require 'cal-julian)
56 (defgroup calendar-chinese nil
57 "Chinese calendar support."
58 :prefix "calendar-chinese-"
59 :group 'calendar)
61 (defcustom calendar-chinese-time-zone
62 '(if (< year 1928)
63 (+ 465 (/ 40.0 60.0))
64 480)
65 "Minutes difference between local standard time for Chinese calendar and UTC.
66 Default is for Beijing. This is an expression in `year' since it changed at
67 1928-01-01 00:00:00 from UT+7:45:40 to UT+8."
68 :type 'sexp
69 :group 'calendar-chinese)
71 ;; It gets eval'd.
72 ;;;###autoload
73 (put 'calendar-chinese-time-zone 'risky-local-variable t)
74 ;;;###autoload
75 (put 'chinese-calendar-time-zone 'risky-local-variable t)
78 ;; FIXME unused.
79 (defcustom calendar-chinese-location-name "Beijing"
80 "Name of location used for calculation of Chinese calendar."
81 :type 'string
82 :group 'calendar-chinese)
84 (defcustom calendar-chinese-daylight-time-offset 0
85 ;; The correct value is as follows, but the Chinese calendrical
86 ;; authorities do NOT use DST in determining astronomical events:
87 ;; 60
88 "Minutes difference between daylight saving and standard time.
89 Default is for no daylight saving time."
90 :type 'integer
91 :group 'calendar-chinese)
93 (defcustom calendar-chinese-standard-time-zone-name
94 '(if (< year 1928)
95 "PMT"
96 "CST")
97 "Abbreviated name of standard time zone used for Chinese calendar.
98 This is an expression depending on `year' because it changed
99 at 1928-01-01 00:00:00 from `PMT' to `CST'."
100 :type 'sexp
101 :group 'calendar-chinese)
103 (defcustom calendar-chinese-daylight-time-zone-name "CDT"
104 "Abbreviated name of daylight saving time zone used for Chinese calendar."
105 :type 'string
106 :group 'calendar-chinese)
108 (defcustom calendar-chinese-daylight-saving-start nil
109 ;; The correct value is as follows, but the Chinese calendrical
110 ;; authorities do NOT use DST in determining astronomical events:
111 ;; '(cond ((< 1986 year) (calendar-nth-named-day 1 0 4 year 10))
112 ;; ((= 1986 year) '(5 4 1986))
113 ;; (t nil))
114 "Sexp giving the date on which daylight saving time starts.
115 Default is for no daylight saving time. See documentation of
116 `calendar-daylight-savings-starts'."
117 :type 'sexp
118 :group 'calendar-chinese)
120 (defcustom calendar-chinese-daylight-saving-end nil
121 ;; The correct value is as follows, but the Chinese calendrical
122 ;; authorities do NOT use DST in determining astronomical events:
123 ;; '(if (<= 1986 year) (calendar-nth-named-day 1 0 9 year 11))
124 "Sexp giving the date on which daylight saving time ends.
125 Default is for no daylight saving time. See documentation of
126 `calendar-daylight-savings-ends'."
127 :type 'sexp
128 :group 'calendar-chinese)
130 (defcustom calendar-chinese-daylight-saving-start-time 0
131 "Number of minutes after midnight that daylight saving time starts.
132 Default is for no daylight saving time."
133 :type 'integer
134 :group 'calendar-chinese)
136 (defcustom calendar-chinese-daylight-saving-end-time 0
137 "Number of minutes after midnight that daylight saving time ends.
138 Default is for no daylight saving time."
139 :type 'integer
140 :group 'calendar-chinese)
142 (defcustom calendar-chinese-celestial-stem
143 ["Jia" "Yi" "Bing" "Ding" "Wu" "Ji" "Geng" "Xin" "Ren" "Gui"]
144 "Prefixes used by `calendar-chinese-sexagesimal-name'."
145 :group 'calendar-chinese
146 :type '(vector (string :tag "Jia")
147 (string :tag "Yi")
148 (string :tag "Bing")
149 (string :tag "Ding")
150 (string :tag "Wu")
151 (string :tag "Ji")
152 (string :tag "Geng")
153 (string :tag "Xin")
154 (string :tag "Ren")
155 (string :tag "Gui")))
157 (defcustom calendar-chinese-terrestrial-branch
158 ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"]
159 "Suffixes used by `calendar-chinese-sexagesimal-name'."
160 :group 'calendar-chinese
161 :type '(vector (string :tag "Zi")
162 (string :tag "Chou")
163 (string :tag "Yin")
164 (string :tag "Mao")
165 (string :tag "Chen")
166 (string :tag "Si")
167 (string :tag "Wu")
168 (string :tag "Wei")
169 (string :tag "Shen")
170 (string :tag "You")
171 (string :tag "Xu")
172 (string :tag "Hai")))
174 ;;; End of user options.
177 (defun calendar-chinese-sexagesimal-name (n)
178 "The N-th name of the Chinese sexagesimal cycle.
179 N congruent to 1 gives the first name, N congruent to 2 gives the second name,
180 ..., N congruent to 60 gives the sixtieth name."
181 (format "%s-%s"
182 (aref calendar-chinese-celestial-stem (% (1- n) 10))
183 (aref calendar-chinese-terrestrial-branch (% (1- n) 12))))
185 (defun calendar-chinese-zodiac-sign-on-or-after (d)
186 "Absolute date of first new Zodiac sign on or after absolute date D.
187 The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
188 (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
189 (calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year
190 (calendar-daylight-time-offset
191 calendar-chinese-daylight-time-offset)
192 (calendar-standard-time-zone-name
193 calendar-chinese-standard-time-zone-name)
194 (calendar-daylight-time-zone-name
195 calendar-chinese-daylight-time-zone-name)
196 (calendar-daylight-savings-starts
197 calendar-chinese-daylight-saving-start)
198 (calendar-daylight-savings-ends
199 calendar-chinese-daylight-saving-end)
200 (calendar-daylight-savings-starts-time
201 calendar-chinese-daylight-saving-start-time)
202 (calendar-daylight-savings-ends-time
203 calendar-chinese-daylight-saving-end-time))
204 (floor
205 (calendar-astro-to-absolute
206 (solar-date-next-longitude (calendar-astro-from-absolute d) 30)))))
208 (defun calendar-chinese-new-moon-on-or-after (d)
209 "Absolute date of first new moon on or after absolute date D."
210 (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
211 (calendar-time-zone (eval calendar-chinese-time-zone))
212 (calendar-daylight-time-offset
213 calendar-chinese-daylight-time-offset)
214 (calendar-standard-time-zone-name
215 calendar-chinese-standard-time-zone-name)
216 (calendar-daylight-time-zone-name
217 calendar-chinese-daylight-time-zone-name)
218 (calendar-daylight-savings-starts
219 calendar-chinese-daylight-saving-start)
220 (calendar-daylight-savings-ends
221 calendar-chinese-daylight-saving-end)
222 (calendar-daylight-savings-starts-time
223 calendar-chinese-daylight-saving-start-time)
224 (calendar-daylight-savings-ends-time
225 calendar-chinese-daylight-saving-end-time))
226 (floor
227 (calendar-astro-to-absolute
228 (lunar-new-moon-on-or-after (calendar-astro-from-absolute d))))))
230 (defun calendar-chinese-month-list (start end)
231 "List of starting dates of Chinese months from START to END."
232 (if (<= start end)
233 (let ((new-moon (calendar-chinese-new-moon-on-or-after start)))
234 (if (<= new-moon end)
235 (cons new-moon
236 (calendar-chinese-month-list (1+ new-moon) end))))))
238 (defun calendar-chinese-number-months (list start)
239 "Assign month numbers to the lunar months in LIST, starting with START.
240 Numbers are assigned sequentially, START, START+1, ..., 11, with
241 half numbers used for leap months. First and last months of list
242 are never leap months."
243 (when list
244 (cons (list start (car list)) ; first month
245 ;; Remaining months.
246 (if (zerop (- 12 start (length list)))
247 ;; List is too short for a leap month.
248 (calendar-chinese-number-months (cdr list) (1+ start))
249 (if (and (cddr list) ; at least two more months...
250 (<= (nth 2 list)
251 (calendar-chinese-zodiac-sign-on-or-after
252 (cadr list))))
253 ;; Next month is a leap month.
254 (cons (list (+ start 0.5) (cadr list))
255 (calendar-chinese-number-months (cddr list) (1+ start)))
256 ;; Next month is not a leap month.
257 (calendar-chinese-number-months (cdr list) (1+ start)))))))
259 (defun calendar-chinese-compute-year (y)
260 "Compute the structure of the Chinese year for Gregorian year Y.
261 The result is a list of pairs (i d), where month i begins on absolute date d,
262 of the Chinese months from the Chinese month following the solstice in
263 Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y."
264 (let* ((next-solstice (calendar-chinese-zodiac-sign-on-or-after
265 (calendar-absolute-from-gregorian
266 (list 12 15 y))))
267 (list (calendar-chinese-month-list
268 (1+ (calendar-chinese-zodiac-sign-on-or-after
269 (calendar-absolute-from-gregorian
270 (list 12 15 (1- y)))))
271 next-solstice))
272 (next-sign (calendar-chinese-zodiac-sign-on-or-after (car list))))
273 (if (= (length list) 12)
274 ;; No room for a leap month, just number them 12, 1, 2, ..., 11.
275 (cons (list 12 (car list))
276 (calendar-chinese-number-months (cdr list) 1))
277 ;; Now we can assign numbers to the list for y.
278 ;; The first month or two are special.
279 (if (or (> (car list) next-sign) (>= next-sign (cadr list)))
280 ;; First month on list is a leap month, second is not.
281 (append (list (list 11.5 (car list))
282 (list 12 (cadr list)))
283 (calendar-chinese-number-months (cddr list) 1))
284 ;; First month on list is not a leap month.
285 (append (list (list 12 (car list)))
286 (if (>= (calendar-chinese-zodiac-sign-on-or-after (cadr list))
287 (nth 2 list))
288 ;; Second month on list is a leap month.
289 (cons (list 12.5 (cadr list))
290 (calendar-chinese-number-months (cddr list) 1))
291 ;; Second month on list is not a leap month.
292 (calendar-chinese-number-months (cdr list) 1)))))))
294 (defvar calendar-chinese-year-cache
295 ;; Maintainers: delete existing value, position point at start of
296 ;; empty line, then call M-: (calendar-chinese-year-cache-init N)
297 '((2005 (12 731956) (1 731986) (2 732015) (3 732045) (4 732074) (5 732104)
298 (6 732133) (7 732163) (8 732193) (9 732222) (10 732252) (11 732281))
299 (2006 (12 732311) (1 732340) (2 732370) (3 732399) (4 732429) (5 732458)
300 (6 732488) (7 732517) (7.5 732547) (8 732576) (9 732606) (10 732636)
301 (11 732665))
302 (2007 (12 732695) (1 732725) (2 732754) (3 732783) (4 732813) (5 732842)
303 (6 732871) (7 732901) (8 732930) (9 732960) (10 732990) (11 733020))
304 (2008 (12 733049) (1 733079) (2 733109) (3 733138) (4 733167) (5 733197)
305 (6 733226) (7 733255) (8 733285) (9 733314) (10 733344) (11 733374))
306 (2009 (12 733403) (1 733433) (2 733463) (3 733493) (4 733522) (5 733551)
307 (5.5 733581) (6 733610) (7 733639) (8 733669) (9 733698) (10 733728)
308 (11 733757))
309 (2010 (12 733787) (1 733817) (2 733847) (3 733876) (4 733906) (5 733935)
310 (6 733965) (7 733994) (8 734023) (9 734053) (10 734082) (11 734112))
311 (2011 (12 734141) (1 734171) (2 734201) (3 734230) (4 734260) (5 734290)
312 (6 734319) (7 734349) (8 734378) (9 734407) (10 734437) (11 734466))
313 (2012 (12 734496) (1 734525) (2 734555) (3 734584) (4 734614) (4.5 734644)
314 (5 734673) (6 734703) (7 734732) (8 734762) (9 734791) (10 734821)
315 (11 734850))
316 (2013 (12 734880) (1 734909) (2 734939) (3 734968) (4 734998) (5 735027)
317 (6 735057) (7 735087) (8 735116) (9 735146) (10 735175) (11 735205))
318 (2014 (12 735234) (1 735264) (2 735293) (3 735323) (4 735352) (5 735382)
319 (6 735411) (7 735441) (8 735470) (9 735500) (9.5 735530) (10 735559)
320 (11 735589))
321 (2015 (12 735618) (1 735648) (2 735677) (3 735707) (4 735736) (5 735765)
322 (6 735795) (7 735824) (8 735854) (9 735884) (10 735914) (11 735943))
323 (2016 (12 735973) (1 736002) (2 736032) (3 736061) (4 736091) (5 736120)
324 (6 736149) (7 736179) (8 736208) (9 736238) (10 736268) (11 736297))
325 (2017 (12 736327) (1 736357) (2 736386) (3 736416) (4 736445) (5 736475)
326 (6 736504) (6.5 736533) (7 736563) (8 736592) (9 736622) (10 736651)
327 (11 736681))
328 (2018 (12 736711) (1 736741) (2 736770) (3 736800) (4 736829) (5 736859)
329 (6 736888) (7 736917) (8 736947) (9 736976) (10 737006) (11 737035))
330 (2019 (12 737065) (1 737095) (2 737125) (3 737154) (4 737184) (5 737213)
331 (6 737243) (7 737272) (8 737301) (9 737331) (10 737360) (11 737389))
332 (2020 (12 737419) (1 737449) (2 737478) (3 737508) (4 737538) (4.5 737568)
333 (5 737597) (6 737627) (7 737656) (8 737685) (9 737715) (10 737744)
334 (11 737774))
335 (2021 (12 737803) (1 737833) (2 737862) (3 737892) (4 737922) (5 737951)
336 (6 737981) (7 738010) (8 738040) (9 738069) (10 738099) (11 738128))
337 (2022 (12 738158) (1 738187) (2 738217) (3 738246) (4 738276) (5 738305)
338 (6 738335) (7 738365) (8 738394) (9 738424) (10 738453) (11 738483))
339 (2023 (12 738512) (1 738542) (2 738571) (2.5 738601) (3 738630) (4 738659)
340 (5 738689) (6 738719) (7 738748) (8 738778) (9 738808) (10 738837)
341 (11 738867))
342 (2024 (12 738896) (1 738926) (2 738955) (3 738985) (4 739014) (5 739043)
343 (6 739073) (7 739102) (8 739132) (9 739162) (10 739191) (11 739221))
344 (2025 (12 739251) (1 739280) (2 739310) (3 739339) (4 739369) (5 739398)
345 (6 739427) (6.5 739457) (7 739486) (8 739516) (9 739545) (10 739575)
346 (11 739605)))
347 "Alist of Chinese year structures as determined by `chinese-year'.
348 The default can be nil, but some values are precomputed for efficiency.")
350 (defun calendar-chinese-year (y)
351 "The structure of the Chinese year for Gregorian year Y.
352 The result is a list of pairs (i d), where month i begins on absolute date d,
353 of the Chinese months from the Chinese month following the solstice in
354 Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y.
355 The list is cached in `calendar-chinese-year-cache' for further use."
356 (let ((list (cdr (assoc y calendar-chinese-year-cache))))
357 (or list
358 (setq list (calendar-chinese-compute-year y)
359 calendar-chinese-year-cache (append calendar-chinese-year-cache
360 (list (cons y list)))))
361 list))
363 ;; Maintainer use.
364 (defun calendar-chinese-year-cache-init (year)
365 "Insert an initialization value for `calendar-chinese-year-cache' after point.
366 Computes values for 10 years either side of YEAR."
367 (setq year (- year 10))
368 (let (calendar-chinese-year-cache end)
369 (save-excursion
370 (insert "'(")
371 (dotimes (n 21)
372 (princ (cons year (calendar-chinese-compute-year year))
373 (current-buffer))
374 (insert (if (= n 20) ")" "\n"))
375 (setq year (1+ year)))
376 (setq end (point)))
377 (save-excursion
378 ;; fill-column -/+ 5.
379 (while (and (< (point) end)
380 (re-search-forward "^.\\{65,75\\})" end t))
381 (delete-char 1)
382 (insert "\n")))
383 (indent-region (point) end)))
385 (defun calendar-chinese-to-absolute (date)
386 "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
387 DATE is a Chinese date (cycle year month day). The Gregorian date
388 Sunday, December 31, 1 BC is imaginary."
389 (let* ((cycle (car date))
390 (year (cadr date))
391 (month (nth 2 date))
392 (day (nth 3 date))
393 (g-year (+ (* (1- cycle) 60) ; years in prior cycles
394 (1- year) ; prior years this cycle
395 -2636))) ; years before absolute date 0
396 (+ (1- day) ; prior days this month
397 (cadr ; absolute date of start of this month
398 (assoc month (append (memq (assoc 1 (calendar-chinese-year g-year))
399 (calendar-chinese-year g-year))
400 (calendar-chinese-year (1+ g-year))))))))
402 (defun calendar-chinese-from-absolute (date)
403 "Compute Chinese date (cycle year month day) corresponding to absolute DATE.
404 The absolute date is the number of days elapsed since the (imaginary)
405 Gregorian date Sunday, December 31, 1 BC."
406 (let* ((g-year (calendar-extract-year
407 (calendar-gregorian-from-absolute date)))
408 (c-year (+ g-year 2695))
409 (list (append (calendar-chinese-year (1- g-year))
410 (calendar-chinese-year g-year)
411 (calendar-chinese-year (1+ g-year)))))
412 (while (<= (cadr (cadr list)) date)
413 ;; The first month on the list is in Chinese year c-year.
414 ;; Date is on or after start of second month on list...
415 (if (= 1 (caar (cdr list)))
416 ;; Second month on list is a new Chinese year...
417 (setq c-year (1+ c-year)))
418 ;; ...so first month on list is of no interest.
419 (setq list (cdr list)))
420 (list (/ (1- c-year) 60)
421 ;; Remainder of c-year/60 with 60 instead of 0.
422 (1+ (mod (1- c-year) 60))
423 (caar list)
424 (1+ (- date (cadr (car list)))))))
426 ;; Bound in calendar-generate.
427 (defvar displayed-month)
428 (defvar displayed-year)
430 ;;;###holiday-autoload
431 (defun holiday-chinese-new-year ()
432 "Date of Chinese New Year, if visible in calendar.
433 Returns (((MONTH DAY YEAR) TEXT)), where the date is Gregorian."
434 (let ((m displayed-month)
435 (y displayed-year)
436 chinese-new-year)
437 ;; In the Gregorian calendar, CNY falls between Jan 21 and Feb 20.
438 ;; Jan is visible if displayed-month = 12, 1, 2; Feb if d-m = 1, 2, 3.
439 ;; If we shift the calendar forward one month, we can do a
440 ;; one-sided test, namely: d-m <= 4 means CNY might be visible.
441 (calendar-increment-month m y 1) ; shift forward a month
442 (and (< m 5)
443 (calendar-date-is-visible-p
444 (setq chinese-new-year
445 (calendar-gregorian-from-absolute
446 (cadr (assoc 1 (calendar-chinese-year y))))))
447 (list
448 (list chinese-new-year
449 (format "Chinese New Year (%s)"
450 (calendar-chinese-sexagesimal-name (+ y 57))))))))
452 ;;;###holiday-autoload
453 (defun holiday-chinese-qingming ()
454 "Date of Chinese Qingming Festival, if visible in calendar.
455 Returns (((MONTH DAY YEAR) TEXT)), where the date is Gregorian."
456 (when (memq displayed-month '(3 4 5)) ; is April visible?
457 (list (list (calendar-gregorian-from-absolute
458 ;; 15 days after Vernal Equinox.
459 (+ 15
460 (calendar-chinese-zodiac-sign-on-or-after
461 (calendar-absolute-from-gregorian
462 (list 3 15 displayed-year)))))
463 "Qingming Festival"))))
465 ;;;###holiday-autoload
466 (defun holiday-chinese-winter-solstice ()
467 "Date of Chinese winter solstice, if visible in calendar.
468 Returns (((MONTH DAY YEAR) TEXT)), where the date is Gregorian."
469 (when (memq displayed-month '(11 12 1)) ; is December visible?
470 (list (list (calendar-gregorian-from-absolute
471 (calendar-chinese-zodiac-sign-on-or-after
472 (calendar-absolute-from-gregorian
473 (list 12 15 (if (eq displayed-month 1)
474 (1- displayed-year)
475 displayed-year)))))
476 "Winter Solstice Festival"))))
478 ;;;###holiday-autoload
479 (defun holiday-chinese (month day string)
480 "Holiday on Chinese MONTH, DAY called STRING.
481 If MONTH, DAY (Chinese) is visible, returns the corresponding
482 Gregorian date as the list (((month day year) STRING)).
483 Returns nil if it is not visible in the current calendar window."
484 (let ((date
485 (calendar-gregorian-from-absolute
486 ;; A basic optimization. Chinese year can only change if
487 ;; Jan or Feb are visible. FIXME can we do more?
488 (if (memq displayed-month '(12 1 2 3))
489 ;; This is calendar-nongregorian-visible-p adapted for
490 ;; the form of chinese dates: (cycle year month day) as
491 ;; opposed to (month day year).
492 (let* ((m1 displayed-month)
493 (y1 displayed-year)
494 (m2 displayed-month)
495 (y2 displayed-year)
496 ;; Absolute date of first/last dates in calendar window.
497 (start-date (progn
498 (calendar-increment-month m1 y1 -1)
499 (calendar-absolute-from-gregorian
500 (list m1 1 y1))))
501 (end-date (progn
502 (calendar-increment-month m2 y2 1)
503 (calendar-absolute-from-gregorian
504 (list m2 (calendar-last-day-of-month m2 y2)
505 y2))))
506 ;; Local date of first/last date in calendar window.
507 (local-start (calendar-chinese-from-absolute start-date))
508 (local-end (calendar-chinese-from-absolute end-date))
509 ;; When Chinese New Year is visible on the far
510 ;; right of the calendar, what is the earliest
511 ;; Chinese month in the previous year that might
512 ;; still visible? This test doesn't have to be precise.
513 (local (if (< month 10) local-end local-start))
514 (cycle (car local))
515 (year (cadr local)))
516 (calendar-chinese-to-absolute (list cycle year month day)))
517 ;; Simple form for when new years are not visible.
518 (+ (cadr (assoc month (calendar-chinese-year displayed-year)))
519 (1- day))))))
520 (if (calendar-date-is-visible-p date)
521 (list (list date string)))))
523 ;;;###cal-autoload
524 (defun calendar-chinese-date-string (&optional date)
525 "String of Chinese date of Gregorian DATE.
526 Defaults to today's date if DATE is not given."
527 (let* ((a-date (calendar-absolute-from-gregorian
528 (or date (calendar-current-date))))
529 (c-date (calendar-chinese-from-absolute a-date))
530 (cycle (car c-date))
531 (year (cadr c-date))
532 (month (nth 2 c-date))
533 (day (nth 3 c-date))
534 (this-month (calendar-chinese-to-absolute
535 (list cycle year month 1)))
536 (next-month (calendar-chinese-to-absolute
537 (list (if (= year 60) (1+ cycle) cycle)
538 (if (= (floor month) 12) (1+ year) year)
539 ;; Remainder of (1+(floor month))/12, with
540 ;; 12 instead of 0.
541 (1+ (mod (floor month) 12))
542 1))))
543 (format "Cycle %s, year %s (%s), %smonth %s%s, day %s (%s)"
544 cycle
545 year (calendar-chinese-sexagesimal-name year)
546 (if (not (integerp month))
547 "second "
548 (if (< 30 (- next-month this-month))
549 "first "
550 ""))
551 (floor month)
552 (if (integerp month)
553 (format " (%s)" (calendar-chinese-sexagesimal-name
554 (+ (* 12 year) month 50)))
556 day (calendar-chinese-sexagesimal-name (+ a-date 15)))))
558 ;;;###cal-autoload
559 (defun calendar-chinese-print-date ()
560 "Show the Chinese date equivalents of date."
561 (interactive)
562 (message "Computing Chinese date...")
563 (message "Chinese date: %s"
564 (calendar-chinese-date-string (calendar-cursor-to-date t))))
566 (defun calendar-chinese-months-to-alist (l)
567 "Make list of months L into an assoc list."
568 (and l (car l)
569 (if (and (cdr l) (cadr l))
570 (if (= (car l) (floor (cadr l)))
571 (append
572 (list (cons (format "%s (first)" (car l)) (car l))
573 (cons (format "%s (second)" (car l)) (cadr l)))
574 (calendar-chinese-months-to-alist (cddr l)))
575 (append
576 (list (cons (number-to-string (car l)) (car l)))
577 (calendar-chinese-months-to-alist (cdr l))))
578 (list (cons (number-to-string (car l)) (car l))))))
580 (defun calendar-chinese-months (c y)
581 "A list of the months in cycle C, year Y of the Chinese calendar."
582 (memq 1 (append
583 (mapcar (lambda (x)
584 (car x))
585 (calendar-chinese-year (calendar-extract-year
586 (calendar-gregorian-from-absolute
587 (calendar-chinese-to-absolute
588 (list c y 1 1))))))
589 (mapcar (lambda (x)
590 (if (> (car x) 11) (car x)))
591 (calendar-chinese-year (calendar-extract-year
592 (calendar-gregorian-from-absolute
593 (calendar-chinese-to-absolute
594 (list (if (= y 60) (1+ c) c)
595 (if (= y 60) 1 y)
596 1 1)))))))))
598 ;;;###cal-autoload
599 (defun calendar-chinese-goto-date (date &optional noecho)
600 "Move cursor to Chinese date DATE.
601 Echo Chinese date unless NOECHO is non-nil."
602 (interactive
603 (let* ((c (calendar-chinese-from-absolute
604 (calendar-absolute-from-gregorian (calendar-current-date))))
605 (cycle (calendar-read
606 "Chinese calendar cycle number (>44): "
607 (lambda (x) (> x 44))
608 (number-to-string (car c))))
609 (year (calendar-read
610 "Year in Chinese cycle (1..60): "
611 (lambda (x) (and (<= 1 x) (<= x 60)))
612 (number-to-string (cadr c))))
613 (month-list (calendar-chinese-months-to-alist
614 (calendar-chinese-months cycle year)))
615 (month (cdr (assoc
616 (completing-read "Chinese calendar month: "
617 month-list nil t)
618 month-list)))
619 (last (if (= month
620 (nth 2
621 (calendar-chinese-from-absolute
622 (+ 29
623 (calendar-chinese-to-absolute
624 (list cycle year month 1))))))
626 29))
627 (day (calendar-read
628 (format "Chinese calendar day (1-%d): " last)
629 (lambda (x) (and (<= 1 x) (<= x last))))))
630 (list (list cycle year month day))))
631 (calendar-goto-date (calendar-gregorian-from-absolute
632 (calendar-chinese-to-absolute date)))
633 (or noecho (calendar-chinese-print-date)))
635 (defvar date)
637 ;; To be called from diary-list-sexp-entries, where DATE is bound.
638 ;;;###diary-autoload
639 (defun diary-chinese-date ()
640 "Chinese calendar equivalent of date diary entry."
641 (format "Chinese date: %s" (calendar-chinese-date-string date)))
643 ;;;; diary support
645 (autoload 'calendar-mark-1 "diary-lib")
646 (autoload 'diary-mark-entries-1 "diary-lib")
647 (autoload 'diary-list-entries-1 "diary-lib")
648 (autoload 'diary-insert-entry-1 "diary-lib")
649 (autoload 'diary-date-display-form "diary-lib")
650 (autoload 'diary-make-date "diary-lib")
651 (autoload 'diary-ordinal-suffix "diary-lib")
652 (defvar diary-sexp-entry-symbol)
653 (defvar entry) ;used by `diary-chinese-anniversary'
655 (defvar calendar-chinese-month-name-array
656 ["正月" "二月" "三月" "四月" "五月" "六月"
657 "七月" "八月" "九月" "十月" "冬月" "臘月"])
659 ;;; NOTE: In the diary the cycle and year of a Chinese date is
660 ;;; combined using this formula: (+ (* cycle 100) year).
662 ;;; These two functions convert to and back from this representation.
663 (defun calendar-chinese-from-absolute-for-diary (date)
664 (pcase-let ((`(,c ,y ,m ,d) (calendar-chinese-from-absolute date)))
665 ;; Note: For leap months M is a float.
666 (list (floor m) d (+ (* c 100) y))))
668 (defun calendar-chinese-to-absolute-for-diary (date &optional prefer-leap)
669 (pcase-let* ((`(,m ,d ,y) date)
670 (cycle (floor y 100))
671 (year (mod y 100))
672 (months (calendar-chinese-months cycle year))
673 (lm (+ (floor m) 0.5)))
674 (calendar-chinese-to-absolute
675 (if (and prefer-leap (memql lm months))
676 (list cycle year lm d)
677 (list cycle year m d)))))
679 (defun calendar-chinese-mark-date-pattern (month day year &optional color)
680 (calendar-mark-1 month day year
681 #'calendar-chinese-from-absolute-for-diary
682 #'calendar-chinese-to-absolute-for-diary
683 color)
684 (unless (zerop month)
685 (calendar-mark-1 month day year
686 #'calendar-chinese-from-absolute-for-diary
687 (lambda (date) (calendar-chinese-to-absolute-for-diary date t))
688 color)))
690 ;;;###cal-autoload
691 (defun diary-chinese-mark-entries ()
692 "Mark days in the calendar window that have Chinese date diary entries.
693 Marks each entry in `diary-file' (or included files) visible in the calendar
694 window. See `diary-chinese-list-entries' for more information.
696 This function is provided for use with `diary-nongregorian-marking-hook'."
697 (diary-mark-entries-1 #'calendar-chinese-mark-date-pattern
698 calendar-chinese-month-name-array
699 diary-chinese-entry-symbol
700 #'calendar-chinese-from-absolute-for-diary))
702 ;;;###cal-autoload
703 (defun diary-chinese-list-entries ()
704 "Add any Chinese date entries from the diary file to `diary-entries-list'.
705 Chinese date diary entries must be prefixed by `diary-chinese-entry-symbol'
706 \(normally a `C'). The same `diary-date-forms' govern the style
707 of the Chinese calendar entries. If a Chinese date diary entry begins with
708 `diary-nonmarking-symbol', the entry will appear in the diary listing,
709 but will not be marked in the calendar.
711 This function is provided for use with `diary-nongregorian-listing-hook'."
712 (diary-list-entries-1 calendar-chinese-month-name-array
713 diary-chinese-entry-symbol
714 #'calendar-chinese-from-absolute-for-diary))
716 ;;;###cal-autoload
717 (defun diary-chinese-anniversary (month day &optional year mark)
718 "Like `diary-anniversary' (which see) but accepts Chinese date."
719 (pcase-let* ((ddate (diary-make-date month day year))
720 (`(,dc ,dy ,dm ,dd) ;diary chinese date
721 (if year
722 (calendar-chinese-from-absolute
723 (calendar-chinese-to-absolute-for-diary ddate))
724 (list nil nil (calendar-extract-month ddate)
725 (calendar-extract-day ddate))))
726 (`(,cc ,cy ,cm ,cd) ;current chinese date
727 (calendar-chinese-from-absolute
728 (calendar-absolute-from-gregorian date)))
729 (diff (if (and dc dy)
730 (+ (* 60 (- cc dc)) (- cy dy))
731 100)))
732 (and (> diff 0)
733 ;; The Chinese month can differ by 0.5 in a leap month.
734 (or (= dm cm) (= (+ 0.5 dm) cm))
735 (= dd cd)
736 (cons mark (format entry diff (diary-ordinal-suffix diff))))))
738 ;;;###cal-autoload
739 (defun diary-chinese-insert-anniversary-entry (&optional arg)
740 "Insert an anniversary diary entry for the Chinese date at point.
741 Prefix argument ARG makes the entry nonmarking."
742 (interactive "P")
743 (let ((calendar-date-display-form (diary-date-display-form)))
744 (diary-make-entry
745 (format "%s(diary-chinese-anniversary %s)"
746 diary-sexp-entry-symbol
747 (calendar-date-string
748 (calendar-chinese-from-absolute-for-diary
749 (calendar-absolute-from-gregorian (calendar-cursor-to-date t)))))
750 arg)))
752 ;;;###cal-autoload
753 (defun diary-chinese-insert-entry (&optional arg)
754 "Insert a diary entry for the Chinese date at point."
755 (interactive "P")
756 (diary-insert-entry-1 nil arg calendar-chinese-month-name-array
757 diary-chinese-entry-symbol
758 #'calendar-chinese-from-absolute-for-diary))
760 ;;;###cal-autoload
761 (defun diary-chinese-insert-monthly-entry (&optional arg)
762 "Insert a monthly diary entry for the Chinese date at point."
763 (interactive "P")
764 (diary-insert-entry-1 'monthly arg calendar-chinese-month-name-array
765 diary-chinese-entry-symbol
766 #'calendar-chinese-from-absolute-for-diary))
768 ;;;###cal-autoload
769 (defun diary-chinese-insert-yearly-entry (&optional arg)
770 "Insert a yearly diary entry for the Chinese date at point."
771 (interactive "P")
772 (diary-insert-entry-1 'yearly arg calendar-chinese-month-name-array
773 diary-chinese-entry-symbol
774 #'calendar-chinese-from-absolute-for-diary))
776 (provide 'cal-china)
778 ;;; cal-china.el ends here