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