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

Refactor calendar

db4
Slava Pestov 2008-02-26 17:22:48 -06:00
parent 5796a18d59
commit 2acfc8fe38
7 changed files with 423 additions and 403 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

272
extra/calendar/calendar-tests.factor
View File

@ -1,14 +1,14 @@
USING: arrays calendar kernel math sequences tools.test 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 12 32 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with ! [ 2004 2 30 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with ! [ 2003 2 29 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with ! [ 2004 -2 9 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with ! [ 2004 12 0 0 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with ! [ 2004 12 1 24 0 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with ! [ 2004 12 1 23 60 0 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with ! [ 2004 12 1 23 59 60 0 <timestamp> ] [ "invalid timestamp" = ] must-fail-with
[ f ] [ 1900 leap-year? ] unit-test [ f ] [ 1900 leap-year? ] unit-test
[ t ] [ 1904 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 ] [ 2001 leap-year? ] unit-test
[ f ] [ 2006 leap-year? ] unit-test [ f ] [ 2006 leap-year? ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 1 seconds +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 1 seconds time+
2006 10 10 0 0 1 0 make-timestamp = ] unit-test 2006 10 10 0 0 1 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 100 seconds +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 100 seconds time+
2006 10 10 0 1 40 0 make-timestamp = ] unit-test 2006 10 10 0 1 40 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 seconds +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 seconds time+
2006 10 9 23 58 20 0 make-timestamp = ] unit-test 2006 10 9 23 58 20 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 86400 seconds +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 86400 seconds time+
2006 10 11 0 0 0 0 make-timestamp = ] unit-test 2006 10 11 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10 minutes time+
2006 10 10 0 10 0 0 make-timestamp = ] unit-test 2006 10 10 0 10 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10.5 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 10.5 minutes time+
2006 10 10 0 10 30 0 make-timestamp = ] unit-test 2006 10 10 0 10 30 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 3/4 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 3/4 minutes time+
2006 10 10 0 0 45 0 make-timestamp = ] unit-test 2006 10 10 0 0 45 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -3/4 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> -3/4 minutes time+
2006 10 9 23 59 15 0 make-timestamp = ] unit-test 2006 10 9 23 59 15 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 7200 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> 7200 minutes time+
2006 10 15 0 0 0 0 make-timestamp = ] unit-test 2006 10 15 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -10 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> -10 minutes time+
2006 10 9 23 50 0 0 make-timestamp = ] unit-test 2006 10 9 23 50 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp -100 minutes +dt [ t ] [ 2006 10 10 0 0 0 0 <timestamp> -100 minutes time+
2006 10 9 22 20 0 0 make-timestamp = ] unit-test 2006 10 9 22 20 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 hours +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 hours time+
2006 1 1 1 0 0 0 make-timestamp = ] unit-test 2006 1 1 1 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 hours +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 hours time+
2006 1 2 0 0 0 0 make-timestamp = ] unit-test 2006 1 2 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 hours +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 hours time+
2005 12 31 0 0 0 0 make-timestamp = ] unit-test 2005 12 31 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 hours +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 hours time+
2006 1 1 12 0 0 0 make-timestamp = ] unit-test 2006 1 1 12 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 72 hours +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 72 hours time+
2006 1 4 0 0 0 0 make-timestamp = ] unit-test 2006 1 4 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 days +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 days time+
2006 1 2 0 0 0 0 make-timestamp = ] unit-test 2006 1 2 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 days +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 days time+
2005 12 31 0 0 0 0 make-timestamp = ] unit-test 2005 12 31 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 365 days +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 365 days time+
2007 1 1 0 0 0 0 make-timestamp = ] unit-test 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -365 days +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -365 days time+
2005 1 1 0 0 0 0 make-timestamp = ] unit-test 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 365 days +dt [ t ] [ 2004 1 1 0 0 0 0 <timestamp> 365 days time+
2004 12 31 0 0 0 0 make-timestamp = ] unit-test 2004 12 31 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 366 days +dt [ t ] [ 2004 1 1 0 0 0 0 <timestamp> 366 days time+
2005 1 1 0 0 0 0 make-timestamp = ] unit-test 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 11 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 11 months time+
2006 12 1 0 0 0 0 make-timestamp = ] unit-test 2006 12 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 12 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 12 months time+
2007 1 1 0 0 0 0 make-timestamp = ] unit-test 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 24 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 24 months time+
2008 1 1 0 0 0 0 make-timestamp = ] unit-test 2008 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 13 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 13 months time+
2007 2 1 0 0 0 0 make-timestamp = ] unit-test 2007 2 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 months time+
2006 2 1 0 0 0 0 make-timestamp = ] unit-test 2006 2 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 months time+
2006 1 1 0 0 0 0 make-timestamp = ] unit-test 2006 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 months time+
2005 12 1 0 0 0 0 make-timestamp = ] unit-test 2005 12 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -2 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -2 months time+
2005 11 1 0 0 0 0 make-timestamp = ] unit-test 2005 11 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -13 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -13 months time+
2004 12 1 0 0 0 0 make-timestamp = ] unit-test 2004 12 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -24 months +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -24 months time+
2004 1 1 0 0 0 0 make-timestamp = ] unit-test 2004 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 2 29 0 0 0 0 make-timestamp 12 months +dt [ t ] [ 2004 2 29 0 0 0 0 <timestamp> 12 months time+
2005 3 1 0 0 0 0 make-timestamp = ] unit-test 2005 3 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 2 29 0 0 0 0 make-timestamp -12 months +dt [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -12 months time+
2003 3 1 0 0 0 0 make-timestamp = ] unit-test 2003 3 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 years +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 0 years time+
2006 1 1 0 0 0 0 make-timestamp = ] unit-test 2006 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 years +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> 1 years time+
2007 1 1 0 0 0 0 make-timestamp = ] unit-test 2007 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -1 years +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -1 years time+
2005 1 1 0 0 0 0 make-timestamp = ] unit-test 2005 1 1 0 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp -100 years +dt [ t ] [ 2006 1 1 0 0 0 0 <timestamp> -100 years time+
1906 1 1 0 0 0 0 make-timestamp = ] unit-test 1906 1 1 0 0 0 0 <timestamp> = ] unit-test
! [ t ] [ 2004 2 29 0 0 0 0 make-timestamp -1 years +dt ! [ t ] [ 2004 2 29 0 0 0 0 <timestamp> -1 years time+
! 2003 2 28 0 0 0 0 make-timestamp = ] unit-test ! 2003 2 28 0 0 0 0 <timestamp> = ] 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 <timestamp> 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 <timestamp> ] 3keep 0 0 0 0 <timestamp> = ] unit-test
[ 1 ] [ 2006 1 1 0 0 0 0 make-timestamp day-of-year ] unit-test [ 1 ] [ 2006 1 1 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 60 ] [ 2004 2 29 0 0 0 0 make-timestamp day-of-year ] unit-test [ 60 ] [ 2004 2 29 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 61 ] [ 2004 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test [ 61 ] [ 2004 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 366 ] [ 2004 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test [ 366 ] [ 2004 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 365 ] [ 2003 12 31 0 0 0 0 make-timestamp day-of-year ] unit-test [ 365 ] [ 2003 12 31 0 0 0 0 <timestamp> day-of-year ] unit-test
[ 60 ] [ 2003 3 1 0 0 0 0 make-timestamp day-of-year ] unit-test [ 60 ] [ 2003 3 1 0 0 0 0 <timestamp> day-of-year ] unit-test
[ t ] [ 2004 12 31 0 0 0 0 make-timestamp dup = ] unit-test [ t ] [ 2004 12 31 0 0 0 0 <timestamp> dup = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp 10 seconds 5 years +dts +dt [ t ] [ 2004 1 1 0 0 0 0 <timestamp> 10 seconds 5 years time+ time+
2009 1 1 0 0 10 0 make-timestamp = ] unit-test 2009 1 1 0 0 10 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 0 0 0 0 make-timestamp -10 seconds -5 years +dts +dt [ t ] [ 2004 1 1 0 0 0 0 <timestamp> -10 seconds -5 years time+ time+
1998 12 31 23 59 50 0 make-timestamp = ] unit-test 1998 12 31 23 59 50 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 23 0 0 12 make-timestamp 0 convert-timezone [ t ] [ 2004 1 1 23 0 0 12 <timestamp> 0 convert-timezone
2004 1 1 11 0 0 0 make-timestamp = ] unit-test 2004 1 1 11 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 5 0 0 -11 make-timestamp 0 convert-timezone [ t ] [ 2004 1 1 5 0 0 -11 <timestamp> 0 convert-timezone
2004 1 1 16 0 0 0 make-timestamp = ] unit-test 2004 1 1 16 0 0 0 <timestamp> = ] unit-test
[ t ] [ 2004 1 1 23 0 0 9.5 make-timestamp 0 convert-timezone [ t ] [ 2004 1 1 23 0 0 9+1/2 <timestamp> 0 convert-timezone
2004 1 1 13 30 0 0 make-timestamp = ] unit-test 2004 1 1 13 30 0 0 <timestamp> = ] unit-test
[ 0 ] [ 2004 1 1 13 30 0 0 make-timestamp [ 0 ] [ 2004 1 1 13 30 0 0 <timestamp>
2004 1 1 12 30 0 -1 make-timestamp <=> ] unit-test 2004 1 1 12 30 0 -1 <timestamp> <=> ] unit-test
[ 1 ] [ 2004 1 1 13 30 0 0 make-timestamp [ 1 ] [ 2004 1 1 13 30 0 0 <timestamp>
2004 1 1 12 30 0 0 make-timestamp <=> ] unit-test 2004 1 1 12 30 0 0 <timestamp> <=> ] unit-test
[ -1 ] [ 2004 1 1 12 30 0 0 make-timestamp [ -1 ] [ 2004 1 1 12 30 0 0 <timestamp>
2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test 2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
[ 1 ] [ 2005 1 1 12 30 0 0 make-timestamp [ 1 ] [ 2005 1 1 12 30 0 0 <timestamp>
2004 1 1 13 30 0 0 make-timestamp <=> ] unit-test 2004 1 1 13 30 0 0 <timestamp> <=> ] unit-test
[ t ] [ now timestamp>unix-time millis 1000 /f - 10 < ] unit-test [ t ] [ now timestamp>millis millis - 1000 < ] unit-test
[ t ] [ 0 unix-time>timestamp unix-1970 = ] unit-test [ t ] [ 0 millis>timestamp unix-1970 = ] unit-test
[ t ] [ 123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test [ t ] [ 123456789000 [ millis>timestamp timestamp>millis ] keep = ] unit-test
[ t ] [ 123456789123456789 [ unix-time>timestamp timestamp>unix-time ] keep = ] unit-test [ t ] [ 123456789123456 [ millis>timestamp timestamp>millis ] keep = ] unit-test
[ 0 ] [ : checktime+ now dup clone [ rot time+ drop ] keep = ;
"Z" [ read-rfc3339-gmt-offset ] with-string-reader
] unit-test
[ 1 ] [ [ t ] [ 5 seconds checktime+ ] unit-test
"+01" [ read-rfc3339-gmt-offset ] with-string-reader
] unit-test
[ -1 ] [ [ t ] [ 5 minutes checktime+ ] unit-test
"-01" [ read-rfc3339-gmt-offset ] with-string-reader
] unit-test
[ -1-1/2 ] [ [ t ] [ 5 hours checktime+ ] unit-test
"-01:30" [ read-rfc3339-gmt-offset ] with-string-reader
] unit-test
[ 1+1/2 ] [ [ t ] [ 5 days checktime+ ] unit-test
"+01:30" [ read-rfc3339-gmt-offset ] with-string-reader
] 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 years checktime+ ] 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

387
extra/calendar/calendar.factor
View File

@ -1,20 +1,21 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io io.streams.string kernel math USING: arrays kernel math math.functions namespaces sequences
math.vectors math.functions math.parser namespaces sequences strings tuples system vocabs.loader calendar.backend threads
strings tuples system debugger combinators vocabs.loader new-slots accessors combinators ;
calendar.backend structs alien.c-types math.vectors
shuffle threads ;
IN: calendar IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ; TUPLE: timestamp year month day hour minute second gmt-offset ;
C: <timestamp> timestamp C: <timestamp> timestamp
TUPLE: dt year month day hour minute second ; : <date> ( year month day -- timestamp )
0 0 0 gmt-offset <timestamp> ;
C: <dt> dt TUPLE: duration year month day hour minute second ;
C: <duration> duration
: month-names : month-names
{ {
@ -40,6 +41,8 @@ C: <dt> dt
#! length of average month in days #! length of average month in days
30.41666666666667 ; 30.41666666666667 ;
<PRIVATE
SYMBOL: a SYMBOL: a
SYMBOL: b SYMBOL: b
SYMBOL: c SYMBOL: c
@ -48,6 +51,8 @@ SYMBOL: e
SYMBOL: y SYMBOL: y
SYMBOL: m SYMBOL: m
PRIVATE>
: julian-day-number ( year month day -- n ) : julian-day-number ( year month day -- n )
#! Returns a composite date number #! Returns a composite date number
#! Not valid before year -4800 #! Not valid before year -4800
@ -74,38 +79,31 @@ SYMBOL: m
e get 153 m get * 2 + 5 /i - 1+ e get 153 m get * 2 + 5 /i - 1+
] with-scope ; ] 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 ) : >date< ( timestamp -- year month day )
[ timestamp-year ] keep { year>> month>> day>> } get-slots ;
[ timestamp-month ] keep
timestamp-day ;
: >time< ( timestamp -- hour minute second ) : >time< ( timestamp -- hour minute second )
[ timestamp-hour ] keep { hour>> minute>> second>> } get-slots ;
[ timestamp-minute ] keep
timestamp-second ;
: zero-dt ( -- <dt> ) 0 0 0 0 0 0 <dt> ; : instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
: years ( n -- dt ) zero-dt [ set-dt-year ] keep ; : years ( n -- dt ) instant swap >>year ;
: months ( n -- dt ) zero-dt [ set-dt-month ] keep ; : months ( n -- dt ) instant swap >>month ;
: days ( n -- dt ) zero-dt [ set-dt-day ] keep ; : days ( n -- dt ) instant swap >>day ;
: weeks ( n -- dt ) 7 * days ; : weeks ( n -- dt ) 7 * days ;
: hours ( n -- dt ) zero-dt [ set-dt-hour ] keep ; : hours ( n -- dt ) instant swap >>hour ;
: minutes ( n -- dt ) zero-dt [ set-dt-minute ] keep ; : minutes ( n -- dt ) instant swap >>minute ;
: seconds ( n -- dt ) zero-dt [ set-dt-second ] keep ; : seconds ( n -- dt ) instant swap >>second ;
: milliseconds ( n -- dt ) 1000 /f seconds ; : milliseconds ( n -- dt ) 1000 / seconds ;
: julian-day-number>timestamp ( n -- timestamp ) GENERIC: leap-year? ( obj -- ? )
julian-day-number>date 0 0 0 0 <timestamp> ;
M: integer leap-year? ( year -- ? )
dup 100 mod zero? 400 4 ? mod zero? ;
M: timestamp leap-year? ( timestamp -- ? )
year>> leap-year? ;
<PRIVATE
GENERIC: +year ( timestamp x -- timestamp ) GENERIC: +year ( timestamp x -- timestamp )
GENERIC: +month ( timestamp x -- timestamp ) GENERIC: +month ( timestamp x -- timestamp )
@ -116,85 +114,103 @@ GENERIC: +second ( timestamp x -- timestamp )
: /rem ( f n -- q r ) : /rem ( f n -- q r )
#! q is positive or negative, r is positive from 0 <= r < n #! q is positive or negative, r is positive from 0 <= r < n
[ /f floor >integer ] 2keep rem ; [ / floor >integer ] 2keep rem ;
: float>whole-part ( float -- int float ) : float>whole-part ( float -- int float )
[ floor >integer ] keep over - ; [ 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 ) : adjust-leap-year ( timestamp -- timestamp )
dup >date< 29 = swap 2 = and swap leap-year? not and [ dup day>> 29 = over month>> 2 = pick leap-year? not and and
dup >r timestamp-year 3 1 r> [ set-date ] keep [ 3 >>month 1 >>day ] when ;
] when ;
: unless-zero >r dup zero? [ drop ] r> if ; inline
M: integer +year ( timestamp n -- timestamp ) M: integer +year ( timestamp n -- timestamp )
over timestamp-year + swap [ set-timestamp-year ] keep [ [ + ] curry change-year adjust-leap-year ] unless-zero ;
adjust-leap-year ;
M: real +year ( timestamp n -- timestamp ) 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 ) M: integer +month ( timestamp n -- timestamp )
over timestamp-month + 12 /rem [ over month>> + months/years >r >>month r> +year ] unless-zero ;
dup zero? [ drop 12 >r 1- r> ] when pick set-timestamp-month
+year ;
M: real +month ( timestamp n -- timestamp ) 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 ) M: integer +day ( timestamp n -- timestamp )
swap [ [
>date< julian-day-number + julian-day-number>timestamp over >date< julian-day-number + julian-day-number>date
] keep swap >r >time< r> [ set-time ] keep ; >r >r >>year r> >>month r> >>day
] unless-zero ;
M: real +day ( timestamp n -- timestamp ) 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 ) M: integer +hour ( timestamp n -- timestamp )
over timestamp-hour + 24 /rem pick set-timestamp-hour [ over hour>> + hours/days >r >>hour r> +day ] unless-zero ;
+day ;
M: real +hour ( timestamp n -- timestamp ) 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 ) M: integer +minute ( timestamp n -- timestamp )
over timestamp-minute + 60 /rem pick [ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ;
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 swapd 60 * +second swap +minute ] unless-zero ;
: seconds/minutes ( n -- seconds minutes )
60 /rem swap >integer ;
M: number +second ( timestamp n -- timestamp ) M: number +second ( timestamp n -- timestamp )
over timestamp-second + 60 /rem >r >integer r> [ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ;
pick set-timestamp-second +minute ;
: +dt ( timestamp dt -- timestamp ) : (time+)
dupd [ second>> +second ] keep
[ dt-second +second ] keep [ minute>> +minute ] keep
[ dt-minute +minute ] keep [ hour>> +hour ] keep
[ dt-hour +hour ] keep [ day>> +day ] keep
[ dt-day +day ] keep [ month>> +month ] keep
[ dt-month +month ] keep [ year>> +year ] keep ; inline
dt-year +year
swap timestamp-gmt-offset over set-timestamp-gmt-offset ;
: make-timestamp ( year month day hour minute second gmt-offset -- timestamp ) : +slots [ 2apply + ] curry 2keep ; inline
<timestamp> [ 0 seconds +dt ] keep
[ = [ "invalid timestamp" throw ] unless ] keep ;
: make-date ( year month day -- timestamp ) PRIVATE>
0 0 0 gmt-offset make-timestamp ;
: array>dt ( vec -- dt ) { dt f } swap append >tuple ; GENERIC# time+ 1 ( time dt -- time )
: +dts ( dt dt -- dt ) [ tuple-slots ] 2apply v+ array>dt ;
M: timestamp time+
>r clone r> (time+) drop ;
M: duration time+
[ year>> ] +slots
[ month>> ] +slots
[ day>> ] +slots
[ hour>> ] +slots
[ minute>> ] +slots
[ second>> ] +slots
2drop <duration> ;
: dt>years ( dt -- x ) : dt>years ( dt -- x )
#! Uses average month/year length since dt loses calendar #! Uses average month/year length since dt loses calendar
#! data #! data
tuple-slots 0 swap
{ 1 12 365.2425 8765.82 525949.2 31556952.0 } [ year>> + ] keep
v/ sum ; [ 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>months ( dt -- x ) dt>years 12 * ;
: dt>days ( dt -- x ) dt>years 365.2425 * ; : 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 * ; : dt>milliseconds ( dt -- x ) dt>years 31556952000 * ;
: convert-timezone ( timestamp n -- timestamp ) : convert-timezone ( timestamp n -- timestamp )
[ over timestamp-gmt-offset - hours +dt ] keep over gmt-offset>> over = [ drop ] [
over set-timestamp-gmt-offset ; [ over gmt-offset>> - hours time+ ] keep >>gmt-offset
] if ;
: >local-time ( timestamp -- timestamp ) : >local-time ( timestamp -- timestamp )
gmt-offset convert-timezone ; gmt-offset convert-timezone ;
@ -216,42 +233,37 @@ M: number +second ( timestamp n -- timestamp )
M: timestamp <=> ( ts1 ts2 -- n ) M: timestamp <=> ( ts1 ts2 -- n )
[ >gmt tuple-slots ] compare ; [ >gmt tuple-slots ] compare ;
: timestamp- ( timestamp timestamp -- seconds ) : time- ( timestamp timestamp -- seconds )
#! Exact calendar-time difference #! Exact calendar-time difference
[ >gmt ] 2apply [ >gmt ] 2apply
[ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep [ [ >date< julian-day-number ] 2apply - 86400 * ] 2keep
[ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ; [ >time< >r >r 3600 * r> 60 * r> + + ] 2apply - + ;
: unix-1970 ( -- timestamp ) : unix-1970 ( -- timestamp )
1970 1 1 0 0 0 0 <timestamp> ; 1970 1 1 0 0 0 0 <timestamp> ; foldable
: millis>timestamp ( n -- timestamp ) : millis>timestamp ( n -- timestamp )
>r unix-1970 r> 1000 /f seconds +dt ; >r unix-1970 r> milliseconds time+ ;
: timestamp>millis ( timestamp -- n ) : timestamp>millis ( timestamp -- n )
unix-1970 timestamp- 1000 * >integer ; unix-1970 time- 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 ;
: gmt ( -- timestamp ) : gmt ( -- timestamp )
#! GMT time, right now #! GMT time, right now
unix-1970 millis 1000 /f seconds +dt ; unix-1970 millis milliseconds time+ ;
: now ( -- timestamp ) gmt >local-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
<duration> ;
: from-now ( dt -- timestamp ) now swap time+ ;
: ago ( dt -- timestamp ) before from-now ; : ago ( dt -- timestamp ) before from-now ;
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; : 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 ) GENERIC: days-in-year ( obj -- n )
M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ; 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 ) GENERIC: days-in-month ( obj -- n )
@ -280,7 +292,7 @@ M: array days-in-month ( obj -- n )
] if ; ] if ;
M: timestamp days-in-month ( timestamp -- n ) 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 ) GENERIC: day-of-week ( obj -- n )
@ -297,156 +309,20 @@ M: array day-of-year ( array -- n )
3dup day-counts rot head-slice sum + 3dup day-counts rot head-slice sum +
swap leap-year? [ swap leap-year? [
-roll -roll
pick 3 1 make-date >r make-date r> pick 3 1 <date> >r <date> r>
<=> 0 >= [ 1+ ] when after=? [ 1+ ] when
] [ ] [
3nip >r 3drop r>
] if ; ] if ;
M: timestamp day-of-year ( timestamp -- n ) M: timestamp day-of-year ( timestamp -- n )
{ timestamp-year timestamp-month timestamp-day } get-slots >date< 3array day-of-year ;
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 " " <repetition> 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
<timestamp> ;
: 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 ;
: 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 time+ ;
: 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 ;
@ -457,25 +333,26 @@ M: timestamp year. ( timestamp -- )
: saturday ( timestamp -- timestamp ) 6 day-this-week ; : saturday ( timestamp -- timestamp ) 6 day-this-week ;
: beginning-of-day ( timestamp -- new-timestamp ) : beginning-of-day ( timestamp -- new-timestamp )
clone dup >r 0 0 0 r> clone
{ set-timestamp-hour set-timestamp-minute set-timestamp-second } 0 >>hour
set-slots ; inline 0 >>minute
0 >>second ; inline
: beginning-of-month ( timestamp -- new-timestamp ) : 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-week ( timestamp -- new-timestamp )
beginning-of-day sunday ; beginning-of-day sunday ;
: beginning-of-year ( timestamp -- new-timestamp ) : beginning-of-year ( timestamp -- new-timestamp )
beginning-of-month 1 over set-timestamp-month ; beginning-of-month 1 >>month ;
: seconds-since-midnight ( timestamp -- x ) : seconds-since-midnight ( timestamp -- x )
dup beginning-of-day timestamp- ; dup beginning-of-day time- ;
M: timestamp sleep-until timestamp>millis sleep-until ; 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" ] } { [ unix? ] [ "calendar.unix" ] }

22
extra/calendar/format/format-tests.factor Executable file
View File

@ -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

138
extra/calendar/format/format.factor Executable file
View File

@ -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 " " <repetition> 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
<timestamp> ;
: 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 ;

3
extra/webapps/file/file.factor
View File

@ -11,6 +11,9 @@ SYMBOL: doc-root
: serving-path ( filename -- filename ) : serving-path ( filename -- filename )
"" or doc-root get swap path+ ; "" or doc-root get swap path+ ;
: unix-time>timestamp ( n -- timestamp )
>r unix-1970 r> seconds time+ ;
: file-http-date ( filename -- string ) : file-http-date ( filename -- string )
file-modified unix-time>timestamp timestamp>http-string ; file-modified unix-time>timestamp timestamp>http-string ;

2
extra/windows/time/time-tests.factor Normal file → Executable file
View File

@ -2,5 +2,5 @@ USING: calendar calendar.windows kernel tools.test ;
[ t ] [ windows-1601 [ timestamp>FILETIME FILETIME>timestamp ] keep = ] unit-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-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

2
extra/windows/time/time.factor
View File

@ -15,7 +15,7 @@ IN: windows.time
FILETIME-dwHighDateTime >64bit ; FILETIME-dwHighDateTime >64bit ;
: windows-time>timestamp ( n -- timestamp ) : windows-time>timestamp ( n -- timestamp )
10000000 /i seconds windows-1601 swap +dt ; 10000000 /i seconds windows-1601 swap time+ ;
: windows-time ( -- n ) : windows-time ( -- n )
"FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep "FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep