diff options
| author | Glenn Morris | 2008-03-14 03:08:33 +0000 |
|---|---|---|
| committer | Glenn Morris | 2008-03-14 03:08:33 +0000 |
| commit | 465323b6648ebaf03f6af84644e1726213f70eef (patch) | |
| tree | 187326c2e0c5a0757c512b30f8fdc81230c0c52b | |
| parent | 75762c68d6057213331609f5a60608dbb79bfc3c (diff) | |
| download | emacs-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/ChangeLog | 15 | ||||
| -rw-r--r-- | lisp/calendar/cal-china.el | 379 |
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. |
| 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 | ||
| @@ -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. | ||
| 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 |
| @@ -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 | |||
| 241 | Values are computed as needed, but to save time, the initial value consists | ||
| 242 | of the precomputed years 1990-2010. The code works just as well with this | ||
| 243 | set 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. | ||
| 247 | 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 | ||
| 249 | Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y. | ||
| 250 | |||
| 251 | The 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. | ||
| 262 | Numbers are assigned sequentially, START, START+1, ..., 11, with half | ||
| 263 | numbers used for leap months. | ||
| 264 | |||
| 265 | First 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. | ||
| 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 | |||
| 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. |
| 294 | The result is a list of pairs (i d), where month i begins on absolute date d, | 225 | The 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'. | ||
| 311 | The 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. | ||
| 315 | The result is a list of pairs (i d), where month i begins on absolute date d, | ||
| 316 | of the Chinese months from the Chinese month following the solstice in | ||
| 317 | Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y. | ||
| 318 | The 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. | ||
| 329 | Computes 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. |
| 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. |
| @@ -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. | ||
| 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." |
| @@ -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. |
| 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)) |
| @@ -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. |