Mercurial > emacs
comparison lisp/calendar/cal-china.el @ 13053:621d48117fde
Initial revision
author | Edward M. Reingold <reingold@emr.cs.iit.edu> |
---|---|
date | Thu, 21 Sep 1995 03:11:06 +0000 |
parents | |
children | 510f946d1e22 |
comparison
equal
deleted
inserted
replaced
13052:71be832cf34a | 13053:621d48117fde |
---|---|
1 ;;; cal-chinese.el --- calendar functions for the Chinese calendar. | |
2 | |
3 ;; Copyright (C) 1995 Free Software Foundation, Inc. | |
4 | |
5 ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> | |
6 ;; Keywords: calendar | |
7 ;; Human-Keywords: Chinese calendar, calendar, holidays, diary | |
8 | |
9 ;; This file is part of GNU Emacs. | |
10 | |
11 ;; GNU Emacs is free software; you can redistribute it and/or modify | |
12 ;; it under the terms of the GNU General Public License as published by | |
13 ;; the Free Software Foundation; either version 2, or (at your option) | |
14 ;; any later version. | |
15 | |
16 ;; GNU Emacs is distributed in the hope that it will be useful, | |
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
19 ;; GNU General Public License for more details. | |
20 | |
21 ;; You should have received a copy of the GNU General Public License | |
22 ;; along with GNU Emacs; see the file COPYING. If not, write to | |
23 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
24 | |
25 ;;; Commentary: | |
26 | |
27 ;; This collection of functions implements the features of calendar.el, | |
28 ;; diary.el, and holidays.el that deal with the Chinese calendar. It was | |
29 ;; written by | |
30 | |
31 ;; Edward M. Reingold Department of Computer Science | |
32 ;; (217) 333-6733 University of Illinois at Urbana-Champaign | |
33 ;; reingold@cs.uiuc.edu 1304 West Springfield Avenue | |
34 ;; Urbana, Illinois 61801 | |
35 | |
36 ;;; Code: | |
37 | |
38 (require 'lunar) | |
39 | |
40 (defvar chinese-calendar-terrestrial-branch | |
41 ["Zi" "Chou" "Yin" "Mao" "Chen" "Si" "Wu" "Wei" "Shen" "You" "Xu" "Hai"]) | |
42 | |
43 (defvar chinese-calendar-celestial-stem | |
44 ["Jia" "Yi" "Bing" "Ding" "Wu" "Ji" "Geng" "Xin" "Ren" "Gui"]) | |
45 | |
46 (defvar chinese-calendar-time-zone | |
47 '(if (< year 1928) | |
48 (+ 465 (/ 40.0 60.0)) | |
49 480) | |
50 "*Number of minutes difference between local standard time for Chinese | |
51 calendar and Coordinated Universal (Greenwich) Time. Default is for Beijing. | |
52 This is an expression in `year' since it changed at 1928-01-01 00:00:00 from | |
53 UT+7:45:40 to UT+8.") | |
54 | |
55 (defvar chinese-calendar-location-name "Beijing" | |
56 "*Name of location used for calculation of Chinese calendar.") | |
57 | |
58 (defvar chinese-calendar-daylight-time-offset 0 | |
59 ; The correct value is as follows, but I don't believe the Chinese calendrical | |
60 ; authorities would use DST in determining astronomical events: | |
61 ; 60 | |
62 "*Number of minutes difference between daylight savings and standard time | |
63 for Chinese calendar. Default is for no daylight savings time.") | |
64 | |
65 (defvar chinese-calendar-standard-time-zone-name | |
66 '(if (< year 1928) | |
67 "PMT" | |
68 "CST") | |
69 "*Abbreviated name of standard time zone used for Chinese calendar.") | |
70 | |
71 (defvar chinese-calendar-daylight-time-zone-name "CDT" | |
72 "*Abbreviated name of daylight-savings time zone used for Chinese calendar.") | |
73 | |
74 (defvar chinese-calendar-daylight-savings-starts nil | |
75 ; The correct value is as follows, but I don't believe the Chinese calendrical | |
76 ; authorities would use DST in determining astronomical events: | |
77 ; '(cond ((< 1986 year) (calendar-nth-named-day 1 0 4 year 10)) | |
78 ; ((= 1986 year) '(5 4 1986)) | |
79 ; (t nil)) | |
80 "*Sexp giving the date on which daylight savings time starts for Chinese | |
81 calendar. Default is for no daylight savings time. See documentation of | |
82 `calendar-daylight-savings-starts'.") | |
83 | |
84 (defvar chinese-calendar-daylight-savings-ends nil | |
85 ; The correct value is as follows, but I don't believe the Chinese calendrical | |
86 ; authorities would use DST in determining astronomical events: | |
87 ; '(if (<= 1986 year) (calendar-nth-named-day 1 0 9 year 11)) | |
88 "*Sexp giving the date on which daylight savings time ends for Chinese | |
89 calendar. Default is for no daylight savings time. See documentation of | |
90 `calendar-daylight-savings-ends'.") | |
91 | |
92 (defvar chinese-calendar-daylight-savings-starts-time 0 | |
93 "*Number of minutes after midnight that daylight savings time starts for | |
94 Chinese calendar. Default is for no daylight savings time.") | |
95 | |
96 (defvar chinese-calendar-daylight-savings-ends-time 0 | |
97 "*Number of minutes after midnight that daylight savings time ends for | |
98 Chinese calendar. Default is for no daylight savings time.") | |
99 | |
100 (defun chinese-zodiac-sign-on-or-after (d) | |
101 "Absolute date of first new Zodiac sign on or after absolute date d. | |
102 The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees." | |
103 (let* ((year (extract-calendar-year | |
104 (calendar-gregorian-from-absolute | |
105 (floor (calendar-absolute-from-astro d))))) | |
106 (calendar-time-zone (eval chinese-calendar-time-zone)) | |
107 (calendar-daylight-time-offset | |
108 chinese-calendar-daylight-time-offset) | |
109 (calendar-standard-time-zone-name | |
110 chinese-calendar-standard-time-zone-name) | |
111 (calendar-daylight-time-zone-name | |
112 chinese-calendar-daylight-time-zone-name) | |
113 (calendar-calendar-daylight-savings-starts | |
114 chinese-calendar-daylight-savings-starts) | |
115 (calendar-daylight-savings-ends | |
116 chinese-calendar-daylight-savings-ends) | |
117 (calendar-daylight-savings-starts-time | |
118 chinese-calendar-daylight-savings-starts-time) | |
119 (calendar-daylight-savings-ends-time | |
120 chinese-calendar-daylight-savings-ends-time)) | |
121 (floor | |
122 (calendar-absolute-from-astro | |
123 (solar-date-next-longitude | |
124 (calendar-astro-from-absolute d) | |
125 30))))) | |
126 | |
127 (defun chinese-new-moon-on-or-after (d) | |
128 "Absolute date of first new moon on or after absolute date d." | |
129 (let* ((year (extract-calendar-year | |
130 (calendar-gregorian-from-absolute d))) | |
131 (calendar-time-zone (eval chinese-calendar-time-zone)) | |
132 (calendar-daylight-time-offset | |
133 chinese-calendar-daylight-time-offset) | |
134 (calendar-standard-time-zone-name | |
135 chinese-calendar-standard-time-zone-name) | |
136 (calendar-daylight-time-zone-name | |
137 chinese-calendar-daylight-time-zone-name) | |
138 (calendar-calendar-daylight-savings-starts | |
139 chinese-calendar-daylight-savings-starts) | |
140 (calendar-daylight-savings-ends | |
141 chinese-calendar-daylight-savings-ends) | |
142 (calendar-daylight-savings-starts-time | |
143 chinese-calendar-daylight-savings-starts-time) | |
144 (calendar-daylight-savings-ends-time | |
145 chinese-calendar-daylight-savings-ends-time)) | |
146 (floor | |
147 (calendar-absolute-from-astro | |
148 (lunar-new-moon-on-or-after | |
149 (calendar-astro-from-absolute d)))))) | |
150 | |
151 (defun calendar-absolute-from-chinese (date) | |
152 "The number of days elapsed between the Gregorian date 12/31/1 BC and DATE. | |
153 The Gregorian date Sunday, December 31, 1 BC is imaginary." | |
154 (let* ((cycle (car date)) | |
155 (year (car (cdr date))) | |
156 (month (car (cdr (cdr date)))) | |
157 (day (car (cdr (cdr (cdr date))))) | |
158 (g-year (+ (* (1- cycle) 60);; years in prior cycles | |
159 (1- year);; prior years this cycle | |
160 -2636));; years before absolute date 0 | |
161 (new-year (chinese-new-year g-year)) | |
162 (current-month new-year) | |
163 (current-month-number 1) | |
164 (next-month (chinese-new-moon-on-or-after (1+ new-year))) | |
165 (next-sign (chinese-zodiac-sign-on-or-after | |
166 (1+ (chinese-zodiac-sign-on-or-after current-month)))) | |
167 (had-leap-month nil)) | |
168 (while (< current-month-number month) | |
169 ;; current-month < next-month <= next-sign | |
170 (setq current-month next-month) | |
171 (setq next-month (chinese-new-moon-on-or-after (1+ current-month))) | |
172 (if (and (<= next-month next-sign) (not had-leap-month)) | |
173 (progn;; leap month | |
174 (setq current-month-number (+ current-month-number 0.5)) | |
175 (setq had-leap-month t)) | |
176 (setq current-month-number (floor (1+ current-month-number))) | |
177 (setq next-sign (chinese-zodiac-sign-on-or-after (1+ next-sign))))) | |
178 (+ current-month (1- day)))) | |
179 | |
180 (defun calendar-chinese-from-absolute (date) | |
181 "Compute Chinese date (cycle year month day) corresponding to absolute DATE. | |
182 The absolute date is the number of days elapsed since the (imaginary) | |
183 Gregorian date Sunday, December 31, 1 BC." | |
184 (let* ((greg-date (calendar-gregorian-from-absolute date)) | |
185 (greg-year (1- (extract-calendar-year greg-date))) | |
186 (greg-year | |
187 (+ greg-year | |
188 (calendar-sum y greg-year | |
189 (>= date (chinese-new-year (1+ y))) 1)) ) | |
190 (chinese-year (+ greg-year 2697)) | |
191 (cycle (/ (1- chinese-year) 60)) ;; previous cycles | |
192 (year (calendar-mod chinese-year 60));; years this cycle | |
193 (current-month (chinese-new-year greg-year)) | |
194 (month 1) | |
195 (next-month (chinese-new-moon-on-or-after (1+ current-month))) | |
196 (next-sign (chinese-zodiac-sign-on-or-after | |
197 (1+ (chinese-zodiac-sign-on-or-after current-month)))) | |
198 (had-leap-month nil)) | |
199 (while (<= next-month date) | |
200 ;; current-month < next-month <= next-sign | |
201 (setq current-month next-month) | |
202 (setq next-month (chinese-new-moon-on-or-after (1+ current-month))) | |
203 (if (and (<= next-month next-sign) (not had-leap-month)) | |
204 (progn;; leap month | |
205 (setq month (+ month 0.5)) | |
206 (setq had-leap-month t)) | |
207 (setq month (floor (1+ month))) | |
208 (setq next-sign (chinese-zodiac-sign-on-or-after (1+ next-sign))))) | |
209 (list cycle year month (1+ (- date current-month))))) | |
210 | |
211 (defun chinese-new-year (year) | |
212 "The absolute date of Chinese New Year in Gregorian YEAR." | |
213 (let* ((last-solstice (chinese-zodiac-sign-on-or-after | |
214 (calendar-absolute-from-gregorian | |
215 (list 12 15 (1- year))))) | |
216 (twelfth-new-moon;; twelfth month of previous year | |
217 (chinese-new-moon-on-or-after (1+ last-solstice))) | |
218 (thirteenth-new-moon;; maybe leap month, maybe New Year | |
219 (chinese-new-moon-on-or-after (1+ twelfth-new-moon))) | |
220 (fourteenth-new-moon;; maybe New Year, maybe second month | |
221 (chinese-new-moon-on-or-after (1+ thirteenth-new-moon))) | |
222 (next-solstice (chinese-zodiac-sign-on-or-after | |
223 (calendar-absolute-from-gregorian (list 12 15 year)))) | |
224 (new-moons (+ 3 (calendar-sum m 0 | |
225 (< (chinese-new-moon-on-or-after | |
226 (+ fourteenth-new-moon (* 29 m))) | |
227 next-solstice) | |
228 1)))) | |
229 (if (and (= new-moons 14) | |
230 (< (chinese-zodiac-sign-on-or-after | |
231 (calendar-absolute-from-gregorian (list 2 15 year))) | |
232 thirteenth-new-moon) | |
233 (<= fourteenth-new-moon | |
234 (chinese-zodiac-sign-on-or-after | |
235 (calendar-absolute-from-gregorian (list 3 15 year))))) | |
236 fourteeth-new-moon | |
237 thirteenth-new-moon))) | |
238 | |
239 (defun holiday-chinese-new-year () | |
240 "Date of Chinese New Year." | |
241 (let ((m displayed-month) | |
242 (y displayed-year)) | |
243 (increment-calendar-month m y 1) | |
244 (if (< m 5) | |
245 (let ((chinese-new-year | |
246 (calendar-gregorian-from-absolute | |
247 (chinese-new-year y)))) | |
248 (if (calendar-date-is-visible-p chinese-new-year) | |
249 (list (list chinese-new-year | |
250 (format "Chinese New Year (%s-%s)" | |
251 (aref chinese-calendar-celestial-stem | |
252 (% (+ y 6) 10)) | |
253 (aref chinese-calendar-terrestrial-branch | |
254 (% (+ y 8) 12)))))))))) | |
255 | |
256 (defun calendar-chinese-date-string (&optional date) | |
257 "String of Chinese date of Gregorian DATE. | |
258 Defaults to today's date if DATE is not given." | |
259 (let* ((a-date (calendar-absolute-from-gregorian | |
260 (or date (calendar-current-date)))) | |
261 (c-date (calendar-chinese-from-absolute a-date)) | |
262 (cycle (car c-date)) | |
263 (year (car (cdr c-date))) | |
264 (month (car (cdr (cdr c-date)))) | |
265 (day (car (cdr (cdr (cdr c-date))))) | |
266 (this-month (calendar-absolute-from-chinese | |
267 (list cycle year month 1))) | |
268 (next-month (calendar-absolute-from-chinese | |
269 (list cycle year (1+ month) 1))) | |
270 (month (floor month)) | |
271 (m-cycle (% (+ (* year 5) month) 60))) | |
272 (format "Cycle %s, year %s (%s-%s), %smonth %s, day %s (%s-%s)" | |
273 cycle | |
274 year | |
275 (aref chinese-calendar-celestial-stem (% (+ year 9) 10)) | |
276 (aref chinese-calendar-terrestrial-branch (% (+ year 11) 12)) | |
277 (if (not (integerp month)) | |
278 "second " | |
279 (if (< 30 (- next-month this-month)) | |
280 "first " | |
281 "")) | |
282 month | |
283 day | |
284 (aref chinese-calendar-celestial-stem (% (+ a-date 4) 10)) | |
285 (aref chinese-calendar-terrestrial-branch (% (+ a-date 2) 12))))) | |
286 | |
287 (defun calendar-print-chinese-date () | |
288 "Show the Chinese date equivalents of date." | |
289 (interactive) | |
290 (message "Computing Chinese date...") | |
291 (message "Chinese date: %s" | |
292 (calendar-chinese-date-string (calendar-cursor-to-date t)))) | |
293 | |
294 (defun calendar-goto-chinese-date (date &optional noecho) | |
295 "Move cursor to Chinese date DATE. | |
296 Echo Chinese date unless NOECHO is t." | |
297 (interactive | |
298 (let* ((c (calendar-chinese-from-absolute | |
299 (calendar-absolute-from-gregorian | |
300 (calendar-current-date)))) | |
301 (cycle (calendar-read | |
302 "Cycle number (>44): " | |
303 '(lambda (x) (> x 44)) | |
304 (int-to-string (car c)))) | |
305 (year (calendar-read | |
306 "Year in cycle (1..60): " | |
307 '(lambda (x) (and (<= 1 x) (<= x 60))) | |
308 (int-to-string (car (cdr c))))) | |
309 (month (read-minibuffer "Month: ")) | |
310 (day (read-minibuffer "Day: "))) | |
311 (list (list cycle year month day)))) | |
312 (calendar-goto-date (calendar-gregorian-from-absolute | |
313 (calendar-absolute-from-chinese date))) | |
314 (or noecho (calendar-print-chinese-date))) | |
315 | |
316 (defun diary-chinese-date () | |
317 "Chinese calendar equivalent of date diary entry." | |
318 (format "Chinese date: %s" (calendar-chinese-date-string date))) | |
319 | |
320 (provide 'cal-chinese) | |
321 | |
322 ;;; cal-chinese ends here |