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