lisp/calendar/cal-china.el

   1 ;;; cal-china.el --- calendar functions for the Chinese calendar
   2
   3 ;; Copyright (C) 1995, 1997, 2001, 2002, 2003, 2004, 2005, 2006, 2007,
   4 ;;   2008  Free Software Foundation, Inc.
   5
   6 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
   7 ;; Maintainer: Glenn Morris <rgm@gnu.org>
   8 ;; Keywords: calendar
   9 ;; Human-Keywords: Chinese calendar, calendar, holidays, diary
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 3, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29
  30 ;; See calendar.el.
  31
  32 ;; The rules used for the Chinese calendar are those of Baolin Liu
  33 ;; (see L. E. Doggett's article "Calendars" in the Explanatory
  34 ;; Supplement to the Astronomical Almanac, second edition, 1992) for
  35 ;; the calendar as revised at the beginning of the Qing dynasty in
  36 ;; 1644.  The nature of the astronomical calculations is such that
  37 ;; precise calculations cannot be made without great expense in time,
  38 ;; so that the calendars produced may not agree perfectly with
  39 ;; published tables--but no two pairs of published tables agree
  40 ;; perfectly either!  Liu's rules produce a calendar for 2033 which is
  41 ;; not accepted by all authorities.  The date of Chinese New Year is
  42 ;; correct from 1644-2051.
  43
  44 ;; Note to maintainers:
  45 ;; Use `chinese-year-cache-init' every few years to recenter the default
  46 ;; value of `chinese-year-cache'.
  47
  48 ;;; Code:
  49
  50 (require 'calendar)
  51 (require 'lunar)                        ; lunar-new-moon-on-or-after
  52 ;; solar-date-next-longitude brought in by lunar.
  53 ;;;(require 'solar)
  54 ;; calendar-astro-to-absolute and from-absolute are cal-autoloads.
  55 ;;;(require 'cal-julian)
  56
  57
  58 (defgroup calendar-chinese nil
  59   "Chinese calendar support."
  60   :prefix "calendar-chinese-"
  61   :group 'calendar)
  62
  63 (defcustom calendar-chinese-time-zone
  64   '(if (< year 1928)
  65        (+ 465 (/ 40.0 60.0))
  66      480)
  67   "Minutes difference between local standard time for Chinese calendar and UTC.
  68 Default is for Beijing.  This is an expression in `year' since it changed at
  69 1928-01-01 00:00:00 from UT+7:45:40 to UT+8."
  70   :type 'sexp
  71   :group 'calendar-chinese)
  72
  73 (define-obsolete-variable-alias 'chinese-calendar-time-zone
  74   'calendar-chinese-time-zone "23.1")
  75
  76 ;; FIXME unused.
  77 (defcustom calendar-chinese-location-name "Beijing"
  78   "Name of location used for calculation of Chinese calendar."
  79   :type 'string
  80   :group 'calendar-chinese)
  81
  82 (define-obsolete-variable-alias 'chinese-calendar-location-name
  83   'calendar-chinese-location-name "23.1")
  84
  85 (defcustom calendar-chinese-daylight-time-offset 0
  86 ;; The correct value is as follows, but the Chinese calendrical
  87 ;; authorities do NOT use DST in determining astronomical events:
  88 ;;  60
  89   "Minutes difference between daylight saving and standard time.
  90 Default is for no daylight saving time."
  91   :type 'integer
  92   :group 'calendar-chinese)
  93
  94 (define-obsolete-variable-alias 'chinese-calendar-daylight-time-offset
  95   'calendar-chinese-daylight-time-offset "23.1")
  96
  97 (defcustom calendar-chinese-standard-time-zone-name
  98   '(if (< year 1928)
  99        "PMT"
 100      "CST")
 101   "Abbreviated name of standard time zone used for Chinese calendar.
 102 This is an expression depending on `year' because it changed
 103 at 1928-01-01 00:00:00 from `PMT' to `CST'."
 104   :type 'sexp
 105   :group 'calendar-chinese)
 106
 107 (define-obsolete-variable-alias 'chinese-calendar-standard-time-zone-name
 108   'calendar-chinese-standard-time-zone-name "23.1")
 109
 110 (defcustom calendar-chinese-daylight-time-zone-name "CDT"
 111   "Abbreviated name of daylight saving time zone used for Chinese calendar."
 112   :type 'string
 113   :group 'calendar-chinese)
 114
 115 (define-obsolete-variable-alias 'chinese-calendar-daylight-time-zone-name
 116   'calendar-chinese-daylight-time-zone-name "23.1")
 117
 118 (defcustom calendar-chinese-daylight-saving-start nil
 119 ;; The correct value is as follows, but the Chinese calendrical
 120 ;; authorities do NOT use DST in determining astronomical events:
 121 ;;  '(cond ((< 1986 year) (calendar-nth-named-day 1 0 4 year 10))
 122 ;;         ((= 1986 year) '(5 4 1986))
 123 ;;         (t nil))
 124   "Sexp giving the date on which daylight saving time starts.
 125 Default is for no daylight saving time.  See documentation of
 126 `calendar-daylight-savings-starts'."
 127   :type 'sexp
 128   :group 'calendar-chinese)
 129
 130 (define-obsolete-variable-alias 'chinese-calendar-daylight-savings-starts
 131   'calendar-chinese-daylight-saving-start "23.1")
 132
 133 (defcustom calendar-chinese-daylight-saving-end nil
 134 ;; The correct value is as follows, but the Chinese calendrical
 135 ;; authorities do NOT use DST in determining astronomical events:
 136 ;;  '(if (<= 1986 year) (calendar-nth-named-day 1 0 9 year 11))
 137   "Sexp giving the date on which daylight saving time ends.
 138 Default is for no daylight saving time.  See documentation of
 139 `calendar-daylight-savings-ends'."
 140   :type 'sexp
 141   :group 'calendar-chinese)
 142
 143 (define-obsolete-variable-alias 'chinese-calendar-daylight-savings-ends
 144   'calendar-chinese-daylight-saving-end "23.1")
 145
 146 (defcustom calendar-chinese-daylight-saving-start-time 0
 147   "Number of minutes after midnight that daylight saving time starts.
 148 Default is for no daylight saving time."
 149   :type 'integer
 150   :group 'calendar-chinese)
 151
 152 (define-obsolete-variable-alias 'chinese-calendar-daylight-savings-starts-time
 153   'calendar-chinese-daylight-saving-start-time "23.1")
 154
 155 (defcustom calendar-chinese-daylight-saving-end-time 0
 156   "Number of minutes after midnight that daylight saving time ends.
 157 Default is for no daylight saving time."
 158   :type 'integer
 159   :group 'calendar-chinese)
 160
 161 (define-obsolete-variable-alias 'chinese-calendar-daylight-savings-ends-time
 162   'calendar-chinese-daylight-saving-end-time "23.1")
 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   :type '(vector (string :tag "Jia")
 169                  (string :tag "Yi")
 170                  (string :tag "Bing")
 171                  (string :tag "Ding")
 172                  (string :tag "Wu")
 173                  (string :tag "Ji")
 174                  (string :tag "Geng")
 175                  (string :tag "Xin")
 176                  (string :tag "Ren")
 177                  (string :tag "Gui")))
 178
 179 (define-obsolete-variable-alias 'chinese-calendar-celestial-stem
 180   'calendar-chinese-celestial-stem "23.1")
 181
 182 (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   :type '(vector (string :tag "Zi")
 187                  (string :tag "Chou")
 188                  (string :tag "Yin")
 189                  (string :tag "Mao")
 190                  (string :tag "Chen")
 191                  (string :tag "Si")
 192                  (string :tag "Wu")
 193                  (string :tag "Wei")
 194                  (string :tag "Shen")
 195                  (string :tag "You")
 196                  (string :tag "Xu")
 197                  (string :tag "Hai")))
 198
 199 (define-obsolete-variable-alias 'chinese-calendar-terrestrial-branch
 200   'calendar-chinese-terrestrial-branch "23.1")
 201
 202 ;;; End of user options.
 203
 204
 205 (defun calendar-chinese-sexagesimal-name (n)
 206   "The N-th name of the Chinese sexagesimal cycle.
 207 N congruent to 1 gives the first name, N congruent to 2 gives the second name,
 208 ..., N congruent to 60 gives the sixtieth name."
 209   (format "%s-%s"
 210           (aref calendar-chinese-celestial-stem (% (1- n) 10))
 211           (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.
 215 The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
 216  (let* ((year (calendar-extract-year (calendar-gregorian-from-absolute d)))
 217          (calendar-time-zone (eval calendar-chinese-time-zone)) ; uses year
 218          (calendar-daylight-time-offset
 219           calendar-chinese-daylight-time-offset)
 220          (calendar-standard-time-zone-name
 221           calendar-chinese-standard-time-zone-name)
 222          (calendar-daylight-time-zone-name
 223           calendar-chinese-daylight-time-zone-name)
 224          (calendar-daylight-savings-starts
 225           calendar-chinese-daylight-saving-start)
 226          (calendar-daylight-savings-ends
 227           calendar-chinese-daylight-saving-end)
 228          (calendar-daylight-savings-starts-time
 229           calendar-chinese-daylight-saving-start-time)
 230          (calendar-daylight-savings-ends-time
 231           calendar-chinese-daylight-saving-end-time))
 232    (floor
 233     (calendar-astro-to-absolute
 234      (solar-date-next-longitude (calendar-astro-from-absolute d) 30)))))
 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 (calendar-extract-year (calendar-gregorian-from-absolute d)))
 239          (calendar-time-zone (eval calendar-chinese-time-zone))
 240          (calendar-daylight-time-offset
 241           calendar-chinese-daylight-time-offset)
 242          (calendar-standard-time-zone-name
 243           calendar-chinese-standard-time-zone-name)
 244          (calendar-daylight-time-zone-name
 245           calendar-chinese-daylight-time-zone-name)
 246          (calendar-daylight-savings-starts
 247           calendar-chinese-daylight-saving-start)
 248          (calendar-daylight-savings-ends
 249           calendar-chinese-daylight-saving-end)
 250          (calendar-daylight-savings-starts-time
 251           calendar-chinese-daylight-saving-start-time)
 252          (calendar-daylight-savings-ends-time
 253           calendar-chinese-daylight-saving-end-time))
 254     (floor
 255      (calendar-astro-to-absolute
 256       (lunar-new-moon-on-or-after (calendar-astro-from-absolute d))))))
 257
 258 (defun calendar-chinese-month-list (start end)
 259   "List of starting dates of Chinese months from START to END."
 260   (if (<= start end)
 261       (let ((new-moon (calendar-chinese-new-moon-on-or-after start)))
 262         (if (<= new-moon end)
 263             (cons new-moon
 264                   (calendar-chinese-month-list (1+ new-moon) end))))))
 265
 266 (defun calendar-chinese-number-months (list start)
 267   "Assign month numbers to the lunar months in LIST, starting with START.
 268 Numbers are assigned sequentially, START, START+1, ..., 11, with
 269 half numbers used for leap months.  First and last months of list
 270 are never leap months."
 271   (when list
 272     (cons (list start (car list))       ; first month
 273           ;; Remaining months.
 274           (if (zerop (- 12 start (length list)))
 275               ;; 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                          (calendar-chinese-zodiac-sign-on-or-after
 280                           (cadr list))))
 281                 ;; Next month is a leap month.
 282                 (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)
 288   "Compute the structure of the Chinese year for Gregorian year Y.
 289 The result is a list of pairs (i d), where month i begins on absolute date d,
 290 of the Chinese months from the Chinese month following the solstice in
 291 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
 293                          (calendar-absolute-from-gregorian
 294                           (list 12 15 y))))
 295          (list (calendar-chinese-month-list
 296                 (1+ (calendar-chinese-zodiac-sign-on-or-after
 297                      (calendar-absolute-from-gregorian
 298                       (list 12 15 (1- y)))))
 299                 next-solstice))
 300          (next-sign (calendar-chinese-zodiac-sign-on-or-after (car list))))
 301     (if (= (length list) 12)
 302         ;; No room for a leap month, just number them 12, 1, 2, ..., 11.
 303         (cons (list 12 (car list))
 304               (calendar-chinese-number-months (cdr list) 1))
 305       ;; Now we can assign numbers to the list for y.
 306       ;; The first month or two are special.
 307       (if (or (> (car list) next-sign) (>= next-sign (cadr list)))
 308           ;; First month on list is a leap month, second is not.
 309           (append (list (list 11.5 (car list))
 310                         (list 12 (cadr list)))
 311                   (calendar-chinese-number-months (cddr list) 1))
 312         ;; First month on list is not a leap month.
 313         (append (list (list 12 (car list)))
 314                 (if (>= (calendar-chinese-zodiac-sign-on-or-after (cadr list))
 315                         (nth 2 list))
 316                     ;; Second month on list is a leap month.
 317                     (cons (list 12.5 (cadr list))
 318                           (calendar-chinese-number-months (cddr list) 1))
 319                   ;; Second month on list is not a leap month.
 320                   (calendar-chinese-number-months (cdr list) 1)))))))
 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   '((2000 (12 730126) (1 730155) (2 730185) (3 730215) (4 730244) (5 730273)
 326           (6 730303) (7 730332) (8 730361) (9 730391) (10 730420) (11 730450))
 327     (2001 (12 730480) (1 730509) (2 730539) (3 730569) (4 730598) (4.5 730628)
 328           (5 730657) (6 730687) (7 730716) (8 730745) (9 730775) (10 730804)
 329           (11 730834))
 330     (2002 (12 730863) (1 730893) (2 730923) (3 730953) (4 730982) (5 731012)
 331           (6 731041) (7 731071) (8 731100) (9 731129) (10 731159) (11 731188))
 332     (2003 (12 731218) (1 731247) (2 731277) (3 731307) (4 731336) (5 731366)
 333           (6 731396) (7 731425) (8 731455) (9 731484) (10 731513) (11 731543))
 334     (2004 (12 731572) (1 731602) (2 731631) (2.5 731661) (3 731690) (4 731720)
 335           (5 731750) (6 731779) (7 731809) (8 731838) (9 731868) (10 731897)
 336           (11 731927))
 337     (2005 (12 731956) (1 731986) (2 732015) (3 732045) (4 732074) (5 732104)
 338           (6 732133) (7 732163) (8 732193) (9 732222) (10 732252) (11 732281))
 339     (2006 (12 732311) (1 732340) (2 732370) (3 732399) (4 732429) (5 732458)
 340           (6 732488) (7 732517) (7.5 732547) (8 732576) (9 732606) (10 732636)
 341           (11 732665))
 342     (2007 (12 732695) (1 732725) (2 732754) (3 732783) (4 732813) (5 732842)
 343           (6 732871) (7 732901) (8 732930) (9 732960) (10 732990) (11 733020))
 344     (2008 (12 733049) (1 733079) (2 733109) (3 733138) (4 733167) (5 733197)
 345           (6 733226) (7 733255) (8 733285) (9 733314) (10 733344) (11 733374))
 346     (2009 (12 733403) (1 733433) (2 733463) (3 733493) (4 733522) (5 733551)
 347           (5.5 733581) (6 733610) (7 733639) (8 733669) (9 733698) (10 733728)
 348           (11 733757))
 349     (2010 (12 733787) (1 733817) (2 733847) (3 733876) (4 733906) (5 733935)
 350           (6 733965) (7 733994) (8 734023) (9 734053) (10 734082) (11 734112))
 351     (2011 (12 734141) (1 734171) (2 734201) (3 734230) (4 734260) (5 734290)
 352           (6 734319) (7 734349) (8 734378) (9 734407) (10 734437) (11 734466))
 353     (2012 (12 734496) (1 734525) (2 734555) (3 734584) (4 734614) (4.5 734644)
 354           (5 734673) (6 734703) (7 734732) (8 734762) (9 734791) (10 734821)
 355           (11 734850))
 356     (2013 (12 734880) (1 734909) (2 734939) (3 734968) (4 734998) (5 735027)
 357           (6 735057) (7 735087) (8 735116) (9 735146) (10 735175) (11 735205))
 358     (2014 (12 735234) (1 735264) (2 735293) (3 735323) (4 735352) (5 735382)
 359           (6 735411) (7 735441) (8 735470) (9 735500) (9.5 735530) (10 735559)
 360           (11 735589))
 361     (2015 (12 735618) (1 735648) (2 735677) (3 735707) (4 735736) (5 735765)
 362           (6 735795) (7 735824) (8 735854) (9 735884) (10 735914) (11 735943))
 363     (2016 (12 735973) (1 736002) (2 736032) (3 736061) (4 736091) (5 736120)
 364           (6 736149) (7 736179) (8 736208) (9 736238) (10 736268) (11 736297))
 365     (2017 (12 736327) (1 736357) (2 736386) (3 736416) (4 736445) (5 736475)
 366           (6 736504) (6.5 736533) (7 736563) (8 736592) (9 736622) (10 736651)
 367           (11 736681))
 368     (2018 (12 736711) (1 736741) (2 736770) (3 736800) (4 736829) (5 736859)
 369           (6 736888) (7 736917) (8 736947) (9 736976) (10 737006) (11 737035))
 370     (2019 (12 737065) (1 737095) (2 737125) (3 737154) (4 737184) (5 737213)
 371           (6 737243) (7 737272) (8 737301) (9 737331) (10 737360) (11 737389))
 372     (2020 (12 737419) (1 737449) (2 737478) (3 737508) (4 737538) (4.5 737568)
 373           (5 737597) (6 737627) (7 737656) (8 737685) (9 737715) (10 737744)
 374           (11 737774)))
 375   "Alist of Chinese year structures as determined by `chinese-year'.
 376 The default can be nil, but some values are precomputed for efficiency.")
 377
 378 (defun calendar-chinese-year (y)
 379   "The structure of the Chinese year for Gregorian year Y.
 380 The result is a list of pairs (i d), where month i begins on absolute date d,
 381 of the Chinese months from the Chinese month following the solstice in
 382 Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y.
 383 The list is cached in `calendar-chinese-year-cache' for further use."
 384   (let ((list (cdr (assoc y calendar-chinese-year-cache))))
 385     (or list
 386         (setq list (calendar-chinese-compute-year y)
 387               calendar-chinese-year-cache (append calendar-chinese-year-cache
 388                                          (list (cons y list)))))
 389     list))
 390
 391 ;; Maintainer use.
 392 (defun calendar-chinese-year-cache-init (year)
 393   "Insert an initialization value for `calendar-chinese-year-cache' after point.
 394 Computes values for 10 years either side of YEAR."
 395   (setq year (- year 10))
 396   (let (calendar-chinese-year-cache end)
 397     (save-excursion
 398       (insert "'(")
 399       (dotimes (n 21)
 400         (princ (cons year (calendar-chinese-compute-year year))
 401                (current-buffer))
 402         (insert (if (= n 20) ")" "\n"))
 403         (setq year (1+ year)))
 404       (setq end (point)))
 405     (save-excursion
 406       ;; fill-column -/+ 5.
 407       (while (and (< (point) end)
 408                   (re-search-forward "^.\\{65,75\\})" end t))
 409         (delete-char 1)
 410         (insert "\n")))
 411     (indent-region (point) end)))
 412
 413 (defun calendar-chinese-to-absolute (date)
 414   "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
 415 DATE is a Chinese date (cycle year month day).  The Gregorian date
 416 Sunday, December 31, 1 BC is imaginary."
 417   (let* ((cycle (car date))
 418          (year (cadr date))
 419          (month (nth 2 date))
 420          (day (nth 3 date))
 421          (g-year (+ (* (1- cycle) 60)  ; years in prior cycles
 422                     (1- year)          ; prior years this cycle
 423                     -2636)))           ; years before absolute date 0
 424     (+ (1- day)                        ; prior days this month
 425        (cadr                    ; absolute date of start of this month
 426         (assoc month (append (memq (assoc 1 (calendar-chinese-year g-year))
 427                                    (calendar-chinese-year g-year))
 428                              (calendar-chinese-year (1+ g-year))))))))
 429
 430 (define-obsolete-function-alias 'calendar-absolute-from-chinese
 431   'calendar-chinese-to-absolute "23.1")
 432
 433 (defun calendar-chinese-from-absolute (date)
 434   "Compute Chinese date (cycle year month day) corresponding to absolute DATE.
 435 The absolute date is the number of days elapsed since the (imaginary)
 436 Gregorian date Sunday, December 31, 1 BC."
 437   (let* ((g-year (calendar-extract-year
 438                   (calendar-gregorian-from-absolute date)))
 439          (c-year (+ g-year 2695))
 440          (list (append (calendar-chinese-year (1- g-year))
 441                        (calendar-chinese-year g-year)
 442                        (calendar-chinese-year (1+ g-year)))))
 443     (while (<= (cadr (cadr list)) date)
 444       ;; The first month on the list is in Chinese year c-year.
 445       ;; Date is on or after start of second month on list...
 446       (if (= 1 (caar (cdr list)))
 447           ;; Second month on list is a new Chinese year...
 448           (setq c-year (1+ c-year)))
 449       ;; ...so first month on list is of no interest.
 450       (setq list (cdr list)))
 451     (list (/ (1- c-year) 60)
 452           ;; Remainder of c-year/60 with 60 instead of 0.
 453           (1+ (mod (1- c-year) 60))
 454           (caar list)
 455           (1+ (- date (cadr (car list)))))))
 456
 457 ;; Bound in calendar-generate.
 458 (defvar displayed-month)
 459 (defvar displayed-year)
 460
 461 ;;;###holiday-autoload
 462 (defun holiday-chinese-new-year ()
 463   "Date of Chinese New Year, if visible in calendar.
 464 Returns (((MONTH DAY YEAR) TEXT)), where the date is Gregorian."
 465   (let ((m displayed-month)
 466         (y displayed-year)
 467         chinese-new-year)
 468     ;; In the Gregorian calendar, CNY falls between Jan 21 and Feb 20.
 469     ;; Jan is visible if displayed-month = 12, 1, 2; Feb if d-m = 1, 2, 3.
 470     ;; If we shift the calendar forward one month, we can do a
 471     ;; one-sided test, namely: d-m <= 4 means CNY might be visible.
 472     (calendar-increment-month m y 1)    ; shift forward a month
 473     (and (< m 5)
 474          (calendar-date-is-visible-p
 475           (setq chinese-new-year
 476                 (calendar-gregorian-from-absolute
 477                  (cadr (assoc 1 (calendar-chinese-year y))))))
 478          (list
 479           (list chinese-new-year
 480                 (format "Chinese New Year (%s)"
 481                         (calendar-chinese-sexagesimal-name (+ y 57))))))))
 482
 483 ;;;###cal-autoload
 484 (defun calendar-chinese-date-string (&optional date)
 485   "String of Chinese date of Gregorian DATE.
 486 Defaults to today's date if DATE is not given."
 487   (let* ((a-date (calendar-absolute-from-gregorian
 488                   (or date (calendar-current-date))))
 489          (c-date (calendar-chinese-from-absolute a-date))
 490          (cycle (car c-date))
 491          (year (cadr c-date))
 492          (month (nth 2 c-date))
 493          (day (nth 3 c-date))
 494          (this-month (calendar-chinese-to-absolute
 495                       (list cycle year month 1)))
 496          (next-month (calendar-chinese-to-absolute
 497                       (list (if (= year 60) (1+ cycle) cycle)
 498                             (if (= (floor month) 12) (1+ year) year)
 499                             ;; Remainder of (1+(floor month))/12, with
 500                             ;; 12 instead of 0.
 501                             (1+ (mod (floor month) 12))
 502                             1)))
 503          (m-cycle (% (+ (* year 5) (floor month)) 60)))
 504     (format "Cycle %s, year %s (%s), %smonth %s%s, day %s (%s)"
 505             cycle
 506             year (calendar-chinese-sexagesimal-name year)
 507             (if (not (integerp month))
 508                 "second "
 509               (if (< 30 (- next-month this-month))
 510                   "first "
 511                 ""))
 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 ()
 521   "Show the Chinese date equivalents of date."
 522   (interactive)
 523   (message "Computing Chinese date...")
 524   (message "Chinese date: %s"
 525            (calendar-chinese-date-string (calendar-cursor-to-date t))))
 526
 527 (define-obsolete-function-alias 'calendar-print-chinese-date
 528   'calendar-chinese-print-date "23.1")
 529
 530 (defun calendar-chinese-months-to-alist (l)
 531   "Make list of months L into an assoc list."
 532   (and l (car l)
 533        (if (and (cdr l) (cadr l))
 534            (if (= (car l) (floor (cadr l)))
 535                (append
 536                 (list (cons (format "%s (first)" (car l)) (car l))
 537                       (cons (format "%s (second)" (car l)) (cadr l)))
 538                 (calendar-chinese-months-to-alist (cddr l)))
 539              (append
 540               (list (cons (int-to-string (car l)) (car l)))
 541               (calendar-chinese-months-to-alist (cdr l))))
 542          (list (cons (int-to-string (car l)) (car l))))))
 543
 544 (defun calendar-chinese-months (c y)
 545   "A list of the months in cycle C, year Y of the Chinese calendar."
 546   (memq 1 (append
 547            (mapcar (lambda (x)
 548                      (car x))
 549                    (calendar-chinese-year (calendar-extract-year
 550                                            (calendar-gregorian-from-absolute
 551                                             (calendar-chinese-to-absolute
 552                                              (list c y 1 1))))))
 553            (mapcar (lambda (x)
 554                      (if (> (car x) 11) (car x)))
 555                    (calendar-chinese-year (calendar-extract-year
 556                                            (calendar-gregorian-from-absolute
 557                                             (calendar-chinese-to-absolute
 558                                              (list (if (= y 60) (1+ c) c)
 559                                                    (if (= y 60) 1 y)
 560                                                    1 1)))))))))
 561
 562 ;;;###cal-autoload
 563 (defun calendar-chinese-goto-date (date &optional noecho)
 564   "Move cursor to Chinese date DATE.
 565 Echo Chinese date unless NOECHO is non-nil."
 566   (interactive
 567    (let* ((c (calendar-chinese-from-absolute
 568               (calendar-absolute-from-gregorian (calendar-current-date))))
 569           (cycle (calendar-read
 570                   "Chinese calendar cycle number (>44): "
 571                   (lambda (x) (> x 44))
 572                   (int-to-string (car c))))
 573           (year (calendar-read
 574                  "Year in Chinese cycle (1..60): "
 575                  (lambda (x) (and (<= 1 x) (<= x 60)))
 576                  (int-to-string (cadr c))))
 577           (month-list (calendar-chinese-months-to-alist
 578                        (calendar-chinese-months cycle year)))
 579           (month (cdr (assoc
 580                        (completing-read "Chinese calendar month: "
 581                                         month-list nil t)
 582                        month-list)))
 583           (last (if (= month
 584                        (nth 2
 585                             (calendar-chinese-from-absolute
 586                              (+ 29
 587                                 (calendar-chinese-to-absolute
 588                                  (list cycle year month 1))))))
 589                     30
 590                   29))
 591           (day (calendar-read
 592                 (format "Chinese calendar day (1-%d): " last)
 593                 (lambda (x) (and (<= 1 x) (<= x last))))))
 594      (list (list cycle year month day))))
 595   (calendar-goto-date (calendar-gregorian-from-absolute
 596                        (calendar-chinese-to-absolute date)))
 597   (or noecho (calendar-chinese-print-date)))
 598
 599 (define-obsolete-function-alias 'calendar-goto-chinese-date
 600   'calendar-chinese-goto-date "23.1")
 601
 602 (defvar date)
 603
 604 ;; To be called from diary-list-sexp-entries, where DATE is bound.
 605 ;;;###diary-autoload
 606 (defun diary-chinese-date ()
 607   "Chinese calendar equivalent of date diary entry."
 608   (format "Chinese date: %s" (calendar-chinese-date-string date)))
 609
 610 (provide 'cal-china)
 611
 612 ;; arch-tag: 7e5b7e0d-676c-47e3-8696-93e7ea0ab644
 613 ;;; cal-china.el ends here