cal-china.el 26.9 KB
Newer Older
1
;;; cal-china.el --- calendar functions for the Chinese calendar
Edward M. Reingold's avatar
Edward M. Reingold committed
2

Glenn Morris's avatar
Glenn Morris committed
3 4
;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
;;   2008  Free Software Foundation, Inc.
Edward M. Reingold's avatar
Edward M. Reingold committed
5 6

;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
7
;; Maintainer: Glenn Morris <rgm@gnu.org>
Edward M. Reingold's avatar
Edward M. Reingold committed
8 9 10 11 12 13 14
;; Keywords: calendar
;; Human-Keywords: Chinese calendar, calendar, holidays, diary

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
15
;; the Free Software Foundation; either version 3, or (at your option)
Edward M. Reingold's avatar
Edward M. Reingold committed
16 17 18 19 20 21 22 23
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
Erik Naggum's avatar
Erik Naggum committed
24
;; along with GNU Emacs; see the file COPYING.  If not, write to the
Lute Kamstra's avatar
Lute Kamstra committed
25 26
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
Edward M. Reingold's avatar
Edward M. Reingold committed
27 28 29

;;; Commentary:

30 31 32 33 34 35 36 37 38 39 40 41 42
;; See calendar.el.

;; The rules used for the Chinese calendar are those of Baolin Liu
;; (see L. E. Doggett's article "Calendars" in the Explanatory
;; Supplement to the Astronomical Almanac, second edition, 1992) for
;; the calendar as revised at the beginning of the Qing dynasty in
;; 1644.  The nature of the astronomical calculations is such that
;; precise calculations cannot be made without great expense in time,
;; so that the calendars produced may not agree perfectly with
;; published tables--but no two pairs of published tables agree
;; perfectly either!  Liu's rules produce a calendar for 2033 which is
;; not accepted by all authorities.  The date of Chinese New Year is
;; correct from 1644-2051.
43

44 45 46
;; Note to maintainers:
;; Use `chinese-year-cache-init' every few years to recenter the default
;; value of `chinese-year-cache'.
Edward M. Reingold's avatar
Edward M. Reingold committed
47

48
;;; Code:
49

Glenn Morris's avatar
Glenn Morris committed
50 51 52 53
(require 'calendar)
(require 'lunar)                        ; lunar-new-moon-on-or-after
;; solar-date-next-longitude brought in by lunar.
;;;(require 'solar)
54
;; calendar-astro-to-absolute and from-absolute are cal-autoloads.
Glenn Morris's avatar
Glenn Morris committed
55 56
;;;(require 'cal-julian)

Edward M. Reingold's avatar
Edward M. Reingold committed
57

58
(defgroup calendar-chinese nil
59
  "Chinese calendar support."
60
  :prefix "calendar-chinese-"
61
  :group 'calendar)
Edward M. Reingold's avatar
Edward M. Reingold committed
62

63
(defcustom calendar-chinese-time-zone
Edward M. Reingold's avatar
Edward M. Reingold committed
64 65 66
  '(if (< year 1928)
       (+ 465 (/ 40.0 60.0))
     480)
67
  "Minutes difference between local standard time for Chinese calendar and UTC.
68 69
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."
70
  :type 'sexp
71
  :group 'calendar-chinese)
Edward M. Reingold's avatar
Edward M. Reingold committed
72

73 74 75 76 77
(define-obsolete-variable-alias 'chinese-calendar-time-zone
  'calendar-chinese-time-zone "23.1")

;; FIXME unused.
(defcustom calendar-chinese-location-name "Beijing"
78
  "Name of location used for calculation of Chinese calendar."
79
  :type 'string
80 81 82 83
  :group 'calendar-chinese)

(define-obsolete-variable-alias 'chinese-calendar-location-name
  'calendar-chinese-location-name "23.1")
Edward M. Reingold's avatar
Edward M. Reingold committed
84

85
(defcustom calendar-chinese-daylight-time-offset 0
Glenn Morris's avatar
Glenn Morris committed
86 87 88
;; The correct value is as follows, but the Chinese calendrical
;; authorities do NOT use DST in determining astronomical events:
;;  60
89 90
  "Minutes difference between daylight saving and standard time.
Default is for no daylight saving time."
91
  :type 'integer
92 93 94 95
  :group 'calendar-chinese)

(define-obsolete-variable-alias 'chinese-calendar-daylight-time-offset
  'calendar-chinese-daylight-time-offset "23.1")
Edward M. Reingold's avatar
Edward M. Reingold committed
96

97
(defcustom calendar-chinese-standard-time-zone-name
Edward M. Reingold's avatar
Edward M. Reingold committed
98 99 100
  '(if (< year 1928)
       "PMT"
     "CST")
101
  "Abbreviated name of standard time zone used for Chinese calendar.
102 103 104
This is an expression depending on `year' because it changed
at 1928-01-01 00:00:00 from `PMT' to `CST'."
  :type 'sexp
105
  :group 'calendar-chinese)
Edward M. Reingold's avatar
Edward M. Reingold committed
106

107 108 109 110
(define-obsolete-variable-alias 'chinese-calendar-standard-time-zone-name
  'calendar-chinese-standard-time-zone-name "23.1")

(defcustom calendar-chinese-daylight-time-zone-name "CDT"
111
  "Abbreviated name of daylight saving time zone used for Chinese calendar."
112
  :type 'string
113 114 115 116
  :group 'calendar-chinese)

(define-obsolete-variable-alias 'chinese-calendar-daylight-time-zone-name
  'calendar-chinese-daylight-time-zone-name "23.1")
Edward M. Reingold's avatar
Edward M. Reingold committed
117

118
(defcustom calendar-chinese-daylight-saving-start nil
Glenn Morris's avatar
Glenn Morris committed
119 120 121 122 123
;; The correct value is as follows, but the Chinese calendrical
;; authorities do NOT use DST in determining astronomical events:
;;  '(cond ((< 1986 year) (calendar-nth-named-day 1 0 4 year 10))
;;         ((= 1986 year) '(5 4 1986))
;;         (t nil))
124 125
  "Sexp giving the date on which daylight saving time starts.
Default is for no daylight saving time.  See documentation of
126 127
`calendar-daylight-savings-starts'."
  :type 'sexp
128
  :group 'calendar-chinese)
Edward M. Reingold's avatar
Edward M. Reingold committed
129

130 131 132 133
(define-obsolete-variable-alias 'chinese-calendar-daylight-savings-starts
  'calendar-chinese-daylight-saving-start "23.1")

(defcustom calendar-chinese-daylight-saving-end nil
Glenn Morris's avatar
Glenn Morris committed
134 135 136
;; The correct value is as follows, but the Chinese calendrical
;; authorities do NOT use DST in determining astronomical events:
;;  '(if (<= 1986 year) (calendar-nth-named-day 1 0 9 year 11))
137 138
  "Sexp giving the date on which daylight saving time ends.
Default is for no daylight saving time.  See documentation of
139 140
`calendar-daylight-savings-ends'."
  :type 'sexp
141 142 143 144
  :group 'calendar-chinese)

(define-obsolete-variable-alias 'chinese-calendar-daylight-savings-ends
  'calendar-chinese-daylight-saving-end "23.1")
Edward M. Reingold's avatar
Edward M. Reingold committed
145

146
(defcustom calendar-chinese-daylight-saving-start-time 0
147 148
  "Number of minutes after midnight that daylight saving time starts.
Default is for no daylight saving time."
149
  :type 'integer
150
  :group 'calendar-chinese)
Edward M. Reingold's avatar
Edward M. Reingold committed
151

152 153 154 155
(define-obsolete-variable-alias 'chinese-calendar-daylight-savings-starts-time
  'calendar-chinese-daylight-saving-start-time "23.1")

(defcustom calendar-chinese-daylight-saving-end-time 0
156 157
  "Number of minutes after midnight that daylight saving time ends.
Default is for no daylight saving time."
158
  :type 'integer
159 160 161 162
  :group 'calendar-chinese)

(define-obsolete-variable-alias 'chinese-calendar-daylight-savings-ends-time
  'calendar-chinese-daylight-saving-end-time "23.1")
Edward M. Reingold's avatar
Edward M. Reingold committed
163

164
(defcustom calendar-chinese-celestial-stem
165
  ["Jia" "Yi" "Bing" "Ding" "Wu" "Ji" "Geng" "Xin" "Ren" "Gui"]
166
  "Prefixes used by `calendar-chinese-sexagesimal-name'."
167
  :group 'calendar-chinese
168 169 170 171 172 173 174 175 176 177 178
  :type '(vector (string :tag "Jia")
                 (string :tag "Yi")
                 (string :tag "Bing")
                 (string :tag "Ding")
                 (string :tag "Wu")
                 (string :tag "Ji")
                 (string :tag "Geng")
                 (string :tag "Xin")
                 (string :tag "Ren")
                 (string :tag "Gui")))

179 180 181 182
(define-obsolete-variable-alias 'chinese-calendar-celestial-stem
  'calendar-chinese-celestial-stem "23.1")

(defcustom calendar-chinese-terrestrial-branch
183
  ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"]
184
  "Suffixes used by `calendar-chinese-sexagesimal-name'."
185
  :group 'calendar-chinese
186 187 188 189 190 191 192 193 194 195 196 197 198
  :type '(vector (string :tag "Zi")
                 (string :tag "Chou")
                 (string :tag "Yin")
                 (string :tag "Mao")
                 (string :tag "Chen")
                 (string :tag "Si")
                 (string :tag "Wu")
                 (string :tag "Wei")
                 (string :tag "Shen")
                 (string :tag "You")
                 (string :tag "Xu")
                 (string :tag "Hai")))

199 200 201
(define-obsolete-variable-alias 'chinese-calendar-terrestrial-branch
  'calendar-chinese-terrestrial-branch "23.1")

202 203
;;; End of user options.

204 205 206 207 208 209

(defun calendar-chinese-sexagesimal-name (n)
  "The N-th name of the Chinese sexagesimal cycle.
N congruent to 1 gives the first name, N congruent to 2 gives the second name,
..., N congruent to 60 gives the sixtieth name."
  (format "%s-%s"
210 211
          (aref calendar-chinese-celestial-stem (% (1- n) 10))
          (aref calendar-chinese-terrestrial-branch (% (1- n) 12))))
212

213
(defun calendar-chinese-zodiac-sign-on-or-after (d)
214
  "Absolute date of first new Zodiac sign on or after absolute date D.
Edward M. Reingold's avatar
Edward M. Reingold committed
215
The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
216
 (let* ((year (extract-calendar-year (calendar-gregorian-from-absolute d)))
217
         (calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year
Edward M. Reingold's avatar
Edward M. Reingold committed
218
         (calendar-daylight-time-offset
219
          calendar-chinese-daylight-time-offset)
Edward M. Reingold's avatar
Edward M. Reingold committed
220
         (calendar-standard-time-zone-name
221
          calendar-chinese-standard-time-zone-name)
Edward M. Reingold's avatar
Edward M. Reingold committed
222
         (calendar-daylight-time-zone-name
223 224 225
          calendar-chinese-daylight-time-zone-name)
         (calendar-daylight-savings-starts
          calendar-chinese-daylight-saving-start)
Edward M. Reingold's avatar
Edward M. Reingold committed
226
         (calendar-daylight-savings-ends
227
          calendar-chinese-daylight-saving-end)
Edward M. Reingold's avatar
Edward M. Reingold committed
228
         (calendar-daylight-savings-starts-time
229
          calendar-chinese-daylight-saving-start-time)
Edward M. Reingold's avatar
Edward M. Reingold committed
230
         (calendar-daylight-savings-ends-time
231
          calendar-chinese-daylight-saving-end-time))
Edward M. Reingold's avatar
Edward M. Reingold committed
232
   (floor
233
    (calendar-astro-to-absolute
234
     (solar-date-next-longitude (calendar-astro-from-absolute d) 30)))))
Edward M. Reingold's avatar
Edward M. Reingold committed
235

236
(defun calendar-chinese-new-moon-on-or-after (d)
237
  "Absolute date of first new moon on or after absolute date D."
238
  (let* ((year (extract-calendar-year (calendar-gregorian-from-absolute d)))
239
         (calendar-time-zone (eval calendar-chinese-time-zone))
Edward M. Reingold's avatar
Edward M. Reingold committed
240
         (calendar-daylight-time-offset
241
          calendar-chinese-daylight-time-offset)
Edward M. Reingold's avatar
Edward M. Reingold committed
242
         (calendar-standard-time-zone-name
243
          calendar-chinese-standard-time-zone-name)
Edward M. Reingold's avatar
Edward M. Reingold committed
244
         (calendar-daylight-time-zone-name
245 246 247
          calendar-chinese-daylight-time-zone-name)
         (calendar-daylight-savings-starts
          calendar-chinese-daylight-saving-start)
Edward M. Reingold's avatar
Edward M. Reingold committed
248
         (calendar-daylight-savings-ends
249
          calendar-chinese-daylight-saving-end)
Edward M. Reingold's avatar
Edward M. Reingold committed
250
         (calendar-daylight-savings-starts-time
251
          calendar-chinese-daylight-saving-start-time)
Edward M. Reingold's avatar
Edward M. Reingold committed
252
         (calendar-daylight-savings-ends-time
253
          calendar-chinese-daylight-saving-end-time))
Edward M. Reingold's avatar
Edward M. Reingold committed
254
    (floor
255
     (calendar-astro-to-absolute
256
      (lunar-new-moon-on-or-after (calendar-astro-from-absolute d))))))
Edward M. Reingold's avatar
Edward M. Reingold committed
257

258
(defun calendar-chinese-month-list (start end)
Edward M. Reingold's avatar
Edward M. Reingold committed
259 260
  "List of starting dates of Chinese months from START to END."
  (if (<= start end)
261
      (let ((new-moon (calendar-chinese-new-moon-on-or-after start)))
Edward M. Reingold's avatar
Edward M. Reingold committed
262
        (if (<= new-moon end)
Edward M. Reingold's avatar
Edward M. Reingold committed
263
            (cons new-moon
264
                  (calendar-chinese-month-list (1+ new-moon) end))))))
Edward M. Reingold's avatar
Edward M. Reingold committed
265

266
(defun calendar-chinese-number-months (list start)
267 268 269 270 271 272 273 274 275
  "Assign month numbers to the lunar months in LIST, starting with START.
Numbers are assigned sequentially, START, START+1, ..., 11, with
half numbers used for leap months.  First and last months of list
are never leap months."
  (when list
    (cons (list start (car list))       ; first month
          ;; Remaining months.
          (if (zerop (- 12 start (length list)))
              ;; List is too short for a leap month.
276
              (calendar-chinese-number-months (cdr list) (1+ start))
277
            (if (and (cddr list)        ; at least two more months...
278
                     (<= (nth 2 list)
279 280
                         (calendar-chinese-zodiac-sign-on-or-after
                          (cadr list))))
281 282
                ;; Next month is a leap month.
                (cons (list (+ start 0.5) (cadr list))
283
                      (calendar-chinese-number-months (cddr list) (1+ start)))
284
              ;; Next month is not a leap month.
285
              (calendar-chinese-number-months (cdr list) (1+ start)))))))
286

287
(defun calendar-chinese-compute-year (y)
Edward M. Reingold's avatar
Edward M. Reingold committed
288
  "Compute the structure of the Chinese year for Gregorian year Y.
Edward M. Reingold's avatar
Edward M. Reingold committed
289
The result is a list of pairs (i d), where month i begins on absolute date d,
Edward M. Reingold's avatar
Edward M. Reingold committed
290 291
of the Chinese months from the Chinese month following the solstice in
Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y."
292
  (let* ((next-solstice (calendar-chinese-zodiac-sign-on-or-after
Edward M. Reingold's avatar
Edward M. Reingold committed
293 294
                         (calendar-absolute-from-gregorian
                          (list 12 15 y))))
295 296 297 298 299 300
         (list (calendar-chinese-month-list
                (1+ (calendar-chinese-zodiac-sign-on-or-after
                     (calendar-absolute-from-gregorian
                      (list 12 15 (1- y)))))
                next-solstice))
         (next-sign (calendar-chinese-zodiac-sign-on-or-after (car list))))
Edward M. Reingold's avatar
Edward M. Reingold committed
301
    (if (= (length list) 12)
Glenn Morris's avatar
Glenn Morris committed
302
        ;; No room for a leap month, just number them 12, 1, 2, ..., 11.
Edward M. Reingold's avatar
Edward M. Reingold committed
303
        (cons (list 12 (car list))
304
              (calendar-chinese-number-months (cdr list) 1))
Glenn Morris's avatar
Glenn Morris committed
305 306
      ;; Now we can assign numbers to the list for y.
      ;; The first month or two are special.
307
      (if (or (> (car list) next-sign) (>= next-sign (cadr list)))
Glenn Morris's avatar
Glenn Morris committed
308
          ;; First month on list is a leap month, second is not.
Edward M. Reingold's avatar
Edward M. Reingold committed
309
          (append (list (list 11.5 (car list))
310
                        (list 12 (cadr list)))
311
                  (calendar-chinese-number-months (cddr list) 1))
Glenn Morris's avatar
Glenn Morris committed
312
        ;; First month on list is not a leap month.
Edward M. Reingold's avatar
Edward M. Reingold committed
313
        (append (list (list 12 (car list)))
314
                (if (>= (calendar-chinese-zodiac-sign-on-or-after (cadr list))
315
                        (nth 2 list))
Glenn Morris's avatar
Glenn Morris committed
316
                    ;; Second month on list is a leap month.
317
                    (cons (list 12.5 (cadr list))
318
                          (calendar-chinese-number-months (cddr list) 1))
Glenn Morris's avatar
Glenn Morris committed
319
                  ;; Second month on list is not a leap month.
320
                  (calendar-chinese-number-months (cdr list) 1)))))))
Edward M. Reingold's avatar
Edward M. Reingold committed
321

322
(defvar calendar-chinese-year-cache
323
  ;; Maintainers: delete existing value, position point at start of
324
  ;; empty line, then call  M-: (calendar-chinese-year-cache-init N)
325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377
  '((2000 (12 730126) (1 730155) (2 730185) (3 730215) (4 730244) (5 730273)
          (6 730303) (7 730332) (8 730361) (9 730391) (10 730420) (11 730450))
    (2001 (12 730480) (1 730509) (2 730539) (3 730569) (4 730598) (4.5 730628)
          (5 730657) (6 730687) (7 730716) (8 730745) (9 730775) (10 730804)
          (11 730834))
    (2002 (12 730863) (1 730893) (2 730923) (3 730953) (4 730982) (5 731012)
          (6 731041) (7 731071) (8 731100) (9 731129) (10 731159) (11 731188))
    (2003 (12 731218) (1 731247) (2 731277) (3 731307) (4 731336) (5 731366)
          (6 731396) (7 731425) (8 731455) (9 731484) (10 731513) (11 731543))
    (2004 (12 731572) (1 731602) (2 731631) (2.5 731661) (3 731690) (4 731720)
          (5 731750) (6 731779) (7 731809) (8 731838) (9 731868) (10 731897)
          (11 731927))
    (2005 (12 731956) (1 731986) (2 732015) (3 732045) (4 732074) (5 732104)
          (6 732133) (7 732163) (8 732193) (9 732222) (10 732252) (11 732281))
    (2006 (12 732311) (1 732340) (2 732370) (3 732399) (4 732429) (5 732458)
          (6 732488) (7 732517) (7.5 732547) (8 732576) (9 732606) (10 732636)
          (11 732665))
    (2007 (12 732695) (1 732725) (2 732754) (3 732783) (4 732813) (5 732842)
          (6 732871) (7 732901) (8 732930) (9 732960) (10 732990) (11 733020))
    (2008 (12 733049) (1 733079) (2 733109) (3 733138) (4 733167) (5 733197)
          (6 733226) (7 733255) (8 733285) (9 733314) (10 733344) (11 733374))
    (2009 (12 733403) (1 733433) (2 733463) (3 733493) (4 733522) (5 733551)
          (5.5 733581) (6 733610) (7 733639) (8 733669) (9 733698) (10 733728)
          (11 733757))
    (2010 (12 733787) (1 733817) (2 733847) (3 733876) (4 733906) (5 733935)
          (6 733965) (7 733994) (8 734023) (9 734053) (10 734082) (11 734112))
    (2011 (12 734141) (1 734171) (2 734201) (3 734230) (4 734260) (5 734290)
          (6 734319) (7 734349) (8 734378) (9 734407) (10 734437) (11 734466))
    (2012 (12 734496) (1 734525) (2 734555) (3 734584) (4 734614) (4.5 734644)
          (5 734673) (6 734703) (7 734732) (8 734762) (9 734791) (10 734821)
          (11 734850))
    (2013 (12 734880) (1 734909) (2 734939) (3 734968) (4 734998) (5 735027)
          (6 735057) (7 735087) (8 735116) (9 735146) (10 735175) (11 735205))
    (2014 (12 735234) (1 735264) (2 735293) (3 735323) (4 735352) (5 735382)
          (6 735411) (7 735441) (8 735470) (9 735500) (9.5 735530) (10 735559)
          (11 735589))
    (2015 (12 735618) (1 735648) (2 735677) (3 735707) (4 735736) (5 735765)
          (6 735795) (7 735824) (8 735854) (9 735884) (10 735914) (11 735943))
    (2016 (12 735973) (1 736002) (2 736032) (3 736061) (4 736091) (5 736120)
          (6 736149) (7 736179) (8 736208) (9 736238) (10 736268) (11 736297))
    (2017 (12 736327) (1 736357) (2 736386) (3 736416) (4 736445) (5 736475)
          (6 736504) (6.5 736533) (7 736563) (8 736592) (9 736622) (10 736651)
          (11 736681))
    (2018 (12 736711) (1 736741) (2 736770) (3 736800) (4 736829) (5 736859)
          (6 736888) (7 736917) (8 736947) (9 736976) (10 737006) (11 737035))
    (2019 (12 737065) (1 737095) (2 737125) (3 737154) (4 737184) (5 737213)
          (6 737243) (7 737272) (8 737301) (9 737331) (10 737360) (11 737389))
    (2020 (12 737419) (1 737449) (2 737478) (3 737508) (4 737538) (4.5 737568)
          (5 737597) (6 737627) (7 737656) (8 737685) (9 737715) (10 737744)
          (11 737774)))
  "Alist of Chinese year structures as determined by `chinese-year'.
The default can be nil, but some values are precomputed for efficiency.")

378
(defun calendar-chinese-year (y)
379 380 381 382
  "The structure of the Chinese year for Gregorian year Y.
The result is a list of pairs (i d), where month i begins on absolute date d,
of the Chinese months from the Chinese month following the solstice in
Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y.
383 384
The list is cached in `calendar-chinese-year-cache' for further use."
  (let ((list (cdr (assoc y calendar-chinese-year-cache))))
385
    (or list
386 387
        (setq list (calendar-chinese-compute-year y)
              calendar-chinese-year-cache (append calendar-chinese-year-cache
388 389 390 391
                                         (list (cons y list)))))
    list))

;; Maintainer use.
392 393
(defun calendar-chinese-year-cache-init (year)
  "Insert an initialization value for `calendar-chinese-year-cache' after point.
394 395
Computes values for 10 years either side of YEAR."
  (setq year (- year 10))
396
  (let (calendar-chinese-year-cache end)
397 398 399
    (save-excursion
      (insert "'(")
      (dotimes (n 21)
400 401
        (princ (cons year (calendar-chinese-compute-year year))
               (current-buffer))
Glenn Morris's avatar
Glenn Morris committed
402 403
        (insert (if (= n 20) ")" "\n"))
        (setq year (1+ year)))
404 405 406 407 408 409 410 411 412
      (setq end (point)))
    (save-excursion
      ;; fill-column -/+ 5.
      (while (and (< (point) end)
                  (re-search-forward "^.\\{65,75\\})" end t))
        (delete-char 1)
        (insert "\n")))
    (indent-region (point) end)))

413
(defun calendar-chinese-to-absolute (date)
Edward M. Reingold's avatar
Edward M. Reingold committed
414
  "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
415 416
DATE is a Chinese date (cycle year month day).  The Gregorian date
Sunday, December 31, 1 BC is imaginary."
Edward M. Reingold's avatar
Edward M. Reingold committed
417
  (let* ((cycle (car date))
418 419 420
         (year (cadr date))
         (month (nth 2 date))
         (day (nth 3 date))
Glenn Morris's avatar
Glenn Morris committed
421 422 423 424
         (g-year (+ (* (1- cycle) 60)  ; years in prior cycles
                    (1- year)          ; prior years this cycle
                    -2636)))           ; years before absolute date 0
    (+ (1- day)                        ; prior days this month
425
       (cadr                    ; absolute date of start of this month
426 427 428 429 430 431
        (assoc month (append (memq (assoc 1 (calendar-chinese-year g-year))
                                   (calendar-chinese-year g-year))
                             (calendar-chinese-year (1+ g-year))))))))

(define-obsolete-function-alias 'calendar-absolute-from-chinese
  'calendar-chinese-to-absolute "23.1")
Edward M. Reingold's avatar
Edward M. Reingold committed
432 433 434 435 436

(defun calendar-chinese-from-absolute (date)
  "Compute Chinese date (cycle year month day) corresponding to absolute DATE.
The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
Edward M. Reingold's avatar
Edward M. Reingold committed
437 438
  (let* ((g-year (extract-calendar-year
                  (calendar-gregorian-from-absolute date)))
Edward M. Reingold's avatar
Edward M. Reingold committed
439
         (c-year (+ g-year 2695))
440 441 442
         (list (append (calendar-chinese-year (1- g-year))
                       (calendar-chinese-year g-year)
                       (calendar-chinese-year (1+ g-year)))))
443
    (while (<= (cadr (cadr list)) date)
Glenn Morris's avatar
Glenn Morris committed
444 445
      ;; The first month on the list is in Chinese year c-year.
      ;; Date is on or after start of second month on list...
446
      (if (= 1 (caar (cdr list)))
Glenn Morris's avatar
Glenn Morris committed
447
          ;; Second month on list is a new Chinese year...
Edward M. Reingold's avatar
Edward M. Reingold committed
448
          (setq c-year (1+ c-year)))
Glenn Morris's avatar
Glenn Morris committed
449
      ;; ...so first month on list is of no interest.
Edward M. Reingold's avatar
Edward M. Reingold committed
450
      (setq list (cdr list)))
Edward M. Reingold's avatar
Edward M. Reingold committed
451
    (list (/ (1- c-year) 60)
452 453
          ;; Remainder of c-year/60 with 60 instead of 0.
          (1+ (mod (1- c-year) 60))
454 455
          (caar list)
          (1+ (- date (cadr (car list)))))))
Edward M. Reingold's avatar
Edward M. Reingold committed
456

457 458 459 460
;; Bound in generate-calendar.
(defvar displayed-month)
(defvar displayed-year)

461
;;;###holiday-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
462
(defun holiday-chinese-new-year ()
463 464
  "Date of Chinese New Year, if visible in calendar.
Returns (((MONTH DAY YEAR) TEXT)), where the date is Gregorian."
Edward M. Reingold's avatar
Edward M. Reingold committed
465
  (let ((m displayed-month)
466 467
        (y displayed-year)
        chinese-new-year)
468 469 470
    ;; In the Gregorian calendar, CNY falls between Jan 21 and Feb 20.
    ;; Jan is visible if displayed-month = 12, 1, 2; Feb if d-m = 1, 2, 3.
    ;; If we shift the calendar forward one month, we can do a
Glenn Morris's avatar
Glenn Morris committed
471
    ;; one-sided test, namely: d-m <= 4 means CNY might be visible.
472
    (increment-calendar-month m y 1)    ; shift forward a month
473
    (and (< m 5)
474 475 476 477
         (calendar-date-is-visible-p
          (setq chinese-new-year
                (calendar-gregorian-from-absolute
                 (cadr (assoc 1 (calendar-chinese-year y))))))
478 479 480 481
         (list
          (list chinese-new-year
                (format "Chinese New Year (%s)"
                        (calendar-chinese-sexagesimal-name (+ y 57))))))))
Edward M. Reingold's avatar
Edward M. Reingold committed
482

483
;;;###cal-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
484 485 486 487 488 489 490
(defun calendar-chinese-date-string (&optional date)
  "String of Chinese date of Gregorian DATE.
Defaults to today's date if DATE is not given."
  (let* ((a-date (calendar-absolute-from-gregorian
                  (or date (calendar-current-date))))
         (c-date (calendar-chinese-from-absolute a-date))
         (cycle (car c-date))
491 492 493
         (year (cadr c-date))
         (month (nth 2 c-date))
         (day (nth 3 c-date))
494
         (this-month (calendar-chinese-to-absolute
Edward M. Reingold's avatar
Edward M. Reingold committed
495
                      (list cycle year month 1)))
496
         (next-month (calendar-chinese-to-absolute
497 498
                      (list (if (= year 60) (1+ cycle) cycle)
                            (if (= (floor month) 12) (1+ year) year)
499 500 501
                            ;; Remainder of (1+(floor month))/12, with
                            ;; 12 instead of 0.
                            (1+ (mod (floor month) 12))
502
                            1)))
Edward M. Reingold's avatar
Edward M. Reingold committed
503
         (m-cycle (% (+ (* year 5) (floor month)) 60)))
504
    (format "Cycle %s, year %s (%s), %smonth %s%s, day %s (%s)"
Edward M. Reingold's avatar
Edward M. Reingold committed
505
            cycle
506
            year (calendar-chinese-sexagesimal-name year)
Edward M. Reingold's avatar
Edward M. Reingold committed
507 508 509 510 511
            (if (not (integerp month))
                "second "
              (if (< 30 (- next-month this-month))
                  "first "
                ""))
Edward M. Reingold's avatar
Edward M. Reingold committed
512
            (floor month)
513
            (if (integerp month)
514
                (format " (%s)" (calendar-chinese-sexagesimal-name
515
                                 (+ (* 12 year) month 50)))
516
              "")
517
            day (calendar-chinese-sexagesimal-name (+ a-date 15)))))
518

519
;;;###cal-autoload
520
(defun calendar-chinese-print-date ()
Edward M. Reingold's avatar
Edward M. Reingold committed
521 522 523 524 525 526
  "Show the Chinese date equivalents of date."
  (interactive)
  (message "Computing Chinese date...")
  (message "Chinese date: %s"
           (calendar-chinese-date-string (calendar-cursor-to-date t))))

527 528 529 530
(define-obsolete-function-alias 'calendar-print-chinese-date
  'calendar-chinese-print-date "23.1")

(defun calendar-chinese-months-to-alist (l)
531 532 533 534 535 536 537
  "Make list of months L into an assoc list."
  (and l (car l)
       (if (and (cdr l) (cadr l))
           (if (= (car l) (floor (cadr l)))
               (append
                (list (cons (format "%s (first)" (car l)) (car l))
                      (cons (format "%s (second)" (car l)) (cadr l)))
538
                (calendar-chinese-months-to-alist (cddr l)))
539 540
             (append
              (list (cons (int-to-string (car l)) (car l)))
541
              (calendar-chinese-months-to-alist (cdr l))))
542 543
         (list (cons (int-to-string (car l)) (car l))))))

544
(defun calendar-chinese-months (c y)
545 546 547 548
  "A list of the months in cycle C, year Y of the Chinese calendar."
  (memq 1 (append
           (mapcar (lambda (x)
                     (car x))
549 550 551 552
                   (calendar-chinese-year (extract-calendar-year
                                           (calendar-gregorian-from-absolute
                                            (calendar-chinese-to-absolute
                                             (list c y 1 1))))))
553 554
           (mapcar (lambda (x)
                     (if (> (car x) 11) (car x)))
555 556 557 558 559 560
                   (calendar-chinese-year (extract-calendar-year
                                           (calendar-gregorian-from-absolute
                                            (calendar-chinese-to-absolute
                                             (list (if (= y 60) (1+ c) c)
                                                   (if (= y 60) 1 y)
                                                   1 1)))))))))
561

562
;;;###cal-autoload
563
(defun calendar-chinese-goto-date (date &optional noecho)
Edward M. Reingold's avatar
Edward M. Reingold committed
564
  "Move cursor to Chinese date DATE.
565
Echo Chinese date unless NOECHO is non-nil."
Edward M. Reingold's avatar
Edward M. Reingold committed
566 567
  (interactive
   (let* ((c (calendar-chinese-from-absolute
568
              (calendar-absolute-from-gregorian (calendar-current-date))))
Edward M. Reingold's avatar
Edward M. Reingold committed
569
          (cycle (calendar-read
Edward M. Reingold's avatar
Edward M. Reingold committed
570
                  "Chinese calendar cycle number (>44): "
571
                  (lambda (x) (> x 44))
Edward M. Reingold's avatar
Edward M. Reingold committed
572 573
                  (int-to-string (car c))))
          (year (calendar-read
Edward M. Reingold's avatar
Edward M. Reingold committed
574
                 "Year in Chinese cycle (1..60): "
575
                 (lambda (x) (and (<= 1 x) (<= x 60)))
576
                 (int-to-string (cadr c))))
577 578
          (month-list (calendar-chinese-months-to-alist
                       (calendar-chinese-months cycle year)))
Edward M. Reingold's avatar
Edward M. Reingold committed
579 580 581 582 583
          (month (cdr (assoc
                       (completing-read "Chinese calendar month: "
                                        month-list nil t)
                       month-list)))
          (last (if (= month
584 585 586
                       (nth 2
                            (calendar-chinese-from-absolute
                             (+ 29
587
                                (calendar-chinese-to-absolute
588
                                 (list cycle year month 1))))))
Edward M. Reingold's avatar
Edward M. Reingold committed
589 590 591 592
                    30
                  29))
          (day (calendar-read
                (format "Chinese calendar day (1-%d): " last)
593
                (lambda (x) (and (<= 1 x) (<= x last))))))
Edward M. Reingold's avatar
Edward M. Reingold committed
594 595
     (list (list cycle year month day))))
  (calendar-goto-date (calendar-gregorian-from-absolute
596 597 598 599 600
                       (calendar-chinese-to-absolute date)))
  (or noecho (calendar-chinese-print-date)))

(define-obsolete-function-alias 'calendar-goto-chinese-date
  'calendar-chinese-goto-date "23.1")
Edward M. Reingold's avatar
Edward M. Reingold committed
601

Glenn Morris's avatar
Glenn Morris committed
602 603
(defvar date)

Glenn Morris's avatar
Glenn Morris committed
604
;; To be called from diary-list-sexp-entries, where DATE is bound.
605
;;;###diary-autoload
Edward M. Reingold's avatar
Edward M. Reingold committed
606 607 608 609
(defun diary-chinese-date ()
  "Chinese calendar equivalent of date diary entry."
  (format "Chinese date: %s" (calendar-chinese-date-string date)))

610
(provide 'cal-china)
Edward M. Reingold's avatar
Edward M. Reingold committed
611

612
;; arch-tag: 7e5b7e0d-676c-47e3-8696-93e7ea0ab644
613
;;; cal-china.el ends here