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