remove >r r> from calendar
parent
76da98c9bf
commit
e0329d7cf8
|
@ -180,7 +180,7 @@ M: real +year ( timestamp n -- timestamp )
|
|||
12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
|
||||
|
||||
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 )
|
||||
[ 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 )
|
||||
[
|
||||
over >date< julian-day-number + julian-day-number>date
|
||||
>r >r >>year r> >>month r> >>day
|
||||
[ >>year ] [ >>month ] [ >>day ] tri*
|
||||
] unless-zero ;
|
||||
|
||||
M: real +day ( timestamp n -- timestamp )
|
||||
|
@ -198,7 +198,7 @@ M: real +day ( timestamp n -- timestamp )
|
|||
24 /rem swap ;
|
||||
|
||||
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 )
|
||||
float>whole-part swapd 60 * +minute swap +hour ;
|
||||
|
@ -207,7 +207,7 @@ M: real +hour ( timestamp n -- timestamp )
|
|||
60 /rem swap ;
|
||||
|
||||
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 )
|
||||
[ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
|
||||
|
@ -216,7 +216,7 @@ M: real +minute ( timestamp n -- timestamp )
|
|||
60 /rem swap >integer ;
|
||||
|
||||
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+)
|
||||
[ second>> +second ] keep
|
||||
|
@ -233,7 +233,7 @@ PRIVATE>
|
|||
GENERIC# time+ 1 ( time1 time2 -- time3 )
|
||||
|
||||
M: timestamp time+
|
||||
>r clone r> (time+) drop ;
|
||||
[ clone ] dip (time+) drop ;
|
||||
|
||||
M: duration time+
|
||||
dup timestamp? [
|
||||
|
@ -291,7 +291,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
|
|||
: (time-) ( timestamp timestamp -- n )
|
||||
[ >gmt ] bi@
|
||||
[ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
|
||||
[ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ;
|
||||
[ >time< [ [ 3600 * ] [ 60 * ] bi* ] dip + + ] bi@ - + ;
|
||||
|
||||
M: timestamp time-
|
||||
#! Exact calendar-time difference
|
||||
|
@ -327,13 +327,13 @@ M: duration time-
|
|||
1970 1 1 0 0 0 instant <timestamp> ;
|
||||
|
||||
: millis>timestamp ( x -- timestamp )
|
||||
>r unix-1970 r> milliseconds time+ ;
|
||||
[ unix-1970 ] dip milliseconds time+ ;
|
||||
|
||||
: timestamp>millis ( timestamp -- n )
|
||||
unix-1970 (time-) 1000 * >integer ;
|
||||
|
||||
: micros>timestamp ( x -- timestamp )
|
||||
>r unix-1970 r> microseconds time+ ;
|
||||
[ unix-1970 ] dip microseconds time+ ;
|
||||
|
||||
: timestamp>micros ( timestamp -- n )
|
||||
unix-1970 (time-) 1000000 * >integer ;
|
||||
|
@ -350,10 +350,11 @@ M: duration time-
|
|||
#! Zeller Congruence
|
||||
#! http://web.textfiles.com/computers/formulas.txt
|
||||
#! 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>
|
||||
[ 1+ 3 * 5 /i + ] keep 2 * + r>
|
||||
1+ + 7 mod ;
|
||||
[
|
||||
dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
|
||||
[ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
|
||||
[ 1+ 3 * 5 /i + ] keep 2 * +
|
||||
] dip 1+ + 7 mod ;
|
||||
|
||||
GENERIC: days-in-year ( obj -- n )
|
||||
|
||||
|
|
Loading…
Reference in New Issue