Mercurial > emacs
comparison lisp/calendar/cal-china.el @ 92900:c6b7fe651716
Re-order so that functions are defined before use.
(displayed-month, displayed-year): Move declarations where needed.
(chinese-calendar-time-zone, calendar-goto-chinese-date): Doc fix.
(chinese-calendar-celestial-stem, chinese-calendar-terrestrial-branch):
Add doc strings.
(chinese-year-cache): Recenter on 2010. Doc fix.
(chinese-year, number-chinese-months, calendar-absolute-from-chinese):
Doc fix. Simplify.
(chinese-year-cache-init): New function.
(compute-chinese-year, holiday-chinese-new-year)
(calendar-chinese-date-string, calendar-goto-chinese-date)
(make-chinese-month-assoc-list): Use cadr, nth.
(chinese-months): Remove un-needed let.
author | Glenn Morris <rgm@gnu.org> |
---|---|
date | Fri, 14 Mar 2008 03:08:08 +0000 |
parents | 02fc7543d146 |
children | 4151ef80cb37 |
comparison
equal
deleted
inserted
replaced
92899:f1e7eae84755 | 92900:c6b7fe651716 |
---|---|
41 | 41 |
42 ;; Technical details of all the calendrical calculations can be found in | 42 ;; Technical details of all the calendrical calculations can be found in |
43 ;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold | 43 ;; ``Calendrical Calculations: The Millennium Edition'' by Edward M. Reingold |
44 ;; and Nachum Dershowitz, Cambridge University Press (2001). | 44 ;; and Nachum Dershowitz, Cambridge University Press (2001). |
45 | 45 |
46 ;; Note to maintainers: | |
47 ;; Use `chinese-year-cache-init' every few years to recenter the default | |
48 ;; value of `chinese-year-cache'. | |
49 | |
46 ;;; Code: | 50 ;;; Code: |
47 | |
48 (defvar displayed-month) | |
49 (defvar displayed-year) | |
50 | 51 |
51 (require 'lunar) | 52 (require 'lunar) |
52 | 53 |
53 (defgroup chinese-calendar nil | 54 (defgroup chinese-calendar nil |
54 "Chinese calendar support." | 55 "Chinese calendar support." |
57 (defcustom chinese-calendar-time-zone | 58 (defcustom chinese-calendar-time-zone |
58 '(if (< year 1928) | 59 '(if (< year 1928) |
59 (+ 465 (/ 40.0 60.0)) | 60 (+ 465 (/ 40.0 60.0)) |
60 480) | 61 480) |
61 "Minutes difference between local standard time for Chinese calendar and UTC. | 62 "Minutes difference between local standard time for Chinese calendar and UTC. |
62 Default is for Beijing. This is an expression in `year' since it changed at 1928-01-01 00:00:00 from UT+7:45:40 to UT+8." | 63 Default is for Beijing. This is an expression in `year' since it changed at |
64 1928-01-01 00:00:00 from UT+7:45:40 to UT+8." | |
63 :type 'sexp | 65 :type 'sexp |
64 :group 'chinese-calendar) | 66 :group 'chinese-calendar) |
65 | 67 |
66 (defcustom chinese-calendar-location-name "Beijing" | 68 (defcustom chinese-calendar-location-name "Beijing" |
67 "Name of location used for calculation of Chinese calendar." | 69 "Name of location used for calculation of Chinese calendar." |
128 | 130 |
129 ;;; End of user options. | 131 ;;; End of user options. |
130 | 132 |
131 | 133 |
132 (defconst chinese-calendar-celestial-stem | 134 (defconst chinese-calendar-celestial-stem |
133 ["Jia" "Yi" "Bing" "Ding" "Wu" "Ji" "Geng" "Xin" "Ren" "Gui"]) | 135 ["Jia" "Yi" "Bing" "Ding" "Wu" "Ji" "Geng" "Xin" "Ren" "Gui"] |
136 "Prefixes used by `calendar-chinese-sexagesimal-name'.") | |
134 | 137 |
135 (defconst chinese-calendar-terrestrial-branch | 138 (defconst chinese-calendar-terrestrial-branch |
136 ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"]) | 139 ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"] |
140 "Suffixes used by `calendar-chinese-sexagesimal-name'.") | |
141 | |
142 (defun calendar-chinese-sexagesimal-name (n) | |
143 "The N-th name of the Chinese sexagesimal cycle. | |
144 N congruent to 1 gives the first name, N congruent to 2 gives the second name, | |
145 ..., N congruent to 60 gives the sixtieth name." | |
146 (format "%s-%s" | |
147 (aref chinese-calendar-celestial-stem (% (1- n) 10)) | |
148 (aref chinese-calendar-terrestrial-branch (% (1- n) 12)))) | |
137 | 149 |
138 (defun chinese-zodiac-sign-on-or-after (d) | 150 (defun chinese-zodiac-sign-on-or-after (d) |
139 "Absolute date of first new Zodiac sign on or after absolute date D. | 151 "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." | 152 The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." |
141 (let* ((year (extract-calendar-year | 153 (let* ((year (extract-calendar-year (calendar-gregorian-from-absolute d))) |
142 (calendar-gregorian-from-absolute d))) | 154 (calendar-time-zone (eval chinese-calendar-time-zone)) ; uses year |
143 (calendar-time-zone (eval chinese-calendar-time-zone)) | |
144 (calendar-daylight-time-offset | 155 (calendar-daylight-time-offset |
145 chinese-calendar-daylight-time-offset) | 156 chinese-calendar-daylight-time-offset) |
146 (calendar-standard-time-zone-name | 157 (calendar-standard-time-zone-name |
147 chinese-calendar-standard-time-zone-name) | 158 chinese-calendar-standard-time-zone-name) |
148 (calendar-daylight-time-zone-name | 159 (calendar-daylight-time-zone-name |
155 chinese-calendar-daylight-savings-starts-time) | 166 chinese-calendar-daylight-savings-starts-time) |
156 (calendar-daylight-savings-ends-time | 167 (calendar-daylight-savings-ends-time |
157 chinese-calendar-daylight-savings-ends-time)) | 168 chinese-calendar-daylight-savings-ends-time)) |
158 (floor | 169 (floor |
159 (calendar-absolute-from-astro | 170 (calendar-absolute-from-astro |
160 (solar-date-next-longitude | 171 (solar-date-next-longitude (calendar-astro-from-absolute d) 30))))) |
161 (calendar-astro-from-absolute d) | |
162 30))))) | |
163 | 172 |
164 (defun chinese-new-moon-on-or-after (d) | 173 (defun chinese-new-moon-on-or-after (d) |
165 "Absolute date of first new moon on or after absolute date D." | 174 "Absolute date of first new moon on or after absolute date D." |
166 (let* ((year (extract-calendar-year | 175 (let* ((year (extract-calendar-year (calendar-gregorian-from-absolute d))) |
167 (calendar-gregorian-from-absolute d))) | |
168 (calendar-time-zone (eval chinese-calendar-time-zone)) | 176 (calendar-time-zone (eval chinese-calendar-time-zone)) |
169 (calendar-daylight-time-offset | 177 (calendar-daylight-time-offset |
170 chinese-calendar-daylight-time-offset) | 178 chinese-calendar-daylight-time-offset) |
171 (calendar-standard-time-zone-name | 179 (calendar-standard-time-zone-name |
172 chinese-calendar-standard-time-zone-name) | 180 chinese-calendar-standard-time-zone-name) |
180 chinese-calendar-daylight-savings-starts-time) | 188 chinese-calendar-daylight-savings-starts-time) |
181 (calendar-daylight-savings-ends-time | 189 (calendar-daylight-savings-ends-time |
182 chinese-calendar-daylight-savings-ends-time)) | 190 chinese-calendar-daylight-savings-ends-time)) |
183 (floor | 191 (floor |
184 (calendar-absolute-from-astro | 192 (calendar-absolute-from-astro |
185 (lunar-new-moon-on-or-after | 193 (lunar-new-moon-on-or-after (calendar-astro-from-absolute d)))))) |
186 (calendar-astro-from-absolute d)))))) | 194 |
195 (defun chinese-month-list (start end) | |
196 "List of starting dates of Chinese months from START to END." | |
197 (if (<= start end) | |
198 (let ((new-moon (chinese-new-moon-on-or-after start))) | |
199 (if (<= new-moon end) | |
200 (cons new-moon | |
201 (chinese-month-list (1+ new-moon) end)))))) | |
202 | |
203 (defun number-chinese-months (list start) | |
204 "Assign month numbers to the lunar months in LIST, starting with START. | |
205 Numbers are assigned sequentially, START, START+1, ..., 11, with | |
206 half numbers used for leap months. First and last months of list | |
207 are never leap months." | |
208 (when list | |
209 (cons (list start (car list)) ; first month | |
210 ;; Remaining months. | |
211 (if (zerop (- 12 start (length list))) | |
212 ;; List is too short for a leap month. | |
213 (number-chinese-months (cdr list) (1+ start)) | |
214 (if (and (cddr list) ; at least two more months... | |
215 (<= (car (cddr list)) | |
216 (chinese-zodiac-sign-on-or-after (cadr list)))) | |
217 ;; Next month is a leap month. | |
218 (cons (list (+ start 0.5) (cadr list)) | |
219 (number-chinese-months (cddr list) (1+ start))) | |
220 ;; Next month is not a leap month. | |
221 (number-chinese-months (cdr list) (1+ start))))))) | |
222 | |
223 (defun compute-chinese-year (y) | |
224 "Compute the structure of the Chinese year for Gregorian year Y. | |
225 The result is a list of pairs (i d), where month i begins on absolute date d, | |
226 of the Chinese months from the Chinese month following the solstice in | |
227 Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y." | |
228 (let* ((next-solstice (chinese-zodiac-sign-on-or-after | |
229 (calendar-absolute-from-gregorian | |
230 (list 12 15 y)))) | |
231 (list (chinese-month-list (1+ (chinese-zodiac-sign-on-or-after | |
232 (calendar-absolute-from-gregorian | |
233 (list 12 15 (1- y))))) | |
234 next-solstice)) | |
235 (next-sign (chinese-zodiac-sign-on-or-after (car list)))) | |
236 (if (= (length list) 12) | |
237 ;; No room for a leap month, just number them 12, 1, 2, ..., 11. | |
238 (cons (list 12 (car list)) | |
239 (number-chinese-months (cdr list) 1)) | |
240 ;; Now we can assign numbers to the list for y. | |
241 ;; The first month or two are special. | |
242 (if (or (> (car list) next-sign) (>= next-sign (cadr list))) | |
243 ;; First month on list is a leap month, second is not. | |
244 (append (list (list 11.5 (car list)) | |
245 (list 12 (cadr list))) | |
246 (number-chinese-months (cddr list) 1)) | |
247 ;; First month on list is not a leap month. | |
248 (append (list (list 12 (car list))) | |
249 (if (>= (chinese-zodiac-sign-on-or-after (cadr list)) | |
250 (nth 2 list)) | |
251 ;; Second month on list is a leap month. | |
252 (cons (list 12.5 (cadr list)) | |
253 (number-chinese-months (cddr list) 1)) | |
254 ;; Second month on list is not a leap month. | |
255 (number-chinese-months (cdr list) 1))))))) | |
187 | 256 |
188 (defvar chinese-year-cache | 257 (defvar chinese-year-cache |
189 '((1990 (12 726464) (1 726494) (2 726523) (3 726553) (4 726582) (5 726611) | 258 ;; Maintainers: delete existing value, position point at start of |
190 (5.5 726641) (6 726670) (7 726699) (8 726729) (9 726758) (10 726788) | 259 ;; empty line, then call M-: (chinese-year-cache-init N) |
191 (11 726818)) | 260 '((2000 (12 730126) (1 730155) (2 730185) (3 730215) (4 730244) (5 730273) |
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) | |
198 (11 727910)) | |
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) | |
203 (11 728649)) | |
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) | |
210 (11 729742)) | |
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)) | 261 (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) | 262 (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) | 263 (5 730657) (6 730687) (7 730716) (8 730745) (9 730775) (10 730804) |
217 (11 730834)) | 264 (11 730834)) |
218 (2002 (12 730863) (1 730893) (2 730923) (3 730953) (4 730982) (5 731012) | 265 (2002 (12 730863) (1 730893) (2 730923) (3 730953) (4 730982) (5 731012) |
233 (6 733226) (7 733255) (8 733285) (9 733314) (10 733344) (11 733374)) | 280 (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) | 281 (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) | 282 (5.5 733581) (6 733610) (7 733639) (8 733669) (9 733698) (10 733728) |
236 (11 733757)) | 283 (11 733757)) |
237 (2010 (12 733787) (1 733817) (2 733847) (3 733876) (4 733906) (5 733935) | 284 (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))) | 285 (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'. | 286 (2011 (12 734141) (1 734171) (2 734201) (3 734230) (4 734260) (5 734290) |
240 | 287 (6 734319) (7 734349) (8 734378) (9 734407) (10 734437) (11 734466)) |
241 Values are computed as needed, but to save time, the initial value consists | 288 (2012 (12 734496) (1 734525) (2 734555) (3 734584) (4 734614) (4.5 734644) |
242 of the precomputed years 1990-2010. The code works just as well with this | 289 (5 734673) (6 734703) (7 734732) (8 734762) (9 734791) (10 734821) |
243 set to nil initially (which is how the value for 1990-2010 was computed).") | 290 (11 734850)) |
291 (2013 (12 734880) (1 734909) (2 734939) (3 734968) (4 734998) (5 735027) | |
292 (6 735057) (7 735087) (8 735116) (9 735146) (10 735175) (11 735205)) | |
293 (2014 (12 735234) (1 735264) (2 735293) (3 735323) (4 735352) (5 735382) | |
294 (6 735411) (7 735441) (8 735470) (9 735500) (9.5 735530) (10 735559) | |
295 (11 735589)) | |
296 (2015 (12 735618) (1 735648) (2 735677) (3 735707) (4 735736) (5 735765) | |
297 (6 735795) (7 735824) (8 735854) (9 735884) (10 735914) (11 735943)) | |
298 (2016 (12 735973) (1 736002) (2 736032) (3 736061) (4 736091) (5 736120) | |
299 (6 736149) (7 736179) (8 736208) (9 736238) (10 736268) (11 736297)) | |
300 (2017 (12 736327) (1 736357) (2 736386) (3 736416) (4 736445) (5 736475) | |
301 (6 736504) (6.5 736533) (7 736563) (8 736592) (9 736622) (10 736651) | |
302 (11 736681)) | |
303 (2018 (12 736711) (1 736741) (2 736770) (3 736800) (4 736829) (5 736859) | |
304 (6 736888) (7 736917) (8 736947) (9 736976) (10 737006) (11 737035)) | |
305 (2019 (12 737065) (1 737095) (2 737125) (3 737154) (4 737184) (5 737213) | |
306 (6 737243) (7 737272) (8 737301) (9 737331) (10 737360) (11 737389)) | |
307 (2020 (12 737419) (1 737449) (2 737478) (3 737508) (4 737538) (4.5 737568) | |
308 (5 737597) (6 737627) (7 737656) (8 737685) (9 737715) (10 737744) | |
309 (11 737774))) | |
310 "Alist of Chinese year structures as determined by `chinese-year'. | |
311 The default can be nil, but some values are precomputed for efficiency.") | |
244 | 312 |
245 (defun chinese-year (y) | 313 (defun chinese-year (y) |
246 "The structure of the Chinese year for Gregorian year Y. | 314 "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, | 315 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 | 316 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. | 317 Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y. |
250 | 318 The list is cached in `chinese-year-cache' for further use." |
251 The list is cached for further use." | |
252 (let ((list (cdr (assoc y chinese-year-cache)))) | 319 (let ((list (cdr (assoc y chinese-year-cache)))) |
253 (if (not list) | 320 (or list |
254 (progn | 321 (setq list (compute-chinese-year y) |
255 (setq list (compute-chinese-year y)) | 322 chinese-year-cache (append chinese-year-cache |
256 (setq chinese-year-cache | 323 (list (cons y list))))) |
257 (append chinese-year-cache (list (cons y list)))))) | |
258 list)) | 324 list)) |
259 | 325 |
260 (defun number-chinese-months (list start) | 326 ;; Maintainer use. |
261 "Assign month numbers to the lunar months in LIST, starting with START. | 327 (defun chinese-year-cache-init (year) |
262 Numbers are assigned sequentially, START, START+1, ..., 11, with half | 328 "Insert an initialization value for `chinese-year-cache' after point. |
263 numbers used for leap months. | 329 Computes values for 10 years either side of YEAR." |
264 | 330 (setq year (- year 10)) |
265 First month of list will never be a leap month, nor will the last." | 331 (let (chinese-year-cache end) |
266 (if list | 332 (save-excursion |
267 (if (zerop (- 12 start (length list))) | 333 (insert "'(") |
268 ;; List is too short for a leap month. | 334 (dotimes (n 21) |
269 (cons (list start (car list)) | 335 (princ (cons year (compute-chinese-year year)) (current-buffer)) |
270 (number-chinese-months (cdr list) (1+ start))) | 336 (insert (if (= n 20) ")" "\n")) |
271 (cons | 337 (setq year (1+ year))) |
272 ;; First month. | 338 (setq end (point))) |
273 (list start (car list)) | 339 (save-excursion |
274 ;; Remaining months. | 340 ;; fill-column -/+ 5. |
275 (if (and (cdr (cdr list)) ; at least two more months... | 341 (while (and (< (point) end) |
276 (<= (car (cdr (cdr list))) | 342 (re-search-forward "^.\\{65,75\\})" end t)) |
277 (chinese-zodiac-sign-on-or-after (car (cdr list))))) | 343 (delete-char 1) |
278 ;; Next month is a leap month. | 344 (insert "\n"))) |
279 (cons (list (+ start 0.5) (car (cdr list))) | 345 (indent-region (point) end))) |
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))))))) | |
283 | |
284 (defun chinese-month-list (start end) | |
285 "List of starting dates of Chinese months from START to END." | |
286 (if (<= start end) | |
287 (let ((new-moon (chinese-new-moon-on-or-after start))) | |
288 (if (<= new-moon end) | |
289 (cons new-moon | |
290 (chinese-month-list (1+ new-moon) end)))))) | |
291 | |
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 | |
299 (list 12 15 y)))) | |
300 (list (chinese-month-list (1+ (chinese-zodiac-sign-on-or-after | |
301 (calendar-absolute-from-gregorian | |
302 (list 12 15 (1- y))))) | |
303 next-solstice)) | |
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))))))) | |
325 | 346 |
326 (defun calendar-absolute-from-chinese (date) | 347 (defun calendar-absolute-from-chinese (date) |
327 "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. | 348 "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." | 349 DATE is a Chinese date (cycle year month day). The Gregorian date |
350 Sunday, December 31, 1 BC is imaginary." | |
329 (let* ((cycle (car date)) | 351 (let* ((cycle (car date)) |
330 (year (car (cdr date))) | 352 (year (cadr date)) |
331 (month (car (cdr (cdr date)))) | 353 (month (nth 2 date)) |
332 (day (car (cdr (cdr (cdr date))))) | 354 (day (nth 3 date)) |
333 (g-year (+ (* (1- cycle) 60) ; years in prior cycles | 355 (g-year (+ (* (1- cycle) 60) ; years in prior cycles |
334 (1- year) ; prior years this cycle | 356 (1- year) ; prior years this cycle |
335 -2636))) ; years before absolute date 0 | 357 -2636))) ; years before absolute date 0 |
336 (+ (1- day) ; prior days this month | 358 (+ (1- day) ; prior days this month |
337 (car | 359 (cadr ; absolute date of start of this month |
338 (cdr ; absolute date of start of this month | 360 (assoc month (append (memq (assoc 1 (chinese-year g-year)) |
339 (assoc month (append (memq (assoc 1 (chinese-year g-year)) | 361 (chinese-year g-year)) |
340 (chinese-year g-year)) | 362 (chinese-year (1+ g-year)))))))) |
341 (chinese-year (1+ g-year))))))))) | |
342 | 363 |
343 (defun calendar-chinese-from-absolute (date) | 364 (defun calendar-chinese-from-absolute (date) |
344 "Compute Chinese date (cycle year month day) corresponding to absolute DATE. | 365 "Compute Chinese date (cycle year month day) corresponding to absolute DATE. |
345 The absolute date is the number of days elapsed since the (imaginary) | 366 The absolute date is the number of days elapsed since the (imaginary) |
346 Gregorian date Sunday, December 31, 1 BC." | 367 Gregorian date Sunday, December 31, 1 BC." |
361 (list (/ (1- c-year) 60) | 382 (list (/ (1- c-year) 60) |
362 (calendar-mod c-year 60) | 383 (calendar-mod c-year 60) |
363 (car (car list)) | 384 (car (car list)) |
364 (1+ (- date (car (cdr (car list)))))))) | 385 (1+ (- date (car (cdr (car list)))))))) |
365 | 386 |
387 ;; Bound in generate-calendar. | |
388 (defvar displayed-month) | |
389 (defvar displayed-year) | |
390 | |
366 ;;;###holiday-autoload | 391 ;;;###holiday-autoload |
367 (defun holiday-chinese-new-year () | 392 (defun holiday-chinese-new-year () |
368 "Date of Chinese New Year." | 393 "Date of Chinese New Year." |
369 (let ((m displayed-month) | 394 (let ((m displayed-month) |
370 (y displayed-year)) | 395 (y displayed-year)) |
371 (increment-calendar-month m y 1) | 396 (increment-calendar-month m y 1) |
372 (if (< m 5) | 397 (if (< m 5) |
373 (let ((chinese-new-year | 398 (let ((chinese-new-year |
374 (calendar-gregorian-from-absolute | 399 (calendar-gregorian-from-absolute |
375 (car (cdr (assoc 1 (chinese-year y))))))) | 400 (cadr (assoc 1 (chinese-year y)))))) |
376 (if (calendar-date-is-visible-p chinese-new-year) | 401 (if (calendar-date-is-visible-p chinese-new-year) |
377 (list | 402 (list |
378 (list chinese-new-year | 403 (list chinese-new-year |
379 (format "Chinese New Year (%s)" | 404 (format "Chinese New Year (%s)" |
380 (calendar-chinese-sexagesimal-name (+ y 57)))))))))) | 405 (calendar-chinese-sexagesimal-name (+ y 57)))))))))) |
385 Defaults to today's date if DATE is not given." | 410 Defaults to today's date if DATE is not given." |
386 (let* ((a-date (calendar-absolute-from-gregorian | 411 (let* ((a-date (calendar-absolute-from-gregorian |
387 (or date (calendar-current-date)))) | 412 (or date (calendar-current-date)))) |
388 (c-date (calendar-chinese-from-absolute a-date)) | 413 (c-date (calendar-chinese-from-absolute a-date)) |
389 (cycle (car c-date)) | 414 (cycle (car c-date)) |
390 (year (car (cdr c-date))) | 415 (year (cadr c-date)) |
391 (month (car (cdr (cdr c-date)))) | 416 (month (nth 2 c-date)) |
392 (day (car (cdr (cdr (cdr c-date))))) | 417 (day (nth 3 c-date)) |
393 (this-month (calendar-absolute-from-chinese | 418 (this-month (calendar-absolute-from-chinese |
394 (list cycle year month 1))) | 419 (list cycle year month 1))) |
395 (next-month (calendar-absolute-from-chinese | 420 (next-month (calendar-absolute-from-chinese |
396 (list (if (= year 60) (1+ cycle) cycle) | 421 (list (if (= year 60) (1+ cycle) cycle) |
397 (if (= (floor month) 12) (1+ year) year) | 422 (if (= (floor month) 12) (1+ year) year) |
411 (format " (%s)" (calendar-chinese-sexagesimal-name | 436 (format " (%s)" (calendar-chinese-sexagesimal-name |
412 (+ (* 12 year) month 50))) | 437 (+ (* 12 year) month 50))) |
413 "") | 438 "") |
414 day (calendar-chinese-sexagesimal-name (+ a-date 15))))) | 439 day (calendar-chinese-sexagesimal-name (+ a-date 15))))) |
415 | 440 |
416 (defun calendar-chinese-sexagesimal-name (n) | |
417 "The N-th name of the Chinese sexagesimal cycle. | |
418 N congruent to 1 gives the first name, N congruent to 2 gives the second name, | |
419 ..., N congruent to 60 gives the sixtieth name." | |
420 (format "%s-%s" | |
421 (aref chinese-calendar-celestial-stem (% (1- n) 10)) | |
422 (aref chinese-calendar-terrestrial-branch (% (1- n) 12)))) | |
423 | |
424 ;;;###cal-autoload | 441 ;;;###cal-autoload |
425 (defun calendar-print-chinese-date () | 442 (defun calendar-print-chinese-date () |
426 "Show the Chinese date equivalents of date." | 443 "Show the Chinese date equivalents of date." |
427 (interactive) | 444 (interactive) |
428 (message "Computing Chinese date...") | 445 (message "Computing Chinese date...") |
429 (message "Chinese date: %s" | 446 (message "Chinese date: %s" |
430 (calendar-chinese-date-string (calendar-cursor-to-date t)))) | 447 (calendar-chinese-date-string (calendar-cursor-to-date t)))) |
431 | 448 |
449 (defun make-chinese-month-assoc-list (l) | |
450 "Make list of months L into an assoc list." | |
451 (and l (car l) | |
452 (if (and (cdr l) (cadr l)) | |
453 (if (= (car l) (floor (cadr l))) | |
454 (append | |
455 (list (cons (format "%s (first)" (car l)) (car l)) | |
456 (cons (format "%s (second)" (car l)) (cadr l))) | |
457 (make-chinese-month-assoc-list (cddr l))) | |
458 (append | |
459 (list (cons (int-to-string (car l)) (car l))) | |
460 (make-chinese-month-assoc-list (cdr l)))) | |
461 (list (cons (int-to-string (car l)) (car l)))))) | |
462 | |
463 (defun chinese-months (c y) | |
464 "A list of the months in cycle C, year Y of the Chinese calendar." | |
465 (memq 1 (append | |
466 (mapcar (lambda (x) | |
467 (car x)) | |
468 (chinese-year (extract-calendar-year | |
469 (calendar-gregorian-from-absolute | |
470 (calendar-absolute-from-chinese | |
471 (list c y 1 1)))))) | |
472 (mapcar (lambda (x) | |
473 (if (> (car x) 11) (car x))) | |
474 (chinese-year (extract-calendar-year | |
475 (calendar-gregorian-from-absolute | |
476 (calendar-absolute-from-chinese | |
477 (list (if (= y 60) (1+ c) c) | |
478 (if (= y 60) 1 y) | |
479 1 1))))))))) | |
480 | |
432 ;;;###cal-autoload | 481 ;;;###cal-autoload |
433 (defun calendar-goto-chinese-date (date &optional noecho) | 482 (defun calendar-goto-chinese-date (date &optional noecho) |
434 "Move cursor to Chinese date DATE. | 483 "Move cursor to Chinese date DATE. |
435 Echo Chinese date unless NOECHO is t." | 484 Echo Chinese date unless NOECHO is non-nil." |
436 (interactive | 485 (interactive |
437 (let* ((c (calendar-chinese-from-absolute | 486 (let* ((c (calendar-chinese-from-absolute |
438 (calendar-absolute-from-gregorian | 487 (calendar-absolute-from-gregorian (calendar-current-date)))) |
439 (calendar-current-date)))) | |
440 (cycle (calendar-read | 488 (cycle (calendar-read |
441 "Chinese calendar cycle number (>44): " | 489 "Chinese calendar cycle number (>44): " |
442 (lambda (x) (> x 44)) | 490 (lambda (x) (> x 44)) |
443 (int-to-string (car c)))) | 491 (int-to-string (car c)))) |
444 (year (calendar-read | 492 (year (calendar-read |
445 "Year in Chinese cycle (1..60): " | 493 "Year in Chinese cycle (1..60): " |
446 (lambda (x) (and (<= 1 x) (<= x 60))) | 494 (lambda (x) (and (<= 1 x) (<= x 60))) |
447 (int-to-string (car (cdr c))))) | 495 (int-to-string (cadr c)))) |
448 (month-list (make-chinese-month-assoc-list | 496 (month-list (make-chinese-month-assoc-list |
449 (chinese-months cycle year))) | 497 (chinese-months cycle year))) |
450 (month (cdr (assoc | 498 (month (cdr (assoc |
451 (completing-read "Chinese calendar month: " | 499 (completing-read "Chinese calendar month: " |
452 month-list nil t) | 500 month-list nil t) |
453 month-list))) | 501 month-list))) |
454 (last (if (= month | 502 (last (if (= month |
455 (car (cdr (cdr | 503 (nth 2 |
456 (calendar-chinese-from-absolute | 504 (calendar-chinese-from-absolute |
457 (+ 29 | 505 (+ 29 |
458 (calendar-absolute-from-chinese | 506 (calendar-absolute-from-chinese |
459 (list cycle year month 1)))))))) | 507 (list cycle year month 1)))))) |
460 30 | 508 30 |
461 29)) | 509 29)) |
462 (day (calendar-read | 510 (day (calendar-read |
463 (format "Chinese calendar day (1-%d): " last) | 511 (format "Chinese calendar day (1-%d): " last) |
464 (lambda (x) (and (<= 1 x) (<= x last)))))) | 512 (lambda (x) (and (<= 1 x) (<= x last)))))) |
465 (list (list cycle year month day)))) | 513 (list (list cycle year month day)))) |
466 (calendar-goto-date (calendar-gregorian-from-absolute | 514 (calendar-goto-date (calendar-gregorian-from-absolute |
467 (calendar-absolute-from-chinese date))) | 515 (calendar-absolute-from-chinese date))) |
468 (or noecho (calendar-print-chinese-date))) | 516 (or noecho (calendar-print-chinese-date))) |
469 | 517 |
470 (defun chinese-months (c y) | |
471 "A list of the months in cycle C, year Y of the Chinese calendar." | |
472 (let* ((l (memq 1 (append | |
473 (mapcar (lambda (x) | |
474 (car x)) | |
475 (chinese-year (extract-calendar-year | |
476 (calendar-gregorian-from-absolute | |
477 (calendar-absolute-from-chinese | |
478 (list c y 1 1)))))) | |
479 (mapcar (lambda (x) | |
480 (if (> (car x) 11) (car x))) | |
481 (chinese-year (extract-calendar-year | |
482 (calendar-gregorian-from-absolute | |
483 (calendar-absolute-from-chinese | |
484 (list (if (= y 60) (1+ c) c) | |
485 (if (= y 60) 1 y) | |
486 1 1)))))))))) | |
487 l)) | |
488 | |
489 (defun make-chinese-month-assoc-list (l) | |
490 "Make list of months L into an assoc list." | |
491 (if (and l (car l)) | |
492 (if (and (cdr l) (car (cdr l))) | |
493 (if (= (car l) (floor (car (cdr l)))) | |
494 (append | |
495 (list (cons (format "%s (first)" (car l)) (car l)) | |
496 (cons (format "%s (second)" (car l)) (car (cdr l)))) | |
497 (make-chinese-month-assoc-list (cdr (cdr l)))) | |
498 (append | |
499 (list (cons (int-to-string (car l)) (car l))) | |
500 (make-chinese-month-assoc-list (cdr l)))) | |
501 (list (cons (int-to-string (car l)) (car l)))))) | |
502 | |
503 (defvar date) | 518 (defvar date) |
504 | 519 |
505 ;; To be called from list-sexp-diary-entries, where DATE is bound. | 520 ;; To be called from list-sexp-diary-entries, where DATE is bound. |
506 ;;;###diary-autoload | 521 ;;;###diary-autoload |
507 (defun diary-chinese-date () | 522 (defun diary-chinese-date () |