aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorGlenn Morris2008-03-14 03:08:33 +0000
committerGlenn Morris2008-03-14 03:08:33 +0000
commit465323b6648ebaf03f6af84644e1726213f70eef (patch)
tree187326c2e0c5a0757c512b30f8fdc81230c0c52b
parent75762c68d6057213331609f5a60608dbb79bfc3c (diff)
downloademacs-465323b6648ebaf03f6af84644e1726213f70eef.tar.gz
emacs-465323b6648ebaf03f6af84644e1726213f70eef.zip
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.
-rw-r--r--lisp/ChangeLog15
-rw-r--r--lisp/calendar/cal-china.el379
2 files changed, 212 insertions, 182 deletions
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index c23fdcd9db8..74ac07ed1a6 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -3,6 +3,21 @@
3 * startup.el (command-line-1): Rename -internal-script back to 3 * startup.el (command-line-1): Rename -internal-script back to
4 -scriptload (reverts previous change). 4 -scriptload (reverts previous change).
5 5
6 * calendar/cal-china.el: Re-order so that functions are defined before
7 use.
8 (displayed-month, displayed-year): Move declarations where needed.
9 (chinese-calendar-time-zone, calendar-goto-chinese-date): Doc fix.
10 (chinese-calendar-celestial-stem, chinese-calendar-terrestrial-branch):
11 Add doc strings.
12 (chinese-year-cache): Recenter on 2010. Doc fix.
13 (chinese-year, number-chinese-months, calendar-absolute-from-chinese):
14 Doc fix. Simplify.
15 (chinese-year-cache-init): New function.
16 (compute-chinese-year, holiday-chinese-new-year)
17 (calendar-chinese-date-string, calendar-goto-chinese-date)
18 (make-chinese-month-assoc-list): Use cadr, nth.
19 (chinese-months): Remove un-needed let.
20
6 * calendar/cal-coptic.el (coptic-calendar-month-name-array): 21 * calendar/cal-coptic.el (coptic-calendar-month-name-array):
7 (ethiopic-calendar-month-name-array, ethiopic-name): Add doc strings. 22 (ethiopic-calendar-month-name-array, ethiopic-name): Add doc strings.
8 (coptic-prompt-for-date): Move definition before use. 23 (coptic-prompt-for-date): Move definition before use.
diff --git a/lisp/calendar/cal-china.el b/lisp/calendar/cal-china.el
index eecd1bc525c..5581348baef 100644
--- a/lisp/calendar/cal-china.el
+++ b/lisp/calendar/cal-china.el
@@ -43,10 +43,11 @@
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;;; Code: 46;; Note to maintainers:
47;; Use `chinese-year-cache-init' every few years to recenter the default
48;; value of `chinese-year-cache'.
47 49
48(defvar displayed-month) 50;;; Code:
49(defvar displayed-year)
50 51
51(require 'lunar) 52(require 'lunar)
52 53
@@ -59,7 +60,8 @@
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.
62Default 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." 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."
63 :type 'sexp 65 :type 'sexp
64 :group 'chinese-calendar) 66 :group 'chinese-calendar)
65 67
@@ -130,17 +132,26 @@ Default is for no daylight saving time."
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.
144N 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.
140The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." 152The 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
@@ -157,14 +168,11 @@ The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
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)
@@ -182,104 +190,7 @@ The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
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))))))
187
188(defvar chinese-year-cache
189 '((1990 (12 726464) (1 726494) (2 726523) (3 726553) (4 726582) (5 726611)
190 (5.5 726641) (6 726670) (7 726699) (8 726729) (9 726758) (10 726788)
191 (11 726818))
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))
215 (2001 (12 730480) (1 730509) (2 730539) (3 730569) (4 730598) (4.5 730628)
216 (5 730657) (6 730687) (7 730716) (8 730745) (9 730775) (10 730804)
217 (11 730834))
218 (2002 (12 730863) (1 730893) (2 730923) (3 730953) (4 730982) (5 731012)
219 (6 731041) (7 731071) (8 731100) (9 731129) (10 731159) (11 731188))
220 (2003 (12 731218) (1 731247) (2 731277) (3 731307) (4 731336) (5 731366)
221 (6 731396) (7 731425) (8 731455) (9 731484) (10 731513) (11 731543))
222 (2004 (12 731572) (1 731602) (2 731631) (2.5 731661) (3 731690) (4 731720)
223 (5 731750) (6 731779) (7 731809) (8 731838) (9 731868) (10 731897)
224 (11 731927))
225 (2005 (12 731956) (1 731986) (2 732015) (3 732045) (4 732074) (5 732104)
226 (6 732133) (7 732163) (8 732193) (9 732222) (10 732252) (11 732281))
227 (2006 (12 732311) (1 732340) (2 732370) (3 732399) (4 732429) (5 732458)
228 (6 732488) (7 732517) (7.5 732547) (8 732576) (9 732606) (10 732636)
229 (11 732665))
230 (2007 (12 732695) (1 732725) (2 732754) (3 732783) (4 732813) (5 732842)
231 (6 732871) (7 732901) (8 732930) (9 732960) (10 732990) (11 733020))
232 (2008 (12 733049) (1 733079) (2 733109) (3 733138) (4 733167) (5 733197)
233 (6 733226) (7 733255) (8 733285) (9 733314) (10 733344) (11 733374))
234 (2009 (12 733403) (1 733433) (2 733463) (3 733493) (4 733522) (5 733551)
235 (5.5 733581) (6 733610) (7 733639) (8 733669) (9 733698) (10 733728)
236 (11 733757))
237 (2010 (12 733787) (1 733817) (2 733847) (3 733876) (4 733906) (5 733935)
238 (6 733965) (7 733994) (8 734023) (9 734053) (10 734082) (11 734112)))
239 "An assoc list of Chinese year structures as determined by `chinese-year'.
240
241Values are computed as needed, but to save time, the initial value consists
242of the precomputed years 1990-2010. The code works just as well with this
243set to nil initially (which is how the value for 1990-2010 was computed).")
244
245(defun chinese-year (y)
246 "The structure of the Chinese year for Gregorian year Y.
247The result is a list of pairs (i d), where month i begins on absolute date d,
248of the Chinese months from the Chinese month following the solstice in
249Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y.
250
251The list is cached for further use."
252 (let ((list (cdr (assoc y chinese-year-cache))))
253 (if (not list)
254 (progn
255 (setq list (compute-chinese-year y))
256 (setq chinese-year-cache
257 (append chinese-year-cache (list (cons y list))))))
258 list))
259
260(defun number-chinese-months (list start)
261 "Assign month numbers to the lunar months in LIST, starting with START.
262Numbers are assigned sequentially, START, START+1, ..., 11, with half
263numbers used for leap months.
264
265First month of list will never be a leap month, nor will the last."
266 (if list
267 (if (zerop (- 12 start (length list)))
268 ;; List is too short for a leap month.
269 (cons (list start (car list))
270 (number-chinese-months (cdr list) (1+ start)))
271 (cons
272 ;; First month.
273 (list start (car list))
274 ;; Remaining months.
275 (if (and (cdr (cdr list)) ; at least two more months...
276 (<= (car (cdr (cdr list)))
277 (chinese-zodiac-sign-on-or-after (car (cdr list)))))
278 ;; Next month is a leap month.
279 (cons (list (+ start 0.5) (car (cdr list)))
280 (number-chinese-months (cdr (cdr list)) (1+ start)))
281 ;; Next month is not a leap month.
282 (number-chinese-months (cdr list) (1+ start)))))))
283 194
284(defun chinese-month-list (start end) 195(defun chinese-month-list (start end)
285 "List of starting dates of Chinese months from START to END." 196 "List of starting dates of Chinese months from START to END."
@@ -289,6 +200,26 @@ First month of list will never be a leap month, nor will the last."
289 (cons new-moon 200 (cons new-moon
290 (chinese-month-list (1+ new-moon) end)))))) 201 (chinese-month-list (1+ new-moon) end))))))
291 202
203(defun number-chinese-months (list start)
204 "Assign month numbers to the lunar months in LIST, starting with START.
205Numbers are assigned sequentially, START, START+1, ..., 11, with
206half numbers used for leap months. First and last months of list
207are 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
292(defun compute-chinese-year (y) 223(defun compute-chinese-year (y)
293 "Compute the structure of the Chinese year for Gregorian year Y. 224 "Compute the structure of the Chinese year for Gregorian year Y.
294The result is a list of pairs (i d), where month i begins on absolute date d, 225The result is a list of pairs (i d), where month i begins on absolute date d,
@@ -308,37 +239,127 @@ Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y."
308 (number-chinese-months (cdr list) 1)) 239 (number-chinese-months (cdr list) 1))
309 ;; Now we can assign numbers to the list for y. 240 ;; Now we can assign numbers to the list for y.
310 ;; The first month or two are special. 241 ;; The first month or two are special.
311 (if (or (> (car list) next-sign) (>= next-sign (car (cdr list)))) 242 (if (or (> (car list) next-sign) (>= next-sign (cadr list)))
312 ;; First month on list is a leap month, second is not. 243 ;; First month on list is a leap month, second is not.
313 (append (list (list 11.5 (car list)) 244 (append (list (list 11.5 (car list))
314 (list 12 (car (cdr list)))) 245 (list 12 (cadr list)))
315 (number-chinese-months (cdr (cdr list)) 1)) 246 (number-chinese-months (cddr list) 1))
316 ;; First month on list is not a leap month. 247 ;; First month on list is not a leap month.
317 (append (list (list 12 (car list))) 248 (append (list (list 12 (car list)))
318 (if (>= (chinese-zodiac-sign-on-or-after (car (cdr list))) 249 (if (>= (chinese-zodiac-sign-on-or-after (cadr list))
319 (car (cdr (cdr list)))) 250 (nth 2 list))
320 ;; Second month on list is a leap month. 251 ;; Second month on list is a leap month.
321 (cons (list 12.5 (car (cdr list))) 252 (cons (list 12.5 (cadr list))
322 (number-chinese-months (cdr (cdr list)) 1)) 253 (number-chinese-months (cddr list) 1))
323 ;; Second month on list is not a leap month. 254 ;; Second month on list is not a leap month.
324 (number-chinese-months (cdr list) 1))))))) 255 (number-chinese-months (cdr list) 1)))))))
325 256
257(defvar chinese-year-cache
258 ;; Maintainers: delete existing value, position point at start of
259 ;; empty line, then call M-: (chinese-year-cache-init N)
260 '((2000 (12 730126) (1 730155) (2 730185) (3 730215) (4 730244) (5 730273)
261 (6 730303) (7 730332) (8 730361) (9 730391) (10 730420) (11 730450))
262 (2001 (12 730480) (1 730509) (2 730539) (3 730569) (4 730598) (4.5 730628)
263 (5 730657) (6 730687) (7 730716) (8 730745) (9 730775) (10 730804)
264 (11 730834))
265 (2002 (12 730863) (1 730893) (2 730923) (3 730953) (4 730982) (5 731012)
266 (6 731041) (7 731071) (8 731100) (9 731129) (10 731159) (11 731188))
267 (2003 (12 731218) (1 731247) (2 731277) (3 731307) (4 731336) (5 731366)
268 (6 731396) (7 731425) (8 731455) (9 731484) (10 731513) (11 731543))
269 (2004 (12 731572) (1 731602) (2 731631) (2.5 731661) (3 731690) (4 731720)
270 (5 731750) (6 731779) (7 731809) (8 731838) (9 731868) (10 731897)
271 (11 731927))
272 (2005 (12 731956) (1 731986) (2 732015) (3 732045) (4 732074) (5 732104)
273 (6 732133) (7 732163) (8 732193) (9 732222) (10 732252) (11 732281))
274 (2006 (12 732311) (1 732340) (2 732370) (3 732399) (4 732429) (5 732458)
275 (6 732488) (7 732517) (7.5 732547) (8 732576) (9 732606) (10 732636)
276 (11 732665))
277 (2007 (12 732695) (1 732725) (2 732754) (3 732783) (4 732813) (5 732842)
278 (6 732871) (7 732901) (8 732930) (9 732960) (10 732990) (11 733020))
279 (2008 (12 733049) (1 733079) (2 733109) (3 733138) (4 733167) (5 733197)
280 (6 733226) (7 733255) (8 733285) (9 733314) (10 733344) (11 733374))
281 (2009 (12 733403) (1 733433) (2 733463) (3 733493) (4 733522) (5 733551)
282 (5.5 733581) (6 733610) (7 733639) (8 733669) (9 733698) (10 733728)
283 (11 733757))
284 (2010 (12 733787) (1 733817) (2 733847) (3 733876) (4 733906) (5 733935)
285 (6 733965) (7 733994) (8 734023) (9 734053) (10 734082) (11 734112))
286 (2011 (12 734141) (1 734171) (2 734201) (3 734230) (4 734260) (5 734290)
287 (6 734319) (7 734349) (8 734378) (9 734407) (10 734437) (11 734466))
288 (2012 (12 734496) (1 734525) (2 734555) (3 734584) (4 734614) (4.5 734644)
289 (5 734673) (6 734703) (7 734732) (8 734762) (9 734791) (10 734821)
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'.
311The default can be nil, but some values are precomputed for efficiency.")
312
313(defun chinese-year (y)
314 "The structure of the Chinese year for Gregorian year Y.
315The result is a list of pairs (i d), where month i begins on absolute date d,
316of the Chinese months from the Chinese month following the solstice in
317Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y.
318The list is cached in `chinese-year-cache' for further use."
319 (let ((list (cdr (assoc y chinese-year-cache))))
320 (or list
321 (setq list (compute-chinese-year y)
322 chinese-year-cache (append chinese-year-cache
323 (list (cons y list)))))
324 list))
325
326;; Maintainer use.
327(defun chinese-year-cache-init (year)
328 "Insert an initialization value for `chinese-year-cache' after point.
329Computes values for 10 years either side of YEAR."
330 (setq year (- year 10))
331 (let (chinese-year-cache end)
332 (save-excursion
333 (insert "'(")
334 (dotimes (n 21)
335 (princ (cons year (compute-chinese-year year)) (current-buffer))
336 (insert (if (= n 20) ")" "\n"))
337 (setq year (1+ year)))
338 (setq end (point)))
339 (save-excursion
340 ;; fill-column -/+ 5.
341 (while (and (< (point) end)
342 (re-search-forward "^.\\{65,75\\})" end t))
343 (delete-char 1)
344 (insert "\n")))
345 (indent-region (point) end)))
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.
328The Gregorian date Sunday, December 31, 1 BC is imaginary." 349DATE is a Chinese date (cycle year month day). The Gregorian date
350Sunday, 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.
@@ -363,6 +384,10 @@ Gregorian date Sunday, December 31, 1 BC."
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."
@@ -372,7 +397,7 @@ Gregorian date Sunday, December 31, 1 BC."
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
@@ -387,9 +412,9 @@ Defaults to today's date if DATE is not given."
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
@@ -413,14 +438,6 @@ Defaults to today's date if DATE is not given."
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.
418N 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."
@@ -429,14 +446,45 @@ N congruent to 1 gives the first name, N congruent to 2 gives the second name,
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.
435Echo Chinese date unless NOECHO is t." 484Echo 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))
@@ -444,7 +492,7 @@ Echo Chinese date unless NOECHO is t."
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
@@ -452,11 +500,11 @@ Echo Chinese date unless NOECHO is t."
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
@@ -467,39 +515,6 @@ Echo Chinese date unless NOECHO is t."
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.