Paste: discal

! Copyright (C) 2015 Alex Maestas.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators command-line formatting io kernel locals
math math.functions math.parser namespaces sequences system words ;
FROM: calendar => <date> today ;
FROM: continuations => recover ;
FROM: debugger => print-error ;
IN: discal

CONSTANT: days { "Sweetmorn" "Boomtime" "Pungenday" "Prickle-Prickle"
                 "Setting Orange" }
CONSTANT: months { "Chaos" "Discord" "Confusion" "Bureaucracy" "Aftermath" }
CONSTANT: apostle-holydays { "Mung" "Mojo" "Sya" "Zara" "Mala" }
CONSTANT: season-holydays { "Chao" "Disco" "Confu" "Bure" "Af" }
CONSTANT: day-count { 0 31 59 90 120 151 181 212 243 273 304 334 }

: roll ( x y z t -- y z t x ) [ rot ] dip swap ; inline
: inflect ( day -- inflected-day )
    [ { { [ dup 10 / floor 1 = ] [ drop "th" ] }
        { [ dup 10 mod 1 = ] [ drop "st" ] }
        { [ dup 10 mod 2 = ] [ drop "nd" ] }
        { [ dup 10 mod 3 = ] [ drop "rd" ] }
        [ drop "th" ] }
      cond
    ] keep
    number>string swap 2array "" concat-as ;

: djulian ( month day -- julian )
    [ day-count nth ] dip + ;
: dmonth ( julian -- month )
    73 / floor months nth ;
: ddow ( julian -- of-week )
    5 mod days nth ;
: (dday) ( jday -- day )
    73 mod 1 + ;
: dday ( day -- inflected-day )
    (dday) inflect ;

: (celebrate) ( thing suffix -- string )
    "Celebrate " swap surround ;
:: (dholy) ( y m d -- string/f )
    m d djulian (dday)
    { { 5 [ m 1 - apostle-holydays nth "day" (celebrate) ] }
      { 50 [ m 1 - season-holydays nth "flux" (celebrate) ] }
      [ drop f ] }
    case ;
: (ddate) ( y m d -- string )
    2dup
    2array
    { { { 1 28 }
        [ 2drop 3066 + "St. Tibs Day in the YOLD %d" sprintf ] }
      [ drop
        djulian [ 3066 + ] dip
        [ ddow ] [ dday ] [ dmonth ] tri
        roll
        "%s, the %s day of %s in the YOLD %d" sprintf ] }
      case ;

: usage ( error -- * )
    [ print-error "ddate yyyy mm dd" print flush ]
    with-output>error
    1 exit ;
: extract-from-timestamp ( ts -- y m d )
    [ year>> 1900 - ] [ month>> 1 - ] [ day>> 1 - ] tri ;
: (parse-command-line) ( seq -- date )
    [ string>number ] map
    [ [ zero? ] any? [ "zero date" throw ] when ] keep
    first3 <date> ; ! validate ;


: ddate ( -- )
    [ command-line get {
        { [ dup length 0 = ] [ drop today "Today is " write ] }
        { [ dup length 3 = ] [ (parse-command-line) ] }
        [ "bad command line" throw ] }
      cond ]
    [ usage ] recover
    [ extract-from-timestamp
      [ (ddate) print ]
      [ (dholy) [ print ] when* ] 3bi ]
    [ "disagreeable date" usage ] recover ;

MAIN: ddate