steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix calendar

db4
Slava Pestov 2008-01-10 23:06:23 -05:00
parent afd4732409
commit 0a6aff794b
1 changed files with 12 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
extra/calendar/calendar.factor
View File

@ -4,7 +4,7 @@
USING: arrays hashtables io io.streams.string kernel math USING: arrays hashtables io io.streams.string kernel math
math.vectors math.functions math.parser namespaces sequences math.vectors math.functions math.parser namespaces sequences
strings tuples system debugger combinators vocabs.loader strings tuples system debugger combinators vocabs.loader
calendar.backend structs alien.c-types unix ; calendar.backend structs alien.c-types ;
IN: calendar IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ; TUPLE: timestamp year month day hour minute second gmt-offset ;
@ -158,7 +158,7 @@ M: integer +minute ( timestamp n -- timestamp )
over timestamp-minute + 60 /rem pick over timestamp-minute + 60 /rem pick
set-timestamp-minute +hour ; set-timestamp-minute +hour ;
M: real +minute ( timestamp n -- timestamp ) M: real +minute ( timestamp n -- timestamp )
float>whole-part rot swap 60 * +second swap +minute ; float>whole-part rot swap 60 * +second swap +minute ;
M: number +second ( timestamp n -- timestamp ) M: number +second ( timestamp n -- timestamp )
over timestamp-second + 60 /rem >r >bignum r> over timestamp-second + 60 /rem >r >bignum r>
@ -217,32 +217,22 @@ M: timestamp <=> ( ts1 ts2 -- n )
1970 1 1 0 0 0 0 <timestamp> ; 1970 1 1 0 0 0 0 <timestamp> ;
: unix-time>timestamp ( n -- timestamp ) : unix-time>timestamp ( n -- timestamp )
>r unix-1970 r> seconds +dt ; >r unix-1970 r> seconds +dt ;
: timestamp>unix-time ( timestamp -- n ) : timestamp>unix-time ( timestamp -- n )
unix-1970 timestamp- >bignum ; unix-1970 timestamp- >bignum ;
: timestamp>timeval ( timestamp -- timeval ) : timestamp>timeval ( timestamp -- timeval )
timestamp>unix-time 1000 * make-timeval ; timestamp>unix-time 1000 * make-timeval ;
: timeval>timestamp ( timeval -- timestamp ) : timeval>timestamp ( timeval -- timestamp )
[ timeval-sec ] keep [ timeval-sec ] keep
timeval-usec 1000000 / + unix-time>timestamp ; timeval-usec 1000000 / + unix-time>timestamp ;
: timestamp>timespec ( timestamp -- timespec )
timestamp>unix-time "timespec" <c-object>
[ set-timespec-sec ] keep ;
: timespec>timestamp ( timespec -- timestamp )
[ timespec-sec ] keep
timespec-nsec 1000000000 / +
unix-time>timestamp ;
: gmt ( -- timestamp ) : gmt ( -- timestamp )
#! GMT time, right now #! GMT time, right now
unix-1970 millis 1000 /f seconds +dt ; unix-1970 millis 1000 /f seconds +dt ;
: now ( -- timestamp ) gmt >local-time ; : now ( -- timestamp ) gmt >local-time ;
: before ( dt -- -dt ) tuple-slots [ neg ] map array>dt ; : before ( dt -- -dt ) tuple-slots [ neg ] map array>dt ;
@ -278,7 +268,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
[ timestamp-year leap-year? ] keep [ timestamp-year leap-year? ] keep
[ >date< 3array ] keep timestamp-year 3 1 3array <=> [ >date< 3array ] keep timestamp-year 3 1 3array <=>
0 >= and 1 0 ? 0 >= and 1 0 ?
] keep ] keep
[ timestamp-month day-counts swap head-slice sum + ] keep [ timestamp-month day-counts swap head-slice sum + ] keep
timestamp-day + ; timestamp-day + ;
@ -370,35 +360,18 @@ M: timestamp <=> ( ts1 ts2 -- n )
: day-offset ( timestamp m -- timestamp n ) : day-offset ( timestamp m -- timestamp n )
over day-of-week - ; inline over day-of-week - ; inline
: day-this-week ( timestamp n -- timestamp ) : day-this-week ( timestamp n -- timestamp )
day-offset days +dt ; day-offset days +dt ;
: sunday ( timestamp -- timestamp ) 0 day-this-week ; : sunday ( timestamp -- timestamp ) 0 day-this-week ;
: monday ( timestamp -- timestamp ) 1 day-this-week ; : monday ( timestamp -- timestamp ) 1 day-this-week ;
: tuesday ( timestamp -- timestamp ) 2 day-this-week ; : tuesday ( timestamp -- timestamp ) 2 day-this-week ;
: wednesday ( timestamp -- timestamp ) 3 day-this-week ; : wednesday ( timestamp -- timestamp ) 3 day-this-week ;
: thursday ( timestamp -- timestamp ) 4 day-this-week ; : thursday ( timestamp -- timestamp ) 4 day-this-week ;
: friday ( timestamp -- timestamp ) 5 day-this-week ; : friday ( timestamp -- timestamp ) 5 day-this-week ;
: saturday ( timestamp -- timestamp ) 6 day-this-week ; : saturday ( timestamp -- timestamp ) 6 day-this-week ;
: beginning-of-day ( timestamp -- new-timestamp )
clone dup >r 0 0 0 r>
{ set-timestamp-hour set-timestamp-minute set-timestamp-second }
set-slots ; inline
: beginning-of-month ( timestamp -- new-timestamp )
clone dup beginning-of-day dup >r 1 r> { set-timestamp-day } set-slots ;
: beginning-of-week ( timestamp -- new-timestamp )
clone dup sunday beginning-of-day ;
: beginning-of-year ( timestamp -- new-timestamp )
clone dup beginning-of-month dup >r 1 r> { set-timestamp-month } set-slots ;
: seconds-since-midnight ( timestamp -- x )
dup beginning-of-day timestamp- ;
{ {
{ [ unix? ] [ "calendar.unix" ] } { [ unix? ] [ "calendar.unix" ] }
{ [ windows? ] [ "calendar.windows" ] } { [ windows? ] [ "calendar.windows" ] }