\ calendar 97.11.25 12:56 am NAB
\ ANSI Forth Gregorian & ISO
\ date routines. Algorithms are
\ from 'Calendrical Calculations',
\ N. Dershowitz & E.M. Reingold, 1997,
\ ISBN 0-521-56474-3.
\ Note: dates before year 1 are not
\ currently supported by this
\ implementation.
needs dblmath
0 constant Sunday
1 constant Monday
2 constant Tuesday
3 constant Wednesday
4 constant Thursday
5 constant Friday
6 constant Saturday
1 constant January
2 constant February
3 constant March
4 constant April
5 constant May
6 constant June
7 constant July
8 constant August
9 constant September
10 constant October
11 constant November
12 constant December
: date>day-of-week 7 dmod ;
: kday ( d1 k o -- d2)
\ Compute kday on-or-before d1+o:
swap >r ( R: k) m+ ( d1+o)
2dup r> ( k) s>d d- ( d1-k)
date>day-of-week s>d d- ( d2) ;
: before ( d1 k -- d2) -1 kday ;
: on-or-before ( d1 k -- d2) 0 kday ;
: nearest ( d1 k -- d2) 3 kday ;
: on-or-after ( d1 k -- d2) 6 kday ;
: after ( d1 k -- d2) 7 kday ;
: nth ( d1 k n -- d2)
\ Find nth kday relative to date d1:
7 * dup >r ( R: nweeks)
0 > if before else on-or-after then
r> ( nweeks) m+ ;
: last ( d1 k -- d2) -1 nth ;
: first ( d1 k -- d2) 1 nth ;
: second ( d1 k -- d2) 2 nth ;
: third ( d1 k -- d2) 3 nth ;
: fourth ( d1 k -- d2) 4 nth ;
: fifth ( d1 k -- d2) 5 nth ;
: leapyear? ( year -- bool)
dup 4 mod 0=
over 100 mod 0= invert and
swap 400 mod 0= or ;
: dmy>date ( day month year -- d)
dup leapyear? >r ( R: leapyear?)
\ Compute days to start of year:
1- s>d ( year-1.)
2dup 365 dm* \ ordinary days
\ ...plus leap days:
2over 4 dm/ d+
2over 100 dm/ d-
2swap 400 dm/ d+
\ Compute days to start of month
\ (assumes Feb. has 30 days):
rot dup >r ( R: month) s>d 367 dm*
-362 m+ 12 dm/ d+ \ rough count
\ ...adjust for February:
r> February > -2 \ 28 days
\ 29 in leap years:
r> ( leapyear?) 1 and + and m+
\ Add days from start of month:
rot m+ ;
: reduce ( ud1 ud2 -- udquot udrem)
ud/mod 2swap ;
: date>year ( d -- year)
\ Multiple-radix conversion.
1. d-
\ 146097=365.2425*400:
146097. reduce ( n400.)
36524. reduce ( n100.)
2over 4. d= >r ( R: n100=4?)
1461. reduce ( n4.) \ 1461=365.25*4
365. reduce ( n1.) 2drop
\ Correct for ends-of-cycles;
\ n1=n1+1 unless n1=4 or n100=4:
2dup 4. d= ( n1=4?) r> ( n100=4?)
or -1 and 1+ m+
\ Combine results:
2swap 4 dm* d+ \ year=n1+4*n4
2swap 100 dm* d+ \ +100*n100
2swap 400 dm* d+ \ +400*n400.
d>s ( year) ;
: date>dmy ( d -- day month year)
\ Determine year:
2dup date>year >r ( R: year)
\ Compute prior days in year:
2dup 1 January r@ dmy>date d-
\ Adjust for leap years:
2over 1 March r@ dmy>date
d< invert 2 r@ leapyear? 1 and -
and m+
\ Compute month:
12 dm* 373 m+ 367 dm/ d>s
\ Compute prior days in month:
1 over r@ ( year) dmy>date
rot >r ( R: -- year month)
d- d>s 1+ ( day)
r> ( month) r> ( year) ;
: iso>date ( day week year -- d)
\ Find nth Sunday in ISO year:
28 December rot 1- dmy>date
rot Sunday swap nth
\ Add day:
rot m+ ;
: date>iso ( d -- day week year)
2dup 2dup 2dup
\ Approx. ISO year:
3. d- date>year >r ( R: year)
\ Add 1 if date is in next ISO year:
1 1 r@ ( year) 1+ iso>date
d< invert 1 and r> + >r
\ Compute week:
1 1 r@ ( year) iso>date d-
7 dm/ 1 m+ d>s >r ( R: year week)
7 admod ( day)
r> ( week) r> ( year) ;