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

Calendar cleanups

release
slava 2006-07-25 17:15:32 +00:00
parent 66c4e51bcf
commit c531e091f7
3 changed files with 58 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
TODO.FACTOR.txt
View File

@ -1,7 +1,6 @@
+ 0.83:
- windows port from erg
- why aren't some cocoa words compiled?
- editor:
- scroll to caret
- clicking input doesn't resize editor gadget

28
contrib/calendar/calendar.factor
View File

@ -44,18 +44,15 @@ SYMBOL: gmt-offset
#! length of average month in days
30.41666666666667 ;
IN: kernel
M: tuple <=> ( tuple tuple -- n )
[ tuple>array 2 over length rot <slice> >array ] 2apply <=> ;
IN: calendar
: compare-timestamps ( tuple tuple -- n )
[ tuple>array 2 swap tail ] 2apply <=> ;
DEFER: >gmt
DEFER: +dt
DEFER: seconds
: make-timestamp ( year month day hour minute second gmt-offset -- <timestamp> )
<timestamp> [ 0 seconds +dt ] keep
[ <=> zero? [ "invalid timestamp" throw ] unless ] keep ;
[ = [ "invalid timestamp" throw ] unless ] keep ;
SYMBOL: a
SYMBOL: b
@ -145,29 +142,29 @@ M: integer +year ( timestamp n -- timestamp )
over timestamp-year + swap [ set-timestamp-year ] keep
adjust-leap-year ;
M: real +year ( timestamp n -- timestamp )
>float float>whole-part rot swap 365.2425 * +day swap +year ;
float>whole-part rot swap 365.2425 * +day swap +year ;
M: integer +month ( timestamp n -- timestamp )
over timestamp-month + 12 /mod-wrap
dup 0 = [ drop 12 >r 1- r> ] when pick set-timestamp-month +year ;
M: real +month ( timestamp n -- timestamp )
>float float>whole-part rot swap average-month * +day swap +month ;
float>whole-part rot swap average-month * +day swap +month ;
M: integer +day ( timestamp n -- timestamp )
swap [ date julian-day-number + julian-day-number>timestamp ] keep
swap >r time r> [ set-time ] keep ;
M: real +day ( timestamp n -- timestamp )
>float float>whole-part rot swap 24 * +hour swap +day ;
float>whole-part rot swap 24 * +hour swap +day ;
M: integer +hour ( timestamp n -- timestamp )
over timestamp-hour + 24 /mod-wrap pick set-timestamp-hour +day ;
M: real +hour ( timestamp n -- timestamp )
>float float>whole-part rot swap 60 * +minute swap +hour ;
float>whole-part rot swap 60 * +minute swap +hour ;
M: integer +minute ( timestamp n -- timestamp )
over timestamp-minute + 60 /mod-wrap pick set-timestamp-minute +hour ;
M: real +minute ( timestamp n -- timestamp )
>float float>whole-part rot swap 60 * +second swap +minute ;
float>whole-part rot swap 60 * +second swap +minute ;
M: number +second ( timestamp n -- timestamp )
over timestamp-second + 60 /mod-wrap >r >bignum r>
@ -183,14 +180,14 @@ M: number +second ( timestamp n -- timestamp )
dt-year +year
swap timestamp-gmt-offset over set-timestamp-gmt-offset ;
: dt>vec ( dt -- vec ) tuple>array 2 8 rot <slice> ;
: dt>vec ( dt -- vec ) tuple>array 2 swap tail ;
: vec>dt ( vec -- dt ) { dt f } swap append >tuple ;
: +dts ( dt dt -- dt ) [ dt>vec ] 2apply v+ vec>dt ;
: timestamp>vec ( dt -- vec ) tuple>array 2 8 rot <slice> ;
: timestamp>vec ( dt -- vec ) tuple>array 2 swap tail ;
: dt>years ( dt -- x )
#! Uses average month/year length since dt loses calendar data
dt>vec [ 1 12 365.2425 8765.82 525949.2 31556952.0 ] [ / ] 2map sum ;
dt>vec { 1 12 365.2425 8765.82 525949.2 31556952.0 } [ / ] 2map sum ;
: dt>months ( dt -- x ) dt>years 12 * ;
: dt>days ( dt -- x ) dt>years 365.2425 * ;
: dt>hours ( dt -- x ) dt>years 8765.82 * ;
@ -246,7 +243,7 @@ M: number +second ( timestamp n -- timestamp )
[ timestamp-year leap-year? ] keep
[ date 3array ] keep timestamp-year 3 1 3array <=> 0 >= and 1 0 ?
] keep
0 swap [ timestamp-month day-counts <slice> sum + ] keep
[ timestamp-month day-counts head-slice sum + ] keep
timestamp-day + ;
: print-day ( n -- )
@ -280,4 +277,3 @@ M: number +second ( timestamp n -- timestamp )
dup timestamp-minute unparse 2 CHAR: 0 pad-left write ":" write
dup timestamp-second >fixnum unparse 2 CHAR: 0 pad-left write " GMT" write
] string-out ;

92
contrib/calendar/test/calendar.factor
View File

@ -16,93 +16,93 @@ USING: arrays calendar errors kernel math sequences 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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
2006 10 11 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 10 minutes +dt
2006 10 10 0 10 0 0 make-timestamp <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
2006 10 9 23 59 15 0 make-timestamp = ] unit-test
[ t ] [ 2006 10 10 0 0 0 0 make-timestamp 7200 minutes +dt
2006 10 15 0 0 0 0 make-timestamp <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
2006 10 9 22 20 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 hours +dt
2006 1 1 1 0 0 0 make-timestamp <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
2006 1 4 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 1 days +dt
2006 1 2 0 0 0 0 make-timestamp <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
2005 1 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 11 months +dt
2006 12 1 0 0 0 0 make-timestamp <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
2003 3 1 0 0 0 0 make-timestamp = ] unit-test
[ t ] [ 2006 1 1 0 0 0 0 make-timestamp 0 years +dt
2006 1 1 0 0 0 0 make-timestamp <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
! 2003 2 28 0 0 0 0 make-timestamp = ] unit-test
[ 5 ] [ 2006 7 14 0 0 0 0 make-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 <=> zero? ] 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
[ 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
@ -111,16 +111,16 @@ USING: arrays calendar errors kernel math sequences 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
[ t ] [ 2004 12 31 0 0 0 0 make-timestamp dup <=> zero? ] 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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
1998 12 31 23 59 50 0 make-timestamp = ] unit-test
[ t ] [ 2004 1 1 23 0 0 12 make-timestamp 0 convert-timezone
2004 1 1 11 0 0 0 make-timestamp <=> zero? ] unit-test
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 <=> zero? ] unit-test
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 <=> zero? ] unit-test
2004 1 1 13 30 0 0 make-timestamp = ] unit-test