Date Arithmetic

artkennedy

Date arithmetic anyone? Don't know if this has been done before in Forth or Tachyon. If so I have flung a lot of sweat reinventing the wheel. I thought I would like to have functions DATE+ and DDAYS like the ones on my Hp-48's. I thought it would be simple. Big laugh. Anyway it passes my test. If anyone is interested you are welcome to use it but you should test it first. It has passed my tests but I might have missed something. If you find something to improve I would like to know about it.

--- Version 0.4

FORGET daymo
TABLE daymo
  0 || 31 || 59 || 90 || 120 || 151 || 181 || 212 || 243 || 273 || 304 || 334 || 365 ||

: DOM1           ( mm -- dom1 )  --- dom1 - 1st day of month
      1- daymo SWAP 2 * + W@  --- fetch first day of month ( base 0 )
;

: SYSDAY      ( yymmdd -- sysday ) --- 20010101 subtracted from yymmdd,
                                     ---   sysday = number of days since 20010101 (Jan 01, 2001) base 0.
    HMS -ROT        --- ( yymmdd -- yy dd mm )
    3RD 4 MOD       --- (  -- yy dd mm lyf )  lyf = 1 if leap year
    OVER DOM1 1-    --- (  -- yy dd mm lyf Zdom ) dom1 - 1 = Zdom, Zeroth day of month
    ROT 2 >         --- (  -- yy dd lyf Zdom ldf ) ldf = 1 if March or later
    ROT NOT         --- (  -- yy dd Zdom ldf lyf )
    AND NOT         --- (  -- yy dd Zdom lda ) lda = leap day addition if any
    + + 1+          --- (  -- yy doy ) doy = day of year (base 0) with leap adjustment, 1+ restores Zdom offset
    SWAP 1-         --- (  -- doy pyy )     pyy = prev years
    DUP 4 /         --- (  -- doy pyy pld ) pld = how many prev leap days
    SWAP 365 * + +  --- (  -- sysday ) # of prev regular days - sum, sysday (see above)
;

: DOY1  ( yy --- doy1 )  --- yy = year, doy1 = first day thereof , totally confirmed.
      1- DUP 4 /            --- num of prev leap days, calculation is done with ordinal of previous year
      SWAP 365 * +          --- add leap days --> sysday of first doy
;

: YRDOY   ( sysday -- yy doy ) --- true year and doy ( includes leap day )
    DUP 365 / 1+ DUP DOY1      --- guess the year and check it out
                               ---       ( sysday 365 / returns the year before the target...therefore 1+ )
    3RD SWAP -                 --- sysday - doy1
    DUP 0< IF                  --- IF negative result ( means year is +1 )
      DROP                     ---   drop result
      1- DUP DOY1              ---   decrement year and try again
      ROT SWAP -               ---   sysday - doy1 --> good this time
    ELSE                       --- ELSE
      ROT DROP                 ---   drop sysday
    THEN                       --- THEN
;

: DAYMO       ( doy -- mm dd )   --- derive month and day of month from day of year
    daymo 22 + FROM -2 BY 12     --- search backward through daymo for 1dom equal to or less than doy
    FOR
      DUP
      I W@
      => IF I LEAVE THEN         --- found it!
    NEXT
    DUP daymo - 2/ 1+            --- extract mm from search address
    -ROT W@ - 1+                 --- subtract doy of first day of month from target doy
;

: DAY>DATE        ( sysday -- yymmdd )       --- sysday to yymmdd
    YRDOY                ( sysday -- yy doy )
    OVER 4 MOD 0 > NOT   ( -- yy doy lyf )      --- leap year?
    OVER 59 >            ( -- yy doy lyf ldf )  --- after leap day if any?
    AND +                ( -- yy doy )          --- combine flags and use result to increment doy or not
    DAYMO                ( -- yy mm dd )        ---
    4TH 59 =             ( -- yy mm dd lyf )    ---
    4TH 4 MOD NOT AND    ( -- yy mm dd ldsf )   --- ldsf = ld substitution flag
    IF                   ( -- yy mm dd )        --- if ld sensed
      2DROP 2 29         ( -- yy mm' dd' )      ---   leap day substituted
    THEN                 ( -- )                     --- then
    SWAP 100 * +         ( -- yy mmdd )         --- compile yymmdd
    SWAP 10000 * +       ( -- yymmdd )
    SWAP DROP            ( -- yymmdd )
;

: DOW   ( sysday -- dow )
         1+ 7 MOD
;

: DATE+  ( yymmdd n -- yymmdd + n )
    SWAP SYSDAY
    + DAY>DATE
;

: DDAYS  ( yymmdd yymmdd' -- ddays )  --- subtract yymmdd' from yymmdd --> days between two dates
       SYSDAY SWAP SYSDAY SWAP -
;