: (days-in-month) ( year month -- n )
dup 2 = [ drop leap-year? 29 28 ? ] [ nip day-counts nth ] if ;
-:: <timestamp> ( year month day hour minute second gmt-offset -- timestamp )
- year
- month 1 12 [a,b] check-interval
- day 1 year month (days-in-month) [a,b] check-interval
- hour 0 23 [a,b] check-interval
- minute 0 59 [a,b] check-interval
- second 0 60 [a,b) check-interval
- gmt-offset timestamp boa ;
+:: <timestamp> ( $year $month $day $hour $minute $second $gmt-offset -- timestamp )
+ $year
+ $month 1 12 [a,b] check-interval
+ $day 1 $year $month (days-in-month) [a,b] check-interval
+ $hour 0 23 [a,b] check-interval
+ $minute 0 59 [a,b] check-interval
+ $second 0 60 [a,b) check-interval
+ $gmt-offset timestamp boa ;
M: timestamp clone (clone) [ clone ] change-gmt-offset ;
CONSTANT: minutes-per-year 5259492/10
CONSTANT: seconds-per-year 31556952
-:: julian-day-number ( year month day -- n )
+:: julian-day-number ( $year $month $day -- n )
! Returns a composite date number
! Not valid before year -4800
- 14 month - 12 /i :> a
- year 4800 + a - :> y
- month 12 a * + 3 - :> m
+ 14 $month - 12 /i :> $a
+ $year 4800 + $a - :> $y
+ $month 12 $a * + 3 - :> $m
- day 153 m * 2 + 5 /i + 365 y * +
- y 4 /i + y 100 /i - y 400 /i + 32045 - ;
+ $day 153 $m * 2 + 5 /i + 365 $y * +
+ $y 4 /i + $y 100 /i - $y 400 /i + 32045 - ;
-:: julian-day-number>date ( n -- year month day )
+:: julian-day-number>date ( $n -- year month day )
! Inverse of julian-day-number
- n 32044 + :> a
- 4 a * 3 + 146097 /i :> b
- a 146097 b * 4 /i - :> c
- 4 c * 3 + 1461 /i :> d
- c 1461 d * 4 /i - :> e
- 5 e * 2 + 153 /i :> m
-
- 100 b * d + 4800 -
- m 10 /i + m 3 +
- 12 m 10 /i * -
- e 153 m * 2 + 5 /i - 1 + ;
+ $n 32044 + :> $a
+ 4 $a * 3 + 146097 /i :> $b
+ $a 146097 $b * 4 /i - :> $c
+ 4 $c * 3 + 1461 /i :> $d
+ $c 1461 $d * 4 /i - :> $e
+ 5 $e * 2 + 153 /i :> $m
+
+ 100 $b * $d + 4800 -
+ $m 10 /i + $m 3 +
+ 12 $m 10 /i * -
+ $e 153 $m * 2 + 5 /i - 1 + ;
GENERIC: easter ( obj -- obj' )
-:: easter-month-day ( year -- month day )
- year 19 mod :> a
- year 100 /mod :> ( b c )
- b 4 /mod :> ( d e )
- b 8 + 25 /i :> f
- b f - 1 + 3 /i :> g
- 19 a * b + d - g - 15 + 30 mod :> h
- c 4 /mod :> ( i k )
- 32 2 e * + 2 i * + h - k - 7 mod :> l
- a 11 h * + 22 l * + 451 /i :> m
+:: easter-month-day ( $year -- month day )
+ $year 19 mod :> $a
+ $year 100 /mod :> ( $b $c )
+ $b 4 /mod :> ( $d $e )
+ $b 8 + 25 /i :> $f
+ $b $f - 1 + 3 /i :> $g
+ 19 $a * $b + $d - $g - 15 + 30 mod :> $h
+ $c 4 /mod :> ( $i $k )
+ 32 2 $e * + 2 $i * + $h - $k - 7 mod :> $l
+ $a 11 $h * + 22 $l * + 451 /i :> $m
- h l + 7 m * - 114 + 31 /mod 1 + ;
+ $h $l + 7 $m * - 114 + 31 /mod 1 + ;
M: integer easter
dup easter-month-day <date> ;
: same-month? ( ts1 ts2 -- ? )
[ slots{ year month } ] same? ;
-:: (day-of-year) ( year month day -- n )
- month cumulative-day-counts nth day + {
- [ year leap-year? ]
- [ month 3 >= ]
+:: (day-of-year) ( $year $month $day -- n )
+ $month cumulative-day-counts nth $day + {
+ [ $year leap-year? ]
+ [ $month 3 >= ]
} 0&& [ 1 + ] when ;
: day-of-year ( timestamp -- n )
[ dup day-of-week 7 swap - ] [ + 7 mod ] bi*
{ 0 1 2 3 -3 -2 -1 } nth days time+ ;
-:: nth-day-this-month ( timestamp n day -- timestamp' )
- timestamp clone
- timestamp start-of-month day day-this-week
+:: nth-day-this-month ( $timestamp $n $day -- timestamp' )
+ $timestamp clone
+ $timestamp start-of-month $day day-this-week
[ [ month>> ] same? ] keep swap
- [ n ] [ n 1 + ] if weeks time+ ;
+ [ $n ] [ $n 1 + ] if weeks time+ ;
PRIVATE>