Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Open sidebar
emacs
emacs
Commits
00e3e480
Commit
00e3e480
authored
Nov 17, 1995
by
Edward M. Reingold
Browse files
Minor fixes.
parent
07986bc4
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
81 additions
and
78 deletions
+81
-78
lisp/calendar/cal-china.el
lisp/calendar/cal-china.el
+81
-78
No files found.
lisp/calendar/cal-china.el
View file @
00e3e480
...
...
@@ -46,12 +46,12 @@
(
require
'lunar
)
(
defvar
chinese-calendar-terrestrial-branch
[
"Zi"
"Chou"
"Yin"
"Mao"
"Chen"
"Si"
"Wu"
"Wei"
"Shen"
"You"
"Xu"
"Hai"
]
)
(
defvar
chinese-calendar-celestial-stem
[
"Jia"
"Yi"
"Bing"
"Ding"
"Wu"
"Ji"
"Geng"
"Xin"
"Ren"
"Gui"
]
)
(
defvar
chinese-calendar-terrestrial-branch
[
"Zi"
"Chou"
"Yin"
"Mao"
"Chen"
"Si"
"Wu"
"Wei"
"Shen"
"You"
"Xu"
"Hai"
]
)
(
defvar
chinese-calendar-time-zone
'
(
if
(
<
year
1928
)
(
+
465
(
/
40.0
60.0
))
...
...
@@ -64,9 +64,12 @@ 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
(
defvar
chinese-calendar-daylight-time-offset
0
; The correct value is as follows, but the Chinese calendrical
; authorities do NOT use DST in determining astronomical events:
; 60
"*Number of minutes difference between daylight savings and standard time
for Chinese calendar."
)
for Chinese calendar.
Default is for no daylight savings time.
"
)
(
defvar
chinese-calendar-standard-time-zone-name
'
(
if
(
<
year
1928
)
...
...
@@ -77,25 +80,31 @@ 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
))
(
defvar
chinese-calendar-daylight-savings-starts
nil
; The correct value is as follows, but the Chinese calendrical
; authorities do NOT 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. See documentation of `calendar-daylight-savings-starts'."
)
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
))
(
defvar
chinese-calendar-daylight-savings-ends
nil
; The correct value is as follows, but the Chinese calendrical
; authorities do NOT 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. See documentation of `calendar-daylight-savings-ends'."
)
calendar. Default is for no daylight savings time. See documentation of
`calendar-daylight-savings-ends'."
)
(
defvar
chinese-calendar-daylight-savings-starts-time
0
"*Number of minutes after midnight that daylight savings time starts for
Chinese calendar."
)
Chinese calendar.
Default is for no daylight savings time.
"
)
(
defvar
chinese-calendar-daylight-savings-ends-time
0
"*Number of minutes after midnight that daylight savings time ends for
Chinese calendar."
)
Chinese calendar.
Default is for no daylight savings time.
"
)
(
defun
chinese-zodiac-sign-on-or-after
(
d
)
"Absolute date of first new Zodiac sign on or after absolute date d.
...
...
@@ -148,42 +157,34 @@ The Zodiac signs begin when the sun's longitude is a multiple of 30 degrees."
(
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
)
(
10
.
727142
)
(
11
.
727172
))
(
1992
(
12
.
727202
)
(
1
.
727232
)
(
2
.
727261
)
(
3
.
727291
)
(
4
.
727321
)
(
5
.
727350
)
(
6
.
727379
)
(
7
.
727409
)
(
8
.
727438
)
(
9
.
727467
)
(
10
.
727497
)
(
11
.
727526
))
(
1993
(
12
.
727556
)
(
1
.
727586
)
(
2
.
727615
)
(
3
.
727645
)
(
3.5
.
727675
)
(
4
.
727704
)
(
5
.
727734
)
(
6
.
727763
)
(
7
.
727793
)
(
8
.
727822
)
(
9
.
727851
)
(
10
.
727881
)
(
11
.
727910
))
(
1994
(
12
.
727940
)
(
1
.
727969
)
(
2
.
727999
)
(
3
.
728029
)
(
4
.
728059
)
(
5
.
728088
)
(
6
.
728118
)
(
7
.
728147
)
(
8
.
728177
)
(
9
.
728206
)
(
10
.
728235
)
(
11
.
728265
))
(
1995
(
12
.
728294
)
(
1
.
728324
)
(
2
.
728353
)
(
3
.
728383
)
(
4
.
728413
)
(
5
.
728442
)
(
6
.
728472
)
(
7
.
728501
)
(
8
.
728531
)
(
8.5
.
728561
)
(
9
.
728590
)
(
10
.
728619
)
(
11
.
728649
))
(
1996
(
12
.
728678
)
(
1
.
728708
)
(
2
.
728737
)
(
3
.
728767
)
(
4
.
728796
)
(
5
.
728826
)
(
6
.
728856
)
(
7
.
728885
)
(
8
.
728915
)
(
9
.
728944
)
(
10
.
728974
)
(
11
.
729004
))
(
1997
(
12
.
729033
)
(
1
.
729062
)
(
2
.
729092
)
(
3
.
729121
)
(
4
.
729151
)
(
5
.
729180
)
(
6
.
729210
)
(
7
.
729239
)
(
8
.
729269
)
(
9
.
729299
)
(
10
.
729328
)
(
11
.
729358
))
(
1998
(
12
.
729388
)
(
1
.
729417
)
(
2
.
729447
)
(
3
.
729476
)
(
4
.
729505
)
(
5
.
729535
)
(
5.5
.
729564
)
(
6
.
729593
)
(
7
.
729623
)
(
8
.
729653
)
(
9
.
729682
)
(
10
.
729712
)
(
11
.
729742
))
(
1999
(
12
.
729771
)
(
1
.
729801
)
(
2
.
729831
)
(
3
.
729860
)
(
4
.
729889
)
(
5
.
729919
)
(
6
.
729948
)
(
7
.
729977
)
(
8
.
730007
)
(
9
.
730036
)
(
10
.
730066
)
(
11
.
730096
))
(
2000
(
12
.
730126
)
(
1
.
730155
)
(
2
.
730185
)
(
3
.
730215
)
(
4
.
730244
)
(
5
.
730273
)
(
6
.
730303
)
(
7
.
730332
)
(
8
.
730361
)
(
9
.
730391
)
(
10
.
730420
)
(
11
.
730450
)))
'
((
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
)
(
10
727142
)
(
11
727172
))
(
1992
(
12
727202
)
(
1
727232
)
(
2
727261
)
(
3
727291
)
(
4
727321
)
(
5
727350
)
(
6
727379
)
(
7
727409
)
(
8
727438
)
(
9
727467
)
(
10
727497
)
(
11
727526
))
(
1993
(
12
727556
)
(
1
727586
)
(
2
727615
)
(
3
727645
)
(
3.5
727675
)
(
4
727704
)
(
5
727734
)
(
6
727763
)
(
7
727793
)
(
8
727822
)
(
9
727851
)
(
10
727881
)
(
11
727910
))
(
1994
(
12
727940
)
(
1
727969
)
(
2
727999
)
(
3
728029
)
(
4
728059
)
(
5
728088
)
(
6
728118
)
(
7
728147
)
(
8
728177
)
(
9
728206
)
(
10
728235
)
(
11
728265
))
(
1995
(
12
728294
)
(
1
728324
)
(
2
728353
)
(
3
728383
)
(
4
728413
)
(
5
728442
)
(
6
728472
)
(
7
728501
)
(
8
728531
)
(
8.5
728561
)
(
9
728590
)
(
10
728619
)
(
11
728649
))
(
1996
(
12
728678
)
(
1
728708
)
(
2
728737
)
(
3
728767
)
(
4
728796
)
(
5
728826
)
(
6
728856
)
(
7
728885
)
(
8
728915
)
(
9
728944
)
(
10
728974
)
(
11
729004
))
(
1997
(
12
729033
)
(
1
729062
)
(
2
729092
)
(
3
729121
)
(
4
729151
)
(
5
729180
)
(
6
729210
)
(
7
729239
)
(
8
729269
)
(
9
729299
)
(
10
729328
)
(
11
729358
))
(
1998
(
12
729388
)
(
1
729417
)
(
2
729447
)
(
3
729476
)
(
4
729505
)
(
5
729535
)
(
5.5
729564
)
(
6
729593
)
(
7
729623
)
(
8
729653
)
(
9
729682
)
(
10
729712
)
(
11
729742
))
(
1999
(
12
729771
)
(
1
729801
)
(
2
729831
)
(
3
729860
)
(
4
729889
)
(
5
729919
)
(
6
729948
)
(
7
729977
)
(
8
730007
)
(
9
730036
)
(
10
730066
)
(
11
730096
))
(
2000
(
12
730126
)
(
1
730155
)
(
2
730185
)
(
3
730215
)
(
4
730244
)
(
5
730273
)
(
6
730303
)
(
7
730332
)
(
8
730361
)
(
9
730391
)
(
10
730420
)
(
11
730450
)))
"An assoc list of Chinese year structures as determined by `chinese-year'.
Values are computed as needed, but to save time, the initial value consists
...
...
@@ -192,7 +193,7 @@ set to nil initially (which is how the value for 1989-2000 was computed).")
(
defun
chinese-year
(
y
)
"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,
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
Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y.
...
...
@@ -202,7 +203,7 @@ The list is cached for further use."
(
progn
(
setq
list
(
compute-chinese-year
y
))
(
setq
chinese-year-cache
(
append
chinese-year-cache
(
list
(
cons
y
list
))))))
(
append
chinese-year-cache
(
list
(
cons
y
list
))))))
list
))
(
defun
number-chinese-months
(
list
start
)
...
...
@@ -210,24 +211,21 @@ The list is cached for further use."
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
))
(
cons
(
list
start
(
car
list
))
(
number-chinese-months
(
cdr
list
)
(
1+
start
)))
(
cons
;; First month
(
cons
start
(
car
list
))
(
list
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
)))
(
cons
(
list
(
+
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
)))))))
...
...
@@ -237,12 +235,12 @@ First month of list will never be a leap month, nor will the last."
(
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
))))))
(
cons
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,
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
Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y."
(
let*
((
next-solstice
(
chinese-zodiac-sign-on-or-after
...
...
@@ -255,21 +253,21 @@ Gregorian year Y-1 to the Chinese month of the solstice of Gregorian year Y."
(
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
))
(
cons
(
list
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
))))
(
append
(
list
(
list
11.5
(
car
list
))
(
list
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
)))
(
append
(
list
(
list
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
)))
(
cons
(
list
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
)))))))
...
...
@@ -285,10 +283,11 @@ The Gregorian date Sunday, December 31, 1 BC is imaginary."
(
1-
year
)
;; prior years this cycle
-2636
)))
;; years before absolute date 0
(
+
(
1-
day
)
;; prior days this month
(
cdr
;; absolute date of start of this month
(
assoc
month
(
append
(
memq
(
assoc
1
(
chinese-year
g-year
))
(
chinese-year
g-year
))
(
chinese-year
(
1+
g-year
))))))))
(
car
(
cdr
;; absolute date of start of this month
(
assoc
month
(
append
(
memq
(
assoc
1
(
chinese-year
g-year
))
(
chinese-year
g-year
))
(
chinese-year
(
1+
g-year
)))))))))
(
defun
calendar-chinese-from-absolute
(
date
)
"Compute Chinese date (cycle year month day) corresponding to absolute DATE.
...
...
@@ -296,18 +295,22 @@ The absolute date is the number of days elapsed since the (imaginary)
Gregorian date Sunday, December 31, 1 BC."
(
let*
((
g-year
(
extract-calendar-year
(
calendar-gregorian-from-absolute
date
)))
(
c
hinese
-year
(
+
g-year
2695
))
(
c-year
(
+
g-year
2695
))
(
list
(
append
(
chinese-year
(
1-
g-year
))
(
chinese-year
g-year
)
(
chinese-year
(
1+
g-year
)))))
(
while
(
<=
(
cdr
(
car
(
cdr
list
)))
date
)
(
while
(
<=
(
car
(
cdr
(
car
(
cdr
list
))))
date
)
;; the first month on the list is in Chinese year c-year
;; date is on or after start of second month on list...
(
if
(
=
1
(
car
(
car
(
cdr
list
))))
(
setq
chinese-year
(
1+
chinese-year
)))
;; second month on list is a new Chinese year
(
setq
c-year
(
1+
c-year
)))
;; ...so first month on list is of no interest
(
setq
list
(
cdr
list
)))
(
list
(
/
(
1-
c
hinese
-year
)
60
)
(
calendar-mod
c
hinese
-year
60
)
(
list
(
/
(
1-
c-year
)
60
)
(
calendar-mod
c-year
60
)
(
car
(
car
list
))
(
1+
(
-
date
(
cdr
(
car
list
)))))))
(
1+
(
-
date
(
car
(
cdr
(
car
list
)))))))
)
(
defun
holiday-chinese-new-year
()
"Date of Chinese New Year."
...
...
@@ -317,7 +320,7 @@ Gregorian date Sunday, December 31, 1 BC."
(
if
(
<
m
5
)
(
let
((
chinese-new-year
(
calendar-gregorian-from-absolute
(
cdr
(
assoc
1
(
chinese-year
y
))))))
(
car
(
cdr
(
assoc
1
(
chinese-year
y
))))))
)
(
if
(
calendar-date-is-visible-p
chinese-new-year
)
(
list
(
list
chinese-new-year
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment
