中國農民曆程式
( Calendar Conversions, 29oct01cht )
( From E. G. Richards, Mapping Time: The Calendar and its History, )
( Oxford University Press, London, 1998 )
4716 constant y ( computational year in which J1 falls )
1401 constant j ( number ov days that Jc falls befor day 0, j=-Jc )
3 constant m ( number of month in a year for which M'=0 )
12 constant n ( number of months in a year )
4 constant r ( number of years in a cycle of intercalation )
1461 constant p ( number of days in a cycle of intercalation )
0 constant q
3 constant v
5 constant u
153 constant s
2 constant t
2 constant w
184 constant A
274277 constant B
-38 constant G
36524 constant K
1 constant sunday-offset
variable year ( Y, year number in given calendar )
variable month ( M, month number in given calendar )
variable day ( D, day number in given calendar )
variable y' ( year number in computational calendar )
variable m' ( month number in computational calendar )
variable d' ( day number in computational calendar )
: computational-date ( day/month/year to d'/m'/y' )
year @ y +
n m + 1- month @ - n / - y' !
month @ m - n + n mod m' !
day @ 1- d' !
;
: given-date ( d'/m'/y' to day/month/year )
d' @ 1+ day !
m' @ m + 1- n mod 1+ month !
n m + 1- month @ - n /
y' @ + y - year !
;
: julian ( -- julian-date, from given-date in D/M/Y )
computational-date
y' @ p * q + r / ( c )
m' @ s * t + u / ( d ) +
y' @ A + 100 / 3 * 4 / G + ( g ) -
d' @ + j -
;
: date ( julian-date -- )
dup 4 * B +
K 4 * 1+ /
3 * 4 / G + ( g ) +
j + ( J' )
r * v + p /mod ( T'*r Y' ) y' !
r / ( T' ) u * w + s /mod ( D'*u M' )
m' !
u / d' !
given-date
;
: .date ( -- )
month @ 1 .r ." /" day @ 1 .r ." /" year @ 1 .r ;
: MDY ( day month year -- )
year ! day ! month ! ;
( 10 23 2001 mdy julian . 2452206 ok )
: week-day ( -- n, 0 Sunday, 1 Monday, ..., 6 Saturday )
julian sunday-offset +
7 mod ;
( Lunar Calendar )
( tropical-year 365.242190 days )
( lunation 29.530589 days )
( lunar-month=[julian+offset]/lunation )
( lunar-day=mod[[julian+offset],lunation] )
( lunar-first=int[lunar-month*lunation]+offset )
( spring-equinox of a year, 21 3 year julian )
( chi, 24 chi's of a year )
( chi[i]=spring-equinox+int[tropical-year*[i-5]/24] )
( sprint-equinox=chi[5] )
( summer-solstice=chi[11] )
( autumn-equinox=chi[17] )
( winter-solstice=chi[23], chi[-1] )
( lunar-new-year, first day of a lunar year )
-9 constant new-moon-offset
29530589 1000000 2constant lunation
365242190 1000000 2constant tropical-year
: spring-equinox ( -- day )
3 21 year @ mdy julian ;
: chi ( i -- day )
tropical-year >r
swap 5 - dup 0<
if abs 24 */ r> / negate
else 24 */ r> / then
spring-equinox + ;
: lunar-day ( day -- n, 1000000*[days in a lunar month] )
new-moon-offset + lunation swap */mod drop
;
: intercalation ( day -- f, 0 intercate, -1 last-chi, 1 first-chi )
lunar-day
tropical-year drop 24 /
2dup > if 2drop -1 exit then
+ lunation drop >
if 0 else 1 then
;
: first ( day -- lunar-1st-day )
dup lunar-day 1000000 / - ;
: lunar-new-year ( year -- day )
year !
-1 chi intercalation ?dup
if else 4 chi first exit then
-1 =
if 0 chi intercalation
if 2 else 3 then
chi first exit
then
2 chi intercalation
if 3 else 4 then chi first
;
: nn ( year -- )
lunar-new-year
date .date ;
comment:
some test results
2000 nn 5/2/2000 ok
2001 nn 24/1/2001 ok
1912 nn 18/2/1912 ok
1913 nn 6/2/1913 ok
1950 nn 17/2/1950 ok
1975 nn 11/2/1975 ok
2031 nn 23/1/2031 ok
comment;
: mm ( year --, display date of new moons )
lunar-new-year 1
13 0 do cr dup 3 .r space
over over 1-
lunation drop 1000000 */ +
date .date
1+
loop 2drop
;
( display lunar months interlaced with chi )
create chi-table 25 4 * allot
: fill-chi-table ( -- )
chi-table
24 0 do
i chi over !
4 +
loop
$7fffffff swap !
;
: show-chi-table ( -- )
chi-table
24 0 do
cr i 3 .r dup @ date .date
4 +
loop
drop
;
: cc ( year -- )
lunar-new-year
fill-chi-table
chi-table ( new-year table -- )
cr 15 spaces
14 1 do
over i 1-
lunation drop 1000000 */ + ( ny table chi -- )
begin over @ over <
while over @ date .date space
swap 4 + swap
repeat
cr i 3 .r space date .date space
loop 2drop
;