From c531e091f7ef07750c0e75694bc9ea74f5137cdd Mon Sep 17 00:00:00 2001 From: slava Date: Tue, 25 Jul 2006 17:15:32 +0000 Subject: [PATCH] Calendar cleanups --- TODO.FACTOR.txt | 1 - contrib/calendar/calendar.factor | 28 ++++---- contrib/calendar/test/calendar.factor | 92 +++++++++++++-------------- 3 files changed, 58 insertions(+), 63 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 7c54d6927a..19f48a324d 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -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 diff --git a/contrib/calendar/calendar.factor b/contrib/calendar/calendar.factor index e26f5af4c8..80bea9abcd 100644 --- a/contrib/calendar/calendar.factor +++ b/contrib/calendar/calendar.factor @@ -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 >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 -- ) [ 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 ; +: 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 ; +: 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 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 ; - diff --git a/contrib/calendar/test/calendar.factor b/contrib/calendar/test/calendar.factor index 1815ff7545..1440677a50 100644 --- a/contrib/calendar/test/calendar.factor +++ b/contrib/calendar/test/calendar.factor @@ -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