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

remove >r r> from calendar

db4
Doug Coleman 2008-11-29 12:51:47 -06:00
parent 76da98c9bf
commit e0329d7cf8
1 changed files with 14 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
basis/calendar/calendar.factor
View File

@ -180,7 +180,7 @@ M: real +year ( timestamp n -- timestamp )
12 /rem dup zero? [ drop 1- 12 ] when swap ; inline 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
M: integer +month ( timestamp n -- timestamp ) M: integer +month ( timestamp n -- timestamp )
[ over month>> + months/years >r >>month r> +year ] unless-zero ; [ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
M: real +month ( timestamp n -- timestamp ) M: real +month ( timestamp n -- timestamp )
[ float>whole-part swapd average-month * +day swap +month ] unless-zero ; [ float>whole-part swapd average-month * +day swap +month ] unless-zero ;
@ -188,7 +188,7 @@ M: real +month ( timestamp n -- timestamp )
M: integer +day ( timestamp n -- timestamp ) M: integer +day ( timestamp n -- timestamp )
[ [
over >date< julian-day-number + julian-day-number>date over >date< julian-day-number + julian-day-number>date
>r >r >>year r> >>month r> >>day [ >>year ] [ >>month ] [ >>day ] tri*
] unless-zero ; ] unless-zero ;
M: real +day ( timestamp n -- timestamp ) M: real +day ( timestamp n -- timestamp )
@ -198,7 +198,7 @@ M: real +day ( timestamp n -- timestamp )
24 /rem swap ; 24 /rem swap ;
M: integer +hour ( timestamp n -- timestamp ) M: integer +hour ( timestamp n -- timestamp )
[ over hour>> + hours/days >r >>hour r> +day ] unless-zero ; [ over hour>> + hours/days [ >>hour ] dip +day ] unless-zero ;
M: real +hour ( timestamp n -- timestamp ) M: real +hour ( timestamp n -- timestamp )
float>whole-part swapd 60 * +minute swap +hour ; float>whole-part swapd 60 * +minute swap +hour ;
@ -207,7 +207,7 @@ M: real +hour ( timestamp n -- timestamp )
60 /rem swap ; 60 /rem swap ;
M: integer +minute ( timestamp n -- timestamp ) M: integer +minute ( timestamp n -- timestamp )
[ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ; [ over minute>> + minutes/hours [ >>minute ] dip +hour ] unless-zero ;
M: real +minute ( timestamp n -- timestamp ) M: real +minute ( timestamp n -- timestamp )
[ float>whole-part swapd 60 * +second swap +minute ] unless-zero ; [ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
@ -216,7 +216,7 @@ M: real +minute ( timestamp n -- timestamp )
60 /rem swap >integer ; 60 /rem swap >integer ;
M: number +second ( timestamp n -- timestamp ) M: number +second ( timestamp n -- timestamp )
[ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ; [ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ;
: (time+) : (time+)
[ second>> +second ] keep [ second>> +second ] keep
@ -233,7 +233,7 @@ PRIVATE>
GENERIC# time+ 1 ( time1 time2 -- time3 ) GENERIC# time+ 1 ( time1 time2 -- time3 )
M: timestamp time+ M: timestamp time+
>r clone r> (time+) drop ; [ clone ] dip (time+) drop ;
M: duration time+ M: duration time+
dup timestamp? [ dup timestamp? [
@ -291,7 +291,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
: (time-) ( timestamp timestamp -- n ) : (time-) ( timestamp timestamp -- n )
[ >gmt ] bi@ [ >gmt ] bi@
[ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
[ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ; [ >time< [ [ 3600 * ] [ 60 * ] bi* ] dip + + ] bi@ - + ;
M: timestamp time- M: timestamp time-
#! Exact calendar-time difference #! Exact calendar-time difference
@ -327,13 +327,13 @@ M: duration time-
1970 1 1 0 0 0 instant <timestamp> ; 1970 1 1 0 0 0 instant <timestamp> ;
: millis>timestamp ( x -- timestamp ) : millis>timestamp ( x -- timestamp )
>r unix-1970 r> milliseconds time+ ; [ unix-1970 ] dip milliseconds time+ ;
: timestamp>millis ( timestamp -- n ) : timestamp>millis ( timestamp -- n )
unix-1970 (time-) 1000 * >integer ; unix-1970 (time-) 1000 * >integer ;
: micros>timestamp ( x -- timestamp ) : micros>timestamp ( x -- timestamp )
>r unix-1970 r> microseconds time+ ; [ unix-1970 ] dip microseconds time+ ;
: timestamp>micros ( timestamp -- n ) : timestamp>micros ( timestamp -- n )
unix-1970 (time-) 1000000 * >integer ; unix-1970 (time-) 1000000 * >integer ;
@ -350,10 +350,11 @@ M: duration time-
#! Zeller Congruence #! Zeller Congruence
#! http://web.textfiles.com/computers/formulas.txt #! http://web.textfiles.com/computers/formulas.txt
#! good for any date since October 15, 1582 #! good for any date since October 15, 1582
>r dup 2 <= [ 12 + >r 1- r> ] when [
>r dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + r> dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
[ 1+ 3 * 5 /i + ] keep 2 * + r> [ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
1+ + 7 mod ; [ 1+ 3 * 5 /i + ] keep 2 * +
] dip 1+ + 7 mod ;
GENERIC: days-in-year ( obj -- n ) GENERIC: days-in-year ( obj -- n )