comparison lisp/calendar/cal-china.el @ 13283:f8658d1ca0f2

Various fixes and simplifications.

13282:69fe836d7f02

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

;; Comments, corrections, and improvements should be sent to
;;  Edward M. Reingold               Department of Computer Science
;;  [phone]                   University of Illinois at Urbana-Champaign
;;  [e-mail]             1304 West Springfield Avenue

UT+7:45:40 to UT+8.")

(defvar chinese-calendar-location-name "Beijing"
  "*Name of location used for calculation of Chinese calendar.")

(defvar chinese-calendar-daylight-time-offset 0
; The correct value is as follows, but I don't believe the Chinese calendrical
; authorities would use DST in determining astronomical events:
;  60
  "*Number of minutes difference between daylight savings and standard time
for Chinese calendar.  Default is for no daylight savings time.")

(defvar chinese-calendar-standard-time-zone-name
  '(if (< year 1928)

  "*Abbreviated name of standard time zone used for Chinese calendar.")

(defvar chinese-calendar-daylight-time-zone-name "CDT"
  "*Abbreviated name of daylight-savings time zone used for Chinese calendar.")

(defvar chinese-calendar-daylight-savings-starts nil
; The correct value is as follows, but I don't believe the Chinese calendrical
; authorities would use DST in determining astronomical events:
;  '(cond ((< 1986 year) (calendar-nth-named-day 1 0 4 year 10))
;         ((= 1986 year) '(5 4 1986))
;         (t nil))
  "*Sexp giving the date on which daylight savings time starts for Chinese
calendar.  Default is for no daylight savings time.  See documentation of
`calendar-daylight-savings-starts'.")

(defvar chinese-calendar-daylight-savings-ends nil
; The correct value is as follows, but I don't believe the Chinese calendrical
; authorities would use DST in determining astronomical events:
;  '(if (<= 1986 year) (calendar-nth-named-day 1 0 9 year 11))
  "*Sexp giving the date on which daylight savings time ends for Chinese
calendar.  Default is for no daylight savings time.  See documentation of
`calendar-daylight-savings-ends'.")

(defvar chinese-calendar-daylight-savings-starts-time 0

       (calendar-astro-from-absolute d))))))

(defvar chinese-year-cache
  '((1989 (12 . 726110) (1 . 726139) (2 . 726169) (3 . 726198) (4 . 726227)
          (5 . 726257) (6 . 726286) (7 . 726316) (8 . 726345) (9 . 726375)
          (10 . 726404) (11 . 726434))
    (1990 (12 . 726464) (1 . 726494) (2 . 726523) (3 . 726553) (4 . 726582)
          (5 . 726611) (5.5 . 726641) (6 . 726670) (7 . 726699) (8 . 726729)
          (9 . 726758) (10 . 726788) (11 . 726818))
    (1991 (12 . 726848) (1 . 726878) (2 . 726907) (3 . 726937) (4 . 726966)
          (5 . 726995) (6 . 727025) (7 . 727054) (8 . 727083) (9 . 727113)

          (setq list (compute-chinese-year y))
          (setq chinese-year-cache
                (append chinese-year-cache  (list (cons y list))))))
    list))

(defun number-chinese-months (list start &optional no-leap-months)
  "Assign month numbers to the lunar months in LIST, starting with START.

If optional parameter NO-LEAP-MONTHS is true, just number the months
sequentially, ignoring the usual leap month rule.

First month of list will never be a leap month, nor will the last.

Numbers are assigned sequentially mod 12 (but using 12 instead of 0)."
  (if list
      (if no-leap-months
          (cons (cons (calendar-mod start 12) (car list))
                (number-chinese-months (cdr list) (1+ start) t))
        (cons
         ;; first month
         (cons (calendar-mod start 12) (car list))
         ;; remaining months
         (if (and (cdr (cdr list));; at least two more months...
                  ;;              ... and next one is a leap month
                  (<= (car (cdr (cdr list)))
                      (chinese-zodiac-sign-on-or-after (car (cdr list)))))
             (cons (cons (+ (calendar-mod start 12) 0.5) (car (cdr list)))
                   (number-chinese-months (cdr (cdr list)) (1+ start) t))
           ;; Otherwise, just number the months
           (number-chinese-months (cdr list) (1+ start)))))))

(defun chinese-month-list (start end)
  "List of starting dates of Chinese months from START to END."
  (if (<= start end)
      (let ((new-moon (chinese-new-moon-on-or-after start)))
        (if (<= new-moon end)
            (append (list new-moon)
                    (chinese-month-list (1+ new-moon) end))))))

(defun chinese-leap-months (list low high)
  "Return list of leap months in LIST with indices in range LOW to HIGH.

A leap month has a non-integer index."
  (if list
      (let ((index (car (car list))))
        (if (and (/= index (floor index))
                 (<= low index)
                 (<= index high))
            (cons index (chinese-leap-months (cdr list) low high))
          (chinese-leap-months (cdr list) low high)))))

(defun compute-chinese-year (y)
  "Compute the structure of the Chinese year for Gregorian year Y.
The result is a list of pairs (i . d), where month i begins on absolute date d,
of the Chinese months from the Chinese month following the solstice in

                         (calendar-absolute-from-gregorian
                          (list 12 15 y))))
         (list (chinese-month-list (1+ (chinese-zodiac-sign-on-or-after
                                        (calendar-absolute-from-gregorian
                                         (list 12 15 (1- y)))))
                                   next-solstice)))
    (if (= (length list) 12)
        ;; No room for a leap month, just number them 12, 1, 2, ..., 11
        (number-chinese-months list 0 t)
      (let* ((had-leap-month (chinese-leap-months (chinese-year (1- y)) 1 10))
             (numbered-list)
             (next-sign;;     On or after first month on list
              (chinese-zodiac-sign-on-or-after (car list))))
        ;; Now we can assign numbers to the list for y
        ;; The first month or two are special
        (if (and (<= (car list) next-sign) (< next-sign (car (cdr list))))
            (progn;; First month on list is not a leap month
              (setq numbered-list (list (cons 12 (car list))))
              (setq list (cdr list))
              (setq next-sign (chinese-zodiac-sign-on-or-after (car list))))
          ;; First month on list might be a leap month...
          (if (not had-leap-month);; ... it is a leap month
              (progn;; First month on list is a leap month, so second is not
                (setq numbered-list (list (cons 11.5 (car list))
                                          (cons 12 (car (cdr list)))))
                (setq list (cdr (cdr list)))
                (setq had-leap-month t))))
        (if (and (>= next-sign (car (cdr list)))
                 (not had-leap-month))
            (progn;; Second month on list is a leap month
              (setq numbered-list
                    (append numbered-list (list (cons 12.5 (car list)))))
              (setq list (cdr list))))
        ;; At this point we have a list of new moons for months 1 to 11 for y.
        ;; We need to see which are leap months.
        (if (= (length list) 11)
            ;; There can be no leap months, just number them 1..11
            (append numbered-list (number-chinese-months list 1 t))
          ;; There is a leap month, but it can't be the first one because that
          ;; would be 12.5 which we already considered.  It also can't be the
          ;; last one because that has the solstice in it.
          (append numbered-list (number-chinese-months list 1)))))))

(defun calendar-absolute-from-chinese (date)
  "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
The Gregorian date Sunday, December 31, 1 BC is imaginary."
  (let* ((cycle (car date))

         (month (car (cdr (cdr c-date))))
         (day (car (cdr (cdr (cdr c-date)))))
         (this-month (calendar-absolute-from-chinese
                      (list cycle year month 1)))
         (next-month (calendar-absolute-from-chinese
                      (list cycle year (1+ (floor month)) 1)))
         (m-cycle (% (+ (* year 5) (floor month)) 60)))
    (format "Cycle %s, year %s (%s-%s), %smonth %s, day %s (%s-%s)"
            cycle
            year
            (aref chinese-calendar-celestial-stem (% (+ year 9) 10))

13283:f8658d1ca0f2

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

;; Comments, corrections, and improvements should be sent to
;;  Edward M. Reingold               Department of Computer Science
;;  [phone]                   University of Illinois at Urbana-Champaign
;;  [e-mail]             1304 West Springfield Avenue

UT+7:45:40 to UT+8.")

(defvar chinese-calendar-location-name "Beijing"
  "*Name of location used for calculation of Chinese calendar.")

(defvar chinese-calendar-daylight-time-offset 60
  "*Number of minutes difference between daylight savings and standard time
for Chinese calendar.  Default is for no daylight savings time.")

(defvar chinese-calendar-standard-time-zone-name
  '(if (< year 1928)

  "*Abbreviated name of standard time zone used for Chinese calendar.")

(defvar chinese-calendar-daylight-time-zone-name "CDT"
  "*Abbreviated name of daylight-savings time zone used for Chinese calendar.")

(defvar chinese-calendar-daylight-savings-starts
  '(cond ((< 1986 year) (calendar-nth-named-day 1 0 4 year 10))
         ((= 1986 year) '(5 4 1986))
         (t nil))
  "*Sexp giving the date on which daylight savings time starts for Chinese
calendar.  Default is for no daylight savings time.  See documentation of
`calendar-daylight-savings-starts'.")

(defvar chinese-calendar-daylight-savings-ends
  '(if (<= 1986 year) (calendar-nth-named-day 1 0 9 year 11))
  "*Sexp giving the date on which daylight savings time ends for Chinese
calendar.  Default is for no daylight savings time.  See documentation of
`calendar-daylight-savings-ends'.")

(defvar chinese-calendar-daylight-savings-starts-time 0

       (calendar-astro-from-absolute d))))))

(defvar chinese-year-cache
  '((1989 (12 . 726110) (1 . 726139) (2 . 726169) (3 . 726198) (4 . 726227)
          (5 . 726257) (6 . 726286) (7 . 726316) (8 . 726345) (9 . 726375)
 (10 . 726404) (11 . 726434))
    (1990 (12 . 726464) (1 . 726494) (2 . 726523) (3 . 726553) (4 . 726582)
          (5 . 726611) (5.5 . 726641) (6 . 726670) (7 . 726699) (8 . 726729)
          (9 . 726758) (10 . 726788) (11 . 726818))
    (1991 (12 . 726848) (1 . 726878) (2 . 726907) (3 . 726937) (4 . 726966)
          (5 . 726995) (6 . 727025) (7 . 727054) (8 . 727083) (9 . 727113)

          (setq list (compute-chinese-year y))
          (setq chinese-year-cache
                (append chinese-year-cache  (list (cons y list))))))
    list))

(defun number-chinese-months (list start)
  "Assign month numbers to the lunar months in LIST, starting with START.
Numbers are assigned sequentially, START, START+1, ..., 11, with half
numbers used for leap months.

If optional parameter NO-LEAP-MONTHS is true, just number the months
sequentially, ignoring the usual leap month rule.

First month of list will never be a leap month, nor will the last."
  (if list
      (if (zerop (- 12 start (length list)))
          ;; List is too short for a leap month
          (cons (cons start (car list))
                (number-chinese-months (cdr list) (1+ start)))
        (cons
         ;; First month
         (cons start (car list))
         ;; Remaining months
         (if (and (cdr (cdr list));; at least two more months...
                  (<= (car (cdr (cdr list)))
                      (chinese-zodiac-sign-on-or-after (car (cdr list)))))
             ;; Next month is a leap month
             (cons (cons (+ start 0.5) (car (cdr list)))
                   (number-chinese-months (cdr (cdr list)) (1+ start)))
           ;; Next month is not a leap month
           (number-chinese-months (cdr list) (1+ start)))))))

(defun chinese-month-list (start end)
  "List of starting dates of Chinese months from START to END."
  (if (<= start end)
      (let ((new-moon (chinese-new-moon-on-or-after start)))
        (if (<= new-moon end)
            (append (list new-moon)
                    (chinese-month-list (1+ new-moon) end))))))

(defun compute-chinese-year (y)
  "Compute the structure of the Chinese year for Gregorian year Y.
The result is a list of pairs (i . d), where month i begins on absolute date d,
of the Chinese months from the Chinese month following the solstice in

                         (calendar-absolute-from-gregorian
                          (list 12 15 y))))
         (list (chinese-month-list (1+ (chinese-zodiac-sign-on-or-after
                                        (calendar-absolute-from-gregorian
                                         (list 12 15 (1- y)))))
                                   next-solstice))
         (next-sign (chinese-zodiac-sign-on-or-after (car list))))
    (if (= (length list) 12)
        ;; No room for a leap month, just number them 12, 1, 2, ..., 11
        (cons (cons 12 (car list))
              (number-chinese-months (cdr list) 1))
      ;; Now we can assign numbers to the list for y
      ;; The first month or two are special
      (if (or (> (car list) next-sign) (>= next-sign (car (cdr list))))
          ;; First month on list is a leap month, second is not
          (append (list (cons 11.5 (car list))
                        (cons 12 (car (cdr list))))
                  (number-chinese-months (cdr (cdr list)) 1))
        ;; First month on list is not a leap month
        (append (list (cons 12 (car list)))
                (if (>= (chinese-zodiac-sign-on-or-after (car (cdr list)))
                        (car (cdr (cdr list))))
                    ;; Second month on list is a leap month
                    (list (cons 12.5 (car (cdr list)))
                          (number-chinese-months (cdr (cdr list)) 1))
                  ;; Second month on list is not a leap month
                  (number-chinese-months (cdr list) 1)))))))

(defun calendar-absolute-from-chinese (date)
  "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE.
The Gregorian date Sunday, December 31, 1 BC is imaginary."
  (let* ((cycle (car date))

         (month (car (cdr (cdr c-date))))
         (day (car (cdr (cdr (cdr c-date)))))
         (this-month (calendar-absolute-from-chinese
                      (list cycle year month 1)))
         (next-month (calendar-absolute-from-chinese
                      (list (if (= year 60) (1+ cycle) cycle)
                            (if (= (floor month) 12) (1+ year) year)
                            (calendar-mod (1+ (floor month)) 12)
                            1)))
         (m-cycle (% (+ (* year 5) (floor month)) 60)))
    (format "Cycle %s, year %s (%s-%s), %smonth %s, day %s (%s-%s)"
            cycle
            year
            (aref chinese-calendar-celestial-stem (% (+ year 9) 10))