diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index a03ebeffcb..804c2b5fb1 100755 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,14 +1,14 @@ USING: arrays calendar kernel math sequences tools.test -continuations system io.streams.string ; +continuations system ; -[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with -[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 12 32 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 2 30 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2003 2 29 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 -2 9 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 12 0 0 0 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 12 1 24 0 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 12 1 23 60 0 0 ] [ "invalid timestamp" = ] must-fail-with +! [ 2004 12 1 23 59 60 0 ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 1900 leap-year? ] unit-test [ t ] [ 1904 leap-year? ] unit-test @@ -16,164 +16,144 @@ continuations system io.streams.string ; [ f ] [ 2001 leap-year? ] unit-test [ f ] [ 2006 leap-year? ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 1 seconds +dt - 2006 10 10 0 0 1 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 100 seconds +dt - 2006 10 10 0 1 40 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 seconds +dt - 2006 10 9 23 58 20 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 86400 seconds +dt - 2006 10 11 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 1 seconds time+ + 2006 10 10 0 0 1 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 100 seconds time+ + 2006 10 10 0 1 40 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -100 seconds time+ + 2006 10 9 23 58 20 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 86400 seconds time+ + 2006 10 11 0 0 0 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10 minutes +dt - 2006 10 10 0 10 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10.5 minutes +dt - 2006 10 10 0 10 30 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 3/4 minutes +dt - 2006 10 10 0 0 45 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -3/4 minutes +dt - 2006 10 9 23 59 15 0 make-timestamp = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 10 minutes time+ + 2006 10 10 0 10 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 10.5 minutes time+ + 2006 10 10 0 10 30 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 3/4 minutes time+ + 2006 10 10 0 0 45 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -3/4 minutes time+ + 2006 10 9 23 59 15 0 = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 7200 minutes +dt - 2006 10 15 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -10 minutes +dt - 2006 10 9 23 50 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 minutes +dt - 2006 10 9 22 20 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 7200 minutes time+ + 2006 10 15 0 0 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -10 minutes time+ + 2006 10 9 23 50 0 0 = ] unit-test +[ t ] [ 2006 10 10 0 0 0 0 -100 minutes time+ + 2006 10 9 22 20 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 hours +dt - 2006 1 1 1 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 hours +dt - 2006 1 2 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 hours +dt - 2005 12 31 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 hours +dt - 2006 1 1 12 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 72 hours +dt - 2006 1 4 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 hours time+ + 2006 1 1 1 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 24 hours time+ + 2006 1 2 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -24 hours time+ + 2005 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 12 hours time+ + 2006 1 1 12 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 72 hours time+ + 2006 1 4 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 days +dt - 2006 1 2 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 days +dt - 2005 12 31 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 365 days +dt - 2007 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -365 days +dt - 2005 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 365 days +dt - 2004 12 31 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 366 days +dt - 2005 1 1 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 days time+ + 2006 1 2 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 days time+ + 2005 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 365 days time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -365 days time+ + 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 365 days time+ + 2004 12 31 0 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 366 days time+ + 2005 1 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 11 months +dt - 2006 12 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 months +dt - 2007 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 months +dt - 2008 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 13 months +dt - 2007 2 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 months +dt - 2006 2 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 months +dt - 2006 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 months +dt - 2005 12 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -2 months +dt - 2005 11 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -13 months +dt - 2004 12 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 months +dt - 2004 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 make-timestamp 12 months +dt - 2005 3 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 2 29 0 0 0 0 make-timestamp -12 months +dt - 2003 3 1 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 11 months time+ + 2006 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 12 months time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 24 months time+ + 2008 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 13 months time+ + 2007 2 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 months time+ + 2006 2 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 0 months time+ + 2006 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 months time+ + 2005 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -2 months time+ + 2005 11 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -13 months time+ + 2004 12 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -24 months time+ + 2004 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 2 29 0 0 0 0 12 months time+ + 2005 3 1 0 0 0 0 = ] unit-test +[ t ] [ 2004 2 29 0 0 0 0 -12 months time+ + 2003 3 1 0 0 0 0 = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 years +dt - 2006 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 years +dt - 2007 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 years +dt - 2005 1 1 0 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -100 years +dt - 1906 1 1 0 0 0 0 make-timestamp = ] unit-test -! [ t ] [ 2004 2 29 0 0 0 0 make-timestamp -1 years +dt - ! 2003 2 28 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 0 years time+ + 2006 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 1 years time+ + 2007 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -1 years time+ + 2005 1 1 0 0 0 0 = ] unit-test +[ t ] [ 2006 1 1 0 0 0 0 -100 years time+ + 1906 1 1 0 0 0 0 = ] unit-test +! [ t ] [ 2004 2 29 0 0 0 0 -1 years time+ +! 2003 2 28 0 0 0 0 = ] unit-test -[ 5 ] [ 2006 7 14 0 0 0 0 make-timestamp day-of-week ] unit-test +[ 5 ] [ 2006 7 14 0 0 0 0 day-of-week ] unit-test -[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 make-timestamp ] 3keep 0 0 0 0 make-timestamp = ] unit-test +[ t ] [ 2006 7 14 [ julian-day-number julian-day-number>date 0 0 0 0 ] 3keep 0 0 0 0 = ] unit-test -[ 1 ] [ 2006 1 1 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 60 ] [ 2004 2 29 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 61 ] [ 2004 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 366 ] [ 2004 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 365 ] [ 2003 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test -[ 60 ] [ 2003 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test +[ 1 ] [ 2006 1 1 0 0 0 0 day-of-year ] unit-test +[ 60 ] [ 2004 2 29 0 0 0 0 day-of-year ] unit-test +[ 61 ] [ 2004 3 1 0 0 0 0 day-of-year ] unit-test +[ 366 ] [ 2004 12 31 0 0 0 0 day-of-year ] unit-test +[ 365 ] [ 2003 12 31 0 0 0 0 day-of-year ] unit-test +[ 60 ] [ 2003 3 1 0 0 0 0 day-of-year ] unit-test -[ t ] [ 2004 12 31 0 0 0 0 make-timestamp dup = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 10 seconds 5 years +dts +dt - 2009 1 1 0 0 10 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 0 0 0 0 make-timestamp -10 seconds -5 years +dts +dt - 1998 12 31 23 59 50 0 make-timestamp = ] unit-test +[ t ] [ 2004 12 31 0 0 0 0 dup = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 10 seconds 5 years time+ time+ + 2009 1 1 0 0 10 0 = ] unit-test +[ t ] [ 2004 1 1 0 0 0 0 -10 seconds -5 years time+ time+ + 1998 12 31 23 59 50 0 = ] unit-test -[ t ] [ 2004 1 1 23 0 0 12 make-timestamp 0 convert-timezone - 2004 1 1 11 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 5 0 0 -11 make-timestamp 0 convert-timezone - 2004 1 1 16 0 0 0 make-timestamp = ] unit-test -[ t ] [ 2004 1 1 23 0 0 9.5 make-timestamp 0 convert-timezone - 2004 1 1 13 30 0 0 make-timestamp = ] unit-test +[ t ] [ 2004 1 1 23 0 0 12 0 convert-timezone + 2004 1 1 11 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 5 0 0 -11 0 convert-timezone + 2004 1 1 16 0 0 0 = ] unit-test +[ t ] [ 2004 1 1 23 0 0 9+1/2 0 convert-timezone + 2004 1 1 13 30 0 0 = ] unit-test -[ 0 ] [ 2004 1 1 13 30 0 0 make-timestamp - 2004 1 1 12 30 0 -1 make-timestamp <=> ] unit-test +[ 0 ] [ 2004 1 1 13 30 0 0 + 2004 1 1 12 30 0 -1 <=> ] unit-test -[ 1 ] [ 2004 1 1 13 30 0 0 make-timestamp - 2004 1 1 12 30 0 0 make-timestamp <=> ] unit-test +[ 1 ] [ 2004 1 1 13 30 0 0 + 2004 1 1 12 30 0 0 <=> ] unit-test -[ -1 ] [ 2004 1 1 12 30 0 0 make-timestamp - 2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test +[ -1 ] [ 2004 1 1 12 30 0 0 + 2004 1 1 13 30 0 0 <=> ] unit-test -[ 1 ] [ 2005 1 1 12 30 0 0 make-timestamp - 2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test +[ 1 ] [ 2005 1 1 12 30 0 0 + 2004 1 1 13 30 0 0 <=> ] unit-test -[ t ] [ now timestamp>unix-time millis 1000 /f - 10 < ] unit-test -[ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test -[ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test -[ t ] [ 123456789123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test +[ t ] [ now timestamp>millis millis - 1000 < ] unit-test +[ t ] [ 0 millis>timestamp unix-1970 = ] unit-test +[ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test +[ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test -[ 0 ] [ - "Z" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +: checktime+ now dup clone [ rot time+ drop ] keep = ; -[ 1 ] [ - "+01" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 seconds checktime+ ] unit-test -[ -1 ] [ - "-01" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 minutes checktime+ ] unit-test -[ -1-1/2 ] [ - "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 hours checktime+ ] unit-test -[ 1+1/2 ] [ - "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader -] unit-test +[ t ] [ 5 days checktime+ ] unit-test -: check+dt now dup clone [ rot +dt drop ] keep = ; +[ t ] [ 5 weeks checktime+ ] unit-test -[ t ] [ 5 seconds check+dt ] unit-test +[ t ] [ 5 months checktime+ ] unit-test -[ t ] [ 5 minutes check+dt ] unit-test - -[ t ] [ 5 hours check+dt ] unit-test - -[ t ] [ 5 days check+dt ] unit-test - -[ t ] [ 5 weeks check+dt ] unit-test - -[ t ] [ 5 months check+dt ] unit-test - -[ t ] [ 5 years check+dt ] unit-test +[ t ] [ 5 years checktime+ ] unit-test diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index d834698d08..7bd655b002 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -1,20 +1,21 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays hashtables io io.streams.string kernel math -math.vectors math.functions math.parser namespaces sequences -strings tuples system debugger combinators vocabs.loader -calendar.backend structs alien.c-types math.vectors -shuffle threads ; +USING: arrays kernel math math.functions namespaces sequences +strings tuples system vocabs.loader calendar.backend threads +new-slots accessors combinators ; IN: calendar TUPLE: timestamp year month day hour minute second gmt-offset ; C: timestamp -TUPLE: dt year month day hour minute second ; +: ( year month day -- timestamp ) + 0 0 0 gmt-offset ; -C:
dt +TUPLE: duration year month day hour minute second ; + +C: duration : month-names { @@ -40,6 +41,8 @@ C:
dt #! length of average month in days 30.41666666666667 ; + + : julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 @@ -74,38 +79,31 @@ SYMBOL: m e get 153 m get * 2 + 5 /i - 1+ ] with-scope ; -: set-date ( year month day timestamp -- ) - [ set-timestamp-day ] keep - [ set-timestamp-month ] keep - set-timestamp-year ; - -: set-time ( hour minute second timestamp -- ) - [ set-timestamp-second ] keep - [ set-timestamp-minute ] keep - set-timestamp-hour ; - : >date< ( timestamp -- year month day ) - [ timestamp-year ] keep - [ timestamp-month ] keep - timestamp-day ; + { year>> month>> day>> } get-slots ; : >time< ( timestamp -- hour minute second ) - [ timestamp-hour ] keep - [ timestamp-minute ] keep - timestamp-second ; + { hour>> minute>> second>> } get-slots ; -: zero-dt ( --
) 0 0 0 0 0 0
; -: years ( n -- dt ) zero-dt [ set-dt-year ] keep ; -: months ( n -- dt ) zero-dt [ set-dt-month ] keep ; -: days ( n -- dt ) zero-dt [ set-dt-day ] keep ; +: instant ( -- dt ) 0 0 0 0 0 0 ; +: years ( n -- dt ) instant swap >>year ; +: months ( n -- dt ) instant swap >>month ; +: days ( n -- dt ) instant swap >>day ; : weeks ( n -- dt ) 7 * days ; -: hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ; -: minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ; -: seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ; -: milliseconds ( n -- dt ) 1000 /f seconds ; +: hours ( n -- dt ) instant swap >>hour ; +: minutes ( n -- dt ) instant swap >>minute ; +: seconds ( n -- dt ) instant swap >>second ; +: milliseconds ( n -- dt ) 1000 / seconds ; -: julian-day-number>timestamp ( n -- timestamp ) - julian-day-number>date 0 0 0 0 ; +GENERIC: leap-year? ( obj -- ? ) + +M: integer leap-year? ( year -- ? ) + dup 100 mod zero? 400 4 ? mod zero? ; + +M: timestamp leap-year? ( timestamp -- ? ) + year>> leap-year? ; + +integer ] 2keep rem ; + [ / floor >integer ] 2keep rem ; : float>whole-part ( float -- int float ) [ floor >integer ] keep over - ; -GENERIC: leap-year? ( obj -- ? ) -M: integer leap-year? ( year -- ? ) - dup 100 mod zero? 400 4 ? mod zero? ; - -M: timestamp leap-year? ( timestamp -- ? ) - timestamp-year leap-year? ; - : adjust-leap-year ( timestamp -- timestamp ) - dup >date< 29 = swap 2 = and swap leap-year? not and [ - dup >r timestamp-year 3 1 r> [ set-date ] keep - ] when ; + dup day>> 29 = over month>> 2 = pick leap-year? not and and + [ 3 >>month 1 >>day ] when ; + +: unless-zero >r dup zero? [ drop ] r> if ; inline M: integer +year ( timestamp n -- timestamp ) - over timestamp-year + swap [ set-timestamp-year ] keep - adjust-leap-year ; + [ [ + ] curry change-year adjust-leap-year ] unless-zero ; + M: real +year ( timestamp n -- timestamp ) - float>whole-part rot swap 365.2425 * +day swap +year ; + [ float>whole-part swapd 365.2425 * +day swap +year ] unless-zero ; + +: months/years ( n -- months years ) + 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline M: integer +month ( timestamp n -- timestamp ) - over timestamp-month + 12 /rem - dup zero? [ drop 12 >r 1- r> ] when pick set-timestamp-month - +year ; + [ over month>> + months/years >r >>month r> +year ] unless-zero ; + M: real +month ( timestamp n -- timestamp ) - float>whole-part rot swap average-month * +day swap +month ; + [ float>whole-part swapd average-month * +day swap +month ] unless-zero ; M: integer +day ( timestamp n -- timestamp ) - swap [ - >date< julian-day-number + julian-day-number>timestamp - ] keep swap >r >time< r> [ set-time ] keep ; + [ + over >date< julian-day-number + julian-day-number>date + >r >r >>year r> >>month r> >>day + ] unless-zero ; + M: real +day ( timestamp n -- timestamp ) - float>whole-part rot swap 24 * +hour swap +day ; + [ float>whole-part swapd 24 * +hour swap +day ] unless-zero ; + +: hours/days ( n -- hours days ) + 24 /rem swap ; M: integer +hour ( timestamp n -- timestamp ) - over timestamp-hour + 24 /rem pick set-timestamp-hour - +day ; + [ over hour>> + hours/days >r >>hour r> +day ] unless-zero ; + M: real +hour ( timestamp n -- timestamp ) - float>whole-part rot swap 60 * +minute swap +hour ; + float>whole-part swapd 60 * +minute swap +hour ; + +: minutes/hours ( n -- minutes hours ) + 60 /rem swap ; M: integer +minute ( timestamp n -- timestamp ) - over timestamp-minute + 60 /rem pick - set-timestamp-minute +hour ; + [ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ; + M: real +minute ( timestamp n -- timestamp ) - float>whole-part rot swap 60 * +second swap +minute ; + [ float>whole-part swapd 60 * +second swap +minute ] unless-zero ; + +: seconds/minutes ( n -- seconds minutes ) + 60 /rem swap >integer ; M: number +second ( timestamp n -- timestamp ) - over timestamp-second + 60 /rem >r >integer r> - pick set-timestamp-second +minute ; + [ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ; -: +dt ( timestamp dt -- timestamp ) - dupd - [ dt-second +second ] keep - [ dt-minute +minute ] keep - [ dt-hour +hour ] keep - [ dt-day +day ] keep - [ dt-month +month ] keep - dt-year +year - swap timestamp-gmt-offset over set-timestamp-gmt-offset ; +: (time+) + [ second>> +second ] keep + [ minute>> +minute ] keep + [ hour>> +hour ] keep + [ day>> +day ] keep + [ month>> +month ] keep + [ year>> +year ] keep ; inline -: make-timestamp ( year month day hour minute second gmt-offset -- timestamp ) - [ 0 seconds +dt ] keep - [ = [ "invalid timestamp" throw ] unless ] keep ; +: +slots [ 2apply + ] curry 2keep ; inline -: make-date ( year month day -- timestamp ) - 0 0 0 gmt-offset make-timestamp ; +PRIVATE> -: array>dt ( vec -- dt ) { dt f } swap append >tuple ; -: +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ; +GENERIC# time+ 1 ( time dt -- time ) + +M: timestamp time+ + >r clone r> (time+) drop ; + +M: duration time+ + [ year>> ] +slots + [ month>> ] +slots + [ day>> ] +slots + [ hour>> ] +slots + [ minute>> ] +slots + [ second>> ] +slots + 2drop ; : dt>years ( dt -- x ) #! Uses average month/year length since dt loses calendar #! data - tuple-slots - { 1 12 365.2425 8765.82 525949.2 31556952.0 } - v/ sum ; + 0 swap + [ year>> + ] keep + [ month>> 12 / + ] keep + [ day>> 365.2425 / + ] keep + [ hour>> 8765.82 / + ] keep + [ minute>> 525949.2 / + ] keep + second>> 31556952.0 / + ; + +M: duration <=> [ dt>years ] compare ; : dt>months ( dt -- x ) dt>years 12 * ; : dt>days ( dt -- x ) dt>years 365.2425 * ; @@ -204,8 +220,9 @@ M: number +second ( timestamp n -- timestamp ) : dt>milliseconds ( dt -- x ) dt>years 31556952000 * ; : convert-timezone ( timestamp n -- timestamp ) - [ over timestamp-gmt-offset - hours +dt ] keep - over set-timestamp-gmt-offset ; + over gmt-offset>> over = [ drop ] [ + [ over gmt-offset>> - hours time+ ] keep >>gmt-offset + ] if ; : >local-time ( timestamp -- timestamp ) gmt-offset convert-timezone ; @@ -216,42 +233,37 @@ M: number +second ( timestamp n -- timestamp ) M: timestamp <=> ( ts1 ts2 -- n ) [ >gmt tuple-slots ] compare ; -: timestamp- ( timestamp timestamp -- seconds ) +: time- ( timestamp timestamp -- seconds ) #! Exact calendar-time difference [ >gmt ] 2apply [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; : unix-1970 ( -- timestamp ) - 1970 1 1 0 0 0 0 ; + 1970 1 1 0 0 0 0 ; foldable : millis>timestamp ( n -- timestamp ) - >r unix-1970 r> 1000 /f seconds +dt ; + >r unix-1970 r> milliseconds time+ ; : timestamp>millis ( timestamp -- n ) - unix-1970 timestamp- 1000 * >integer ; - -: unix-time>timestamp ( n -- timestamp ) - >r unix-1970 r> seconds +dt ; - -: timestamp>unix-time ( timestamp -- n ) - unix-1970 timestamp- >integer ; - -: timestamp>timeval ( timestamp -- timeval ) - timestamp>unix-time 1000 * make-timeval ; - -: timeval>timestamp ( timeval -- timestamp ) - [ timeval-sec ] keep - timeval-usec 1000000 / + unix-time>timestamp ; - + unix-1970 time- 1000 * >integer ; : gmt ( -- timestamp ) #! GMT time, right now - unix-1970 millis 1000 /f seconds +dt ; + unix-1970 millis milliseconds time+ ; : now ( -- timestamp ) gmt >local-time ; -: before ( dt -- -dt ) tuple-slots vneg array>dt ; -: from-now ( dt -- timestamp ) now swap +dt ; + +: before ( dt -- -dt ) + [ year>> neg ] keep + [ month>> neg ] keep + [ day>> neg ] keep + [ hour>> neg ] keep + [ minute>> neg ] keep + [ second>> neg ] keep + ; + +: from-now ( dt -- timestamp ) now swap time+ ; : ago ( dt -- timestamp ) before from-now ; : day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; @@ -268,7 +280,7 @@ M: timestamp <=> ( ts1 ts2 -- n ) GENERIC: days-in-year ( obj -- n ) M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ; -M: timestamp days-in-year ( timestamp -- n ) timestamp-year days-in-year ; +M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; GENERIC: days-in-month ( obj -- n ) @@ -280,7 +292,7 @@ M: array days-in-month ( obj -- n ) ] if ; M: timestamp days-in-month ( timestamp -- n ) - { timestamp-year timestamp-month } get-slots 2array days-in-month ; + >date< drop 2array days-in-month ; GENERIC: day-of-week ( obj -- n ) @@ -297,156 +309,20 @@ M: array day-of-year ( array -- n ) 3dup day-counts rot head-slice sum + swap leap-year? [ -roll - pick 3 1 make-date >r make-date r> - <=> 0 >= [ 1+ ] when + pick 3 1 >r r> + after=? [ 1+ ] when ] [ - 3nip + >r 3drop r> ] if ; M: timestamp day-of-year ( timestamp -- n ) - { timestamp-year timestamp-month timestamp-day } get-slots - 3array day-of-year ; - -GENERIC: day. ( obj -- ) - -M: integer day. ( n -- ) - number>string dup length 2 < [ bl ] when write ; - -M: timestamp day. ( timestamp -- ) - timestamp-day day. ; - -GENERIC: month. ( obj -- ) - -M: array month. ( pair -- ) - first2 - [ month-names nth write bl number>string print ] 2keep - [ 1 zeller-congruence ] 2keep - 2array days-in-month day-abbreviations2 " " join print - over " " concat write - [ - [ 1+ day. ] keep - 1+ + 7 mod zero? [ nl ] [ bl ] if - ] with each nl ; - -M: timestamp month. ( timestamp -- ) - { timestamp-year timestamp-month } get-slots 2array month. ; - -GENERIC: year. ( obj -- ) - -M: integer year. ( n -- ) - 12 [ 1+ 2array month. nl ] with each ; - -M: timestamp year. ( timestamp -- ) - timestamp-year year. ; - -: pad-00 number>string 2 CHAR: 0 pad-left ; - -: write-00 pad-00 write ; - -: (timestamp>string) ( timestamp -- ) - dup day-of-week day-abbreviations3 nth write ", " write - dup timestamp-day number>string write bl - dup timestamp-month month-abbreviations nth write bl - dup timestamp-year number>string write bl - dup timestamp-hour write-00 ":" write - dup timestamp-minute write-00 ":" write - timestamp-second >fixnum write-00 ; - -: timestamp>string ( timestamp -- str ) - [ (timestamp>string) ] with-string-writer ; - -: (write-gmt-offset) ( ratio -- ) - 1 /mod swap write-00 60 * write-00 ; - -: write-gmt-offset ( gmt-offset -- ) - { - { [ dup zero? ] [ drop "GMT" write ] } - { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } - { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } - } cond ; - -: timestamp>rfc822-string ( timestamp -- str ) - #! RFC822 timestamp format - #! Example: Tue, 15 Nov 1994 08:12:31 +0200 - [ - dup (timestamp>string) - " " write - timestamp-gmt-offset write-gmt-offset - ] with-string-writer ; - -: timestamp>http-string ( timestamp -- str ) - #! http timestamp format - #! Example: Tue, 15 Nov 1994 08:12:31 GMT - >gmt timestamp>rfc822-string ; - -: write-rfc3339-gmt-offset ( n -- ) - dup zero? [ drop "Z" write ] [ - dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if - 60 * 60 /mod swap write-00 CHAR: : write1 write-00 - ] if ; - -: (timestamp>rfc3339) ( timestamp -- ) - dup timestamp-year number>string write CHAR: - write1 - dup timestamp-month write-00 CHAR: - write1 - dup timestamp-day write-00 CHAR: T write1 - dup timestamp-hour write-00 CHAR: : write1 - dup timestamp-minute write-00 CHAR: : write1 - dup timestamp-second >fixnum write-00 - timestamp-gmt-offset write-rfc3339-gmt-offset ; - -: timestamp>rfc3339 ( timestamp -- str ) - [ (timestamp>rfc3339) ] with-string-writer ; - -: expect ( str -- ) - read1 swap member? [ "Parse error" throw ] unless ; - -: read-00 2 read string>number ; - -: read-0000 4 read string>number ; - -: read-rfc3339-gmt-offset ( -- n ) - read1 dup CHAR: Z = [ drop 0 ] [ - { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case - read-00 - read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case - 60 / + * - ] if ; - -: (rfc3339>timestamp) ( -- timestamp ) - read-0000 ! year - "-" expect - read-00 ! month - "-" expect - read-00 ! day - "Tt" expect - read-00 ! hour - ":" expect - read-00 ! minute - ":" expect - read-00 ! second - read-rfc3339-gmt-offset ! timezone - ; - -: rfc3339>timestamp ( str -- timestamp ) - [ (rfc3339>timestamp) ] with-string-reader ; - -: file-time-string ( timestamp -- string ) - [ - [ timestamp-month month-abbreviations nth write ] keep bl - [ timestamp-day number>string 2 32 pad-left write ] keep bl - dup now [ timestamp-year ] 2apply = [ - [ timestamp-hour write-00 ] keep ":" write - timestamp-minute write-00 - ] [ - timestamp-year number>string 5 32 pad-left write - ] if - ] with-string-writer ; + >date< 3array day-of-year ; : day-offset ( timestamp m -- timestamp n ) over day-of-week - ; inline : day-this-week ( timestamp n -- timestamp ) - day-offset days +dt ; + day-offset days time+ ; : sunday ( timestamp -- timestamp ) 0 day-this-week ; : monday ( timestamp -- timestamp ) 1 day-this-week ; @@ -457,25 +333,26 @@ M: timestamp year. ( timestamp -- ) : 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 + clone + 0 >>hour + 0 >>minute + 0 >>second ; inline : beginning-of-month ( timestamp -- new-timestamp ) - beginning-of-day 1 over set-timestamp-day ; + beginning-of-day 1 >>day ; : beginning-of-week ( timestamp -- new-timestamp ) beginning-of-day sunday ; : beginning-of-year ( timestamp -- new-timestamp ) - beginning-of-month 1 over set-timestamp-month ; + beginning-of-month 1 >>month ; : seconds-since-midnight ( timestamp -- x ) - dup beginning-of-day timestamp- ; + dup beginning-of-day time- ; M: timestamp sleep-until timestamp>millis sleep-until ; -M: dt sleep from-now sleep-until ; +M: duration sleep from-now sleep-until ; { { [ unix? ] [ "calendar.unix" ] } diff --git a/extra/calendar/format/format-tests.factor b/extra/calendar/format/format-tests.factor new file mode 100755 index 0000000000..1f23d4f841 --- /dev/null +++ b/extra/calendar/format/format-tests.factor @@ -0,0 +1,22 @@ +IN: temporary +USING: calendar.format tools.test io.streams.string ; + +[ 0 ] [ + "Z" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ 1 ] [ + "+01" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ -1 ] [ + "-01" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ -1-1/2 ] [ + "-01:30" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test + +[ 1+1/2 ] [ + "+01:30" [ read-rfc3339-gmt-offset ] with-string-reader +] unit-test diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor new file mode 100755 index 0000000000..ea8d387e01 --- /dev/null +++ b/extra/calendar/format/format.factor @@ -0,0 +1,138 @@ +IN: calendar.format +USING: math math.parser kernel sequences io calendar +accessors arrays io.streams.string combinators ; + +GENERIC: day. ( obj -- ) + +M: integer day. ( n -- ) + number>string dup length 2 < [ bl ] when write ; + +M: timestamp day. ( timestamp -- ) + day>> day. ; + +GENERIC: month. ( obj -- ) + +M: array month. ( pair -- ) + first2 + [ month-names nth write bl number>string print ] 2keep + [ 1 zeller-congruence ] 2keep + 2array days-in-month day-abbreviations2 " " join print + over " " concat write + [ + [ 1+ day. ] keep + 1+ + 7 mod zero? [ nl ] [ bl ] if + ] with each nl ; + +M: timestamp month. ( timestamp -- ) + { year>> month>> } get-slots 2array month. ; + +GENERIC: year. ( obj -- ) + +M: integer year. ( n -- ) + 12 [ 1+ 2array month. nl ] with each ; + +M: timestamp year. ( timestamp -- ) + year>> year. ; + +: pad-00 number>string 2 CHAR: 0 pad-left ; + +: write-00 pad-00 write ; + +: (timestamp>string) ( timestamp -- ) + dup day-of-week day-abbreviations3 nth write ", " write + dup day>> number>string write bl + dup month>> month-abbreviations nth write bl + dup year>> number>string write bl + dup hour>> write-00 ":" write + dup minute>> write-00 ":" write + second>> >integer write-00 ; + +: timestamp>string ( timestamp -- str ) + [ (timestamp>string) ] with-string-writer ; + +: (write-gmt-offset) ( ratio -- ) + 1 /mod swap write-00 60 * write-00 ; + +: write-gmt-offset ( gmt-offset -- ) + { + { [ dup zero? ] [ drop "GMT" write ] } + { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } + { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } + } cond ; + +: timestamp>rfc822-string ( timestamp -- str ) + #! RFC822 timestamp format + #! Example: Tue, 15 Nov 1994 08:12:31 +0200 + [ + dup (timestamp>string) + " " write + gmt-offset>> write-gmt-offset + ] with-string-writer ; + +: timestamp>http-string ( timestamp -- str ) + #! http timestamp format + #! Example: Tue, 15 Nov 1994 08:12:31 GMT + >gmt timestamp>rfc822-string ; + +: write-rfc3339-gmt-offset ( n -- ) + dup zero? [ drop "Z" write ] [ + dup 0 < [ CHAR: - write1 neg ] [ CHAR: + write1 ] if + 60 * 60 /mod swap write-00 CHAR: : write1 write-00 + ] if ; + +: (timestamp>rfc3339) ( timestamp -- ) + dup year>> number>string write CHAR: - write1 + dup month>> write-00 CHAR: - write1 + dup day>> write-00 CHAR: T write1 + dup hour>> write-00 CHAR: : write1 + dup minute>> write-00 CHAR: : write1 + dup second>> >fixnum write-00 + gmt-offset>> write-rfc3339-gmt-offset ; + +: timestamp>rfc3339 ( timestamp -- str ) + [ (timestamp>rfc3339) ] with-string-writer ; + +: expect ( str -- ) + read1 swap member? [ "Parse error" throw ] unless ; + +: read-00 2 read string>number ; + +: read-0000 4 read string>number ; + +: read-rfc3339-gmt-offset ( -- n ) + read1 dup CHAR: Z = [ drop 0 ] [ + { { CHAR: + [ 1 ] } { CHAR: - [ -1 ] } } case + read-00 + read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case + 60 / + * + ] if ; + +: (rfc3339>timestamp) ( -- timestamp ) + read-0000 ! year + "-" expect + read-00 ! month + "-" expect + read-00 ! day + "Tt" expect + read-00 ! hour + ":" expect + read-00 ! minute + ":" expect + read-00 ! second + read-rfc3339-gmt-offset ! timezone + ; + +: rfc3339>timestamp ( str -- timestamp ) + [ (rfc3339>timestamp) ] with-string-reader ; + +: file-time-string ( timestamp -- string ) + [ + [ month>> month-abbreviations nth write ] keep bl + [ day>> number>string 2 32 pad-left write ] keep bl + dup now [ year>> ] 2apply = [ + [ hour>> write-00 ] keep ":" write + minute>> write-00 + ] [ + year>> number>string 5 32 pad-left write + ] if + ] with-string-writer ; diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor index 82bc5d1316..898ae35f1a 100755 --- a/extra/webapps/file/file.factor +++ b/extra/webapps/file/file.factor @@ -11,6 +11,9 @@ SYMBOL: doc-root : serving-path ( filename -- filename ) "" or doc-root get swap path+ ; +: unix-time>timestamp ( n -- timestamp ) + >r unix-1970 r> seconds time+ ; + : file-http-date ( filename -- string ) file-modified unix-time>timestamp timestamp>http-string ; diff --git a/extra/windows/time/time-tests.factor b/extra/windows/time/time-tests.factor old mode 100644 new mode 100755 index ed0dcae6f4..dc846a1b04 --- a/extra/windows/time/time-tests.factor +++ b/extra/windows/time/time-tests.factor @@ -2,5 +2,5 @@ USING: calendar calendar.windows kernel tools.test ; [ t ] [ windows-1601 [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test [ t ] [ windows-time [ windows-time>FILETIME FILETIME>windows-time ] keep = ] unit-test -[ t ] [ windows-1601 400 years +dt [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test +[ t ] [ windows-1601 400 years time+ [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-test diff --git a/extra/windows/time/time.factor b/extra/windows/time/time.factor index 3ccb4cfa67..5409edbb75 100755 --- a/extra/windows/time/time.factor +++ b/extra/windows/time/time.factor @@ -15,7 +15,7 @@ IN: windows.time FILETIME-dwHighDateTime >64bit ; : windows-time>timestamp ( n -- timestamp ) - 10000000 /i seconds windows-1601 swap +dt ; + 10000000 /i seconds windows-1601 swap time+ ; : windows-time ( -- n ) "FILETIME" [ GetSystemTimeAsFileTime ] keep