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