\ calendar


: 3dup  ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 )  2dup 4 pick -rot ;  
: spaces ( n -- )           0 ?do space loop ;
: u.r   ( n1 n2 -- )        >r <# #s #>  r@ min r> over - spaces type  ;

decimal
: gregor             ( dd mm yyyy -- gregor )
    >r 3 - dup 0<
    dup r> + >r 12 and +
    306 *  5 +  10 / +
    r@  1461 4 */  + 1+
    r@ 100 / -  
    r> 400 / +
;

: dow  ( dd mm yyyy -- 0...6 )     gregor 7 mod  ;      \ 0: monday 1: tuesday .... 6: sunday 
: .weekday ( 0...6 -- )     7 mod 2* s" MoTuWeThFrSaSu" drop + 2 type  ;
: .month ( m -- )           1- 3 *   s" JanFebMarAprMayJunJulAugSepOctNovDec" drop + 3 type ;
: days/month ( m y -- n )   1 -rot 3dup gregor >r >r 1+ 12 /mod r> + gregor r> - 7 mod 28 + ;

: calendar ( d m y -- )
   cr 6 spaces over .month space dup .
   cr 7 0 do space i .weekday loop
   2dup 1 -rot dow
   cr dup 3 * spaces
   -rot days/month 1+ 1 do
      i 3 u.r
      1+ dup 7 mod
      0= if cr then
   loop  2drop  ;

1 3 2003 calendar