\ 4tH library - String to date conversion - Copyright 2012 J.L. Bezemer
\ You can redistribute this file and/or modify it under
\ the terms of the GNU General Public License

[UNDEFINED] s>date   [IF]
[UNDEFINED] is-digit [IF] include lib/istype.4th   [THEN]
[UNDEFINED] split<   [IF] include lib/tokenize.4th [THEN]
[UNDEFINED] row      [IF] include lib/row.4th      [THEN]

\ Note this library has a bias towards the European format.
\ If you want to fix this, use pragma FORCEAMERICANDATE.
\ Supplying a four digit year helps to determine the difference
\ between ISO and default formats.

27 constant _NO_DATE_                  \ cannot be a valid date
31536000 constant s/year               \ seconds per year

: d-m-y swap rot ;                     \ swap order on stack for
: m-d-y rot ;                          \ various date formats
: y-m-d ;
: y-d-m rot swap ;

create reorder-date
[DEFINED] forceamericandate
[IF]
   0 , ' m-d-y ,
   1 , ' m-d-y ,
   2 , ' m-d-y ,                       \ the flag has three digits:
[ELSE]
   0 , ' d-m-y ,                       \ 0 = 0 < x < 13
   1 , ' d-m-y ,                       \ 1 = > 12
   2 , ' d-m-y ,                       \ 2 = > 31
[THEN]
   3 , ' m-d-y ,                       \ e.g. 210 = (9*2) + (3*1) + 0 = 21
   4 , ' m-d-y ,                       \ this table selects the appropriate
   5 , ' m-d-y ,                       \ word to reorder the stack
   9 , ' d-m-y ,
  10 , ' d-m-y ,
  11 , ' d-m-y ,
  12 , ' y-d-m ,
  18 , ' y-m-d ,
  19 , ' y-m-d ,
  21 , ' y-d-m ,
  NULL ,
does>
  2 num-key row
  if nip cell+ @c execute else drop drop drop drop drop 1 dup 1970 then
;
                                       \ n3 is a code in base 3: 0 - 1 - 2
: (nn)                                 ( a1 n1 -- n2 n3)
  number dup 0>                        \ if it is a valid date part
  if 0 over 12 > if 1+ over 31 > if 1+ then then else _NO_DATE_ then swap
;                                      \ evaluate it, else return _NO_DATE_

: s>date                               ( a1 n1 -- d m y)
  ['] is-type defer@ >r :noname is-digit 0= ; is is-type
  split< dup                           \ split first part
  if                                   \ is there anything left to split?
    1- split< dup                      \ adjust remaining string and repeat
    if                                 \ is there anything left to split?
      1- (nn) >r 9 * >r (nn) >r 3 *    \ convert and evaluate the parts
      >r (nn) r> rot + r> r> rot + r> swap
      reorder-date dup 100 <           \ now reorder and make 4 digit year
      if time s/year / over < if 1900 + else 2000 + then then
      r> is is-type exit               \ restore deferred word
    else                               \ null string?
      2drop                            \ drop the part split
    then                               \ drop remaining parts, 1/1/1970
  then 2drop 2drop 1 dup 1970 r> is is-type
;

[DEFINED] 4TH# [IF]
  hide d-m-y
  hide m-d-y
  hide y-m-d
  hide y-d-m
  hide _NO_DATE_
  hide reorder-date
  hide (nn)
  hide s/year
[THEN]
[THEN]
