\ 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) ;