! 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 => 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 ; ! 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