! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
+! See https://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.tuple combinators
-combinators.short-circuit kernel literals math math.functions
-math.intervals math.order math.statistics sequences slots.syntax
-system vocabs vocabs.loader ;
-FROM: math.ranges => [a..b) ;
+combinators.short-circuit kernel literals math math.constants
+math.functions math.intervals math.order math.statistics
+sequences system vocabs vocabs.loader ;
+FROM: ranges => [a..b) ;
IN: calendar
ERROR: not-in-interval value interval ;
HOOK: gmt-offset os ( -- hours minutes seconds )
+ALIAS: utc-offset gmt-offset
+
HOOK: now-gmt os ( -- timestamp )
+ALIAS: now-utc now-gmt
+
TUPLE: duration
{ year real }
{ month real }
{ gmt-offset duration } ;
<PRIVATE
+
<<
CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
>>
-CONSTANT: days-until $[ day-counts cum-sum0 ]
+CONSTANT: cumulative-day-counts $[ day-counts cum-sum0 ]
PRIVATE>
: (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 ;
: <date-gmt> ( year month day -- timestamp )
0 0 0 instant <timestamp> ; inline
+ALIAS: <date-utc> <date-gmt>
+
: <year> ( year -- timestamp )
1 1 <date> ; inline
: <year-gmt> ( year -- timestamp )
1 1 <date-gmt> ; inline
+ALIAS: <year-utc> <year-gmt>
+
CONSTANT: average-month 30+5/12
CONSTANT: months-per-year 12
CONSTANT: days-per-year 3652425/10000
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> ;
M: timestamp easter
- dup year>> easter-month-day
+ clone dup year>> easter-month-day
swapd >>day swap >>month ;
: >date< ( timestamp -- year month day )
: microseconds ( x -- duration ) 1000000 / seconds ;
: nanoseconds ( x -- duration ) 1000000000 / seconds ;
+DEFER: days-in-month
+
<PRIVATE
GENERIC: +year ( timestamp x -- timestamp )
12 /rem [ 1 - 12 ] when-zero swap ; inline
M: integer +month
- [ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
+ [
+ over month>> + months/years
+ [ >>month dup days-in-month '[ _ min ] change-day ] dip +year
+ ] unless-zero ;
M: real +month
float>whole-part swapd average-month * +day swap +month ;
[ day>> +day ]
[ month>> +month ]
[ year>> +year ]
- } cleave ; inline
+ } cleave ; inline
PRIVATE>
M: timestamp <=> [ >gmt tuple-slots ] compare ;
: same-year? ( ts1 ts2 -- ? )
- [ >gmt slots{ year } ] same? ;
+ [ year>> ] bi@ = ; inline
: quarter ( timestamp -- [1,4] )
month>> 3 /mod [ drop 1 + ] unless-zero ; inline
: same-quarter? ( ts1 ts2 -- ? )
- [ >gmt [ year>> ] [ quarter ] bi 2array ] same? ;
+ {
+ [ [ year>> ] same? ]
+ [ [ quarter ] same? ]
+ } 2&& ;
: same-month? ( ts1 ts2 -- ? )
- [ >gmt slots{ year month } ] same? ;
-
-:: (day-of-year) ( year month day -- n )
- month days-until nth day + {
- [ year leap-year? ]
- [ month 3 >= ]
+ {
+ [ [ year>> ] same? ]
+ [ [ month>> ] same? ]
+ } 2&& ;
+
+:: (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 )
>date< (day-of-year) ;
: same-day? ( ts1 ts2 -- ? )
- [ >gmt slots{ year month day } ] same? ;
+ {
+ [ [ year>> ] same? ]
+ [ [ month>> ] same? ]
+ [ [ day>> ] same? ]
+ } 2&& ;
+
+: same-day-of-year? ( ts1 ts2 -- ? )
+ {
+ [ [ month>> ] same? ]
+ [ [ day>> ] same? ]
+ } 2&& ;
: (day-of-week) ( year month day -- n )
! Zeller Congruence
- ! http://web.textfiles.com/computers/formulas.txt
+ ! https://web.textfiles.com/computers/formulas.txt
! good for any date since October 15, 1582
[
dup 2 <= [ [ 1 - ] [ 12 + ] bi* ] when
} case ;
: same-week? ( ts1 ts2 -- ? )
- [ >gmt [ year>> ] [ week-number ] bi 2array ] same? ;
+ [ [ year>> ] [ week-number ] bi 2array ] same? ;
: same-hour? ( ts1 ts2 -- ? )
- [ >gmt slots{ year month day hour } ] same? ;
+ [ >gmt ] bi@ {
+ [ [ year>> ] same? ]
+ [ [ month>> ] same? ]
+ [ [ day>> ] same? ]
+ [ [ hour>> ] same? ]
+ } 2&& ;
: same-minute? ( ts1 ts2 -- ? )
- [ >gmt slots{ year month day hour minute } ] same? ;
+ [ >gmt ] bi@ {
+ [ [ year>> ] same? ]
+ [ [ month>> ] same? ]
+ [ [ day>> ] same? ]
+ [ [ hour>> ] same? ]
+ [ [ minute>> ] same? ]
+ } 2&& ;
: same-second? ( ts1 ts2 -- ? )
- [ >gmt slots{ year month day hour minute second } ] same? ;
+ [ >gmt ] bi@ {
+ [ [ second>> floor ] bi@ = ]
+ [ same-minute? ]
+ } 2&& ;
<PRIVATE
: hence ( duration -- timestamp ) now swap time+ ;
: ago ( duration -- timestamp ) now swap time- ;
+: days-since ( time -- n ) ago duration>days ;
+: days-until ( time -- n ) now time- duration>days ;
GENERIC: days-in-year ( obj -- n )
: days-in-month ( timestamp -- n )
>date< drop (days-in-month) ;
-: midnight ( timestamp -- timestamp ) 0 0 0 set-time ; inline
-: noon ( timestamp -- timestamp ) 12 0 0 set-time ; inline
+: midnight ( timestamp -- timestamp' ) clone 0 0 0 set-time ; inline
+: noon ( timestamp -- timestamp' ) clone 12 0 0 set-time ; inline
: today ( -- timestamp ) now midnight ; inline
: tomorrow ( -- timestamp ) 1 days hence midnight ; inline
: yesterday ( -- timestamp ) 1 days ago midnight ; inline
-: overtomorrow ( -- timestamp ) 2 days hence midnight ; inline
+: overmorrow ( -- timestamp ) 2 days hence midnight ; inline
: ereyesterday ( -- timestamp ) 2 days ago midnight ; inline
: today? ( timestamp -- ? ) now same-day? ; inline
ALIAS: start-of-day midnight
-: end-of-day ( timestamp -- timestamp )
- 23 >>hour 59 >>minute 59+999/1000 >>second ; inline
+: end-of-day ( timestamp -- timestamp' )
+ clone 23 >>hour 59 >>minute 59+999/1000 >>second ; inline
+
+: first-day-of-month ( timestamp -- timestamp' )
+ clone 1 >>day ;
-: start-of-month ( timestamp -- timestamp )
- midnight 1 >>day ; inline
+: last-day-of-month ( timestamp -- timestamp' )
+ clone dup days-in-month >>day ; inline
-: end-of-month ( timestamp -- timestamp )
+: start-of-month ( timestamp -- timestamp' )
+ midnight first-day-of-month ; inline
+
+: end-of-month ( timestamp -- timestamp' )
[ end-of-day ] [ days-in-month ] bi >>day ;
-: start-of-quarter ( timestamp -- timestamp )
+: start-of-quarter ( timestamp -- timestamp' )
[ start-of-day ] [ quarter 1 - 3 * ] bi >>month ; inline
-: end-of-quarter ( timestamp -- timestamp )
+: end-of-quarter ( timestamp -- timestamp' )
dup quarter 1 - 3 * 3 + >>month end-of-month ; inline
-: first-day-of-month ( timestamp -- timestamp )
- 1 >>day ;
-
-: last-day-of-month ( timestamp -- timestamp )
- dup days-in-month >>day ; inline
-
GENERIC: first-day-of-year ( object -- timestamp )
-M: timestamp first-day-of-year first-day-of-month 1 >>month ;
+M: timestamp first-day-of-year clone 1 >>month 1 >>day ;
M: integer first-day-of-year <year> ;
GENERIC: last-day-of-year ( object -- timestamp )
-M: timestamp last-day-of-year 12 >>month 31 >>day ;
+M: timestamp last-day-of-year clone 12 >>month 31 >>day ;
M: integer last-day-of-year 12 31 <date> ;
-: first-day-of-decade ( object -- timestamp )
+: first-day-of-decade ( object -- timestamp' )
first-day-of-year [ dup 10 mod - ] change-year ;
-: last-day-of-decade ( object -- timestamp )
+: last-day-of-decade ( object -- timestamp' )
last-day-of-year [ dup 10 mod - 9 + ] change-year ;
-: first-day-of-century ( object -- timestamp )
+: first-day-of-century ( object -- timestamp' )
first-day-of-year [ dup 100 mod - ] change-year ;
-: last-day-of-century ( object -- timestamp )
+: last-day-of-century ( object -- timestamp' )
last-day-of-year [ dup 100 mod - 99 + ] change-year ;
-: first-day-of-millennium ( object -- timestamp )
+: first-day-of-millennium ( object -- timestamp' )
first-day-of-year [ dup 1000 mod - ] change-year ;
-: last-day-of-millennium ( object -- timestamp )
+: last-day-of-millennium ( object -- timestamp' )
last-day-of-year [ dup 1000 mod - 999 + ] change-year ;
: start-of-year ( object -- timestamp )
: end-of-millennium ( object -- timestamp )
last-day-of-millennium end-of-day ;
-: start-of-hour ( timestamp -- timestamp ) 0 >>minute 0 >>second ;
-: end-of-hour ( timestamp -- timestamp ) 59 >>minute 59+999/1000 >>second ;
+: start-of-hour ( timestamp -- timestamp' ) clone 0 >>minute 0 >>second ;
+: end-of-hour ( timestamp -- timestamp' ) clone 59 >>minute 59+999/1000 >>second ;
-: start-of-minute ( timestamp -- timestamp ) 0 >>second ;
-: end-of-minute ( timestamp -- timestamp ) 59+999/1000 >>second ;
+: start-of-minute ( timestamp -- timestamp' ) clone 0 >>second ;
+: end-of-minute ( timestamp -- timestamp' ) clone 59+999/1000 >>second ;
-: start-of-second ( timestamp -- timestamp ) [ floor ] change-second ;
-: end-of-second ( timestamp -- timestamp ) [ floor 999/1000 + ] change-second ;
+: start-of-second ( timestamp -- timestamp' ) clone [ floor ] change-second ;
+: end-of-second ( timestamp -- timestamp' ) clone [ floor 999/1000 + ] change-second ;
<PRIVATE
: day-offset ( timestamp m -- timestamp n )
over day-of-week - ; inline
-: day-this-week ( timestamp n -- timestamp )
- day-offset days (time+) ;
+: day-this-week ( timestamp n -- timestamp' )
+ day-offset days time+ ;
-: closest-day ( timestamp n -- timestamp )
+: closest-day ( timestamp n -- timestamp' )
[ dup day-of-week 7 swap - ] [ + 7 mod ] bi*
- { 0 1 2 3 -3 -2 -1 } nth days (time+) ;
+ { 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
- [ 1 weeks (time+) ] unless
- n [ weeks (time+) ] unless-zero ;
+ [ $n ] [ $n 1 + ] if weeks time+ ;
PRIVATE>
-GENERIC: january ( obj -- timestamp )
-GENERIC: february ( obj -- timestamp )
-GENERIC: march ( obj -- timestamp )
-GENERIC: april ( obj -- timestamp )
-GENERIC: may ( obj -- timestamp )
-GENERIC: june ( obj -- timestamp )
-GENERIC: july ( obj -- timestamp )
-GENERIC: august ( obj -- timestamp )
-GENERIC: september ( obj -- timestamp )
-GENERIC: october ( obj -- timestamp )
-GENERIC: november ( obj -- timestamp )
-GENERIC: december ( obj -- timestamp )
+GENERIC: january ( obj -- timestamp' )
+GENERIC: february ( obj -- timestamp' )
+GENERIC: march ( obj -- timestamp' )
+GENERIC: april ( obj -- timestamp' )
+GENERIC: may ( obj -- timestamp' )
+GENERIC: june ( obj -- timestamp' )
+GENERIC: july ( obj -- timestamp' )
+GENERIC: august ( obj -- timestamp' )
+GENERIC: september ( obj -- timestamp' )
+GENERIC: october ( obj -- timestamp' )
+GENERIC: november ( obj -- timestamp' )
+GENERIC: december ( obj -- timestamp' )
M: integer january 1 1 <date> ;
M: integer february 2 1 <date> ;
M: integer november 11 1 <date> ;
M: integer december 12 1 <date> ;
-M: timestamp january 1 >>month ;
-M: timestamp february 2 >>month ;
-M: timestamp march 3 >>month ;
-M: timestamp april 4 >>month ;
-M: timestamp may 5 >>month ;
-M: timestamp june 6 >>month ;
-M: timestamp july 7 >>month ;
-M: timestamp august 8 >>month ;
-M: timestamp september 9 >>month ;
-M: timestamp october 10 >>month ;
-M: timestamp november 11 >>month ;
-M: timestamp december 12 >>month ;
-
-: closest-sunday ( timestamp -- timestamp ) 0 closest-day ;
-: closest-monday ( timestamp -- timestamp ) 1 closest-day ;
-: closest-tuesday ( timestamp -- timestamp ) 2 closest-day ;
-: closest-wednesday ( timestamp -- timestamp ) 3 closest-day ;
-: closest-thursday ( timestamp -- timestamp ) 4 closest-day ;
-: closest-friday ( timestamp -- timestamp ) 5 closest-day ;
-: closest-saturday ( timestamp -- timestamp ) 6 closest-day ;
-
-: sunday ( timestamp -- timestamp ) 0 day-this-week ;
-: monday ( timestamp -- timestamp ) 1 day-this-week ;
-: tuesday ( timestamp -- timestamp ) 2 day-this-week ;
-: wednesday ( timestamp -- timestamp ) 3 day-this-week ;
-: thursday ( timestamp -- timestamp ) 4 day-this-week ;
-: friday ( timestamp -- timestamp ) 5 day-this-week ;
-: saturday ( timestamp -- timestamp ) 6 day-this-week ;
+M: timestamp january clone 1 >>month ;
+M: timestamp february clone 2 >>month ;
+M: timestamp march clone 3 >>month ;
+M: timestamp april clone 4 >>month ;
+M: timestamp may clone 5 >>month ;
+M: timestamp june clone 6 >>month ;
+M: timestamp july clone 7 >>month ;
+M: timestamp august clone 8 >>month ;
+M: timestamp september clone 9 >>month ;
+M: timestamp october clone 10 >>month ;
+M: timestamp november clone 11 >>month ;
+M: timestamp december clone 12 >>month ;
+
+: closest-sunday ( timestamp -- timestamp' ) 0 closest-day ;
+: closest-monday ( timestamp -- timestamp' ) 1 closest-day ;
+: closest-tuesday ( timestamp -- timestamp' ) 2 closest-day ;
+: closest-wednesday ( timestamp -- timestamp' ) 3 closest-day ;
+: closest-thursday ( timestamp -- timestamp' ) 4 closest-day ;
+: closest-friday ( timestamp -- timestamp' ) 5 closest-day ;
+: closest-saturday ( timestamp -- timestamp' ) 6 closest-day ;
+
+: sunday ( timestamp -- timestamp' ) 0 day-this-week ;
+: monday ( timestamp -- timestamp' ) 1 day-this-week ;
+: tuesday ( timestamp -- timestamp' ) 2 day-this-week ;
+: wednesday ( timestamp -- timestamp' ) 3 day-this-week ;
+: thursday ( timestamp -- timestamp' ) 4 day-this-week ;
+: friday ( timestamp -- timestamp' ) 5 day-this-week ;
+: saturday ( timestamp -- timestamp' ) 6 day-this-week ;
ALIAS: first-day-of-week sunday
ALIAS: last-day-of-week saturday
-: day< ( timestamp quot -- timestamp )
- over clone [ call dup ] dip after=? [ -7 days (time+) ] when ; inline
-: day<= ( timestamp quot -- timestamp )
- over clone [ call dup ] dip after? [ -7 days (time+) ] when ; inline
-: day> ( timestamp quot -- timestamp )
- over clone [ call dup ] dip before=? [ 7 days (time+) ] when ; inline
-: day>= ( timestamp quot -- timestamp )
- over clone [ call dup ] dip before? [ 7 days (time+) ] when ; inline
-
-: sunday< ( timestamp -- timestamp ) [ sunday ] day< ;
-: monday< ( timestamp -- timestamp ) [ monday ] day< ;
-: tuesday< ( timestamp -- timestamp ) [ tuesday ] day< ;
-: wednesday< ( timestamp -- timestamp ) [ wednesday ] day< ;
-: thursday< ( timestamp -- timestamp ) [ thursday ] day< ;
-: friday< ( timestamp -- timestamp ) [ friday ] day< ;
-: saturday< ( timestamp -- timestamp ) [ saturday ] day< ;
-
-: sunday<= ( timestamp -- timestamp ) [ sunday ] day<= ;
-: monday<= ( timestamp -- timestamp ) [ monday ] day<= ;
-: tuesday<= ( timestamp -- timestamp ) [ tuesday ] day<= ;
-: wednesday<= ( timestamp -- timestamp ) [ wednesday ] day<= ;
-: thursday<= ( timestamp -- timestamp ) [ thursday ] day<= ;
-: friday<= ( timestamp -- timestamp ) [ friday ] day<= ;
-: saturday<= ( timestamp -- timestamp ) [ saturday ] day<= ;
-
-: sunday> ( timestamp -- timestamp ) [ sunday ] day> ;
-: monday> ( timestamp -- timestamp ) [ monday ] day> ;
-: tuesday> ( timestamp -- timestamp ) [ tuesday ] day> ;
-: wednesday> ( timestamp -- timestamp ) [ wednesday ] day> ;
-: thursday> ( timestamp -- timestamp ) [ thursday ] day> ;
-: friday> ( timestamp -- timestamp ) [ friday ] day> ;
-: saturday> ( timestamp -- timestamp ) [ saturday ] day> ;
-
-: sunday>= ( timestamp -- timestamp ) [ sunday ] day>= ;
-: monday>= ( timestamp -- timestamp ) [ monday ] day>= ;
-: tuesday>= ( timestamp -- timestamp ) [ tuesday ] day>= ;
-: wednesday>= ( timestamp -- timestamp ) [ wednesday ] day>= ;
-: thursday>= ( timestamp -- timestamp ) [ thursday ] day>= ;
-: friday>= ( timestamp -- timestamp ) [ friday ] day>= ;
-: saturday>= ( timestamp -- timestamp ) [ saturday ] day>= ;
-
-: next-sunday ( timestamp -- timestamp ) closest-sunday sunday> ;
-: next-monday ( timestamp -- timestamp ) closest-monday monday> ;
-: next-tuesday ( timestamp -- timestamp ) closest-tuesday tuesday> ;
-: next-wednesday ( timestamp -- timestamp ) closest-wednesday wednesday> ;
-: next-thursday ( timestamp -- timestamp ) closest-thursday thursday> ;
-: next-friday ( timestamp -- timestamp ) closest-friday friday> ;
-: next-saturday ( timestamp -- timestamp ) closest-saturday saturday> ;
-
-: last-sunday ( timestamp -- timestamp ) closest-sunday sunday< ;
-: last-monday ( timestamp -- timestamp ) closest-monday monday< ;
-: last-tuesday ( timestamp -- timestamp ) closest-tuesday tuesday< ;
-: last-wednesday ( timestamp -- timestamp ) closest-wednesday wednesday< ;
-: last-thursday ( timestamp -- timestamp ) closest-thursday thursday< ;
-: last-friday ( timestamp -- timestamp ) closest-friday friday< ;
-: last-saturday ( timestamp -- timestamp ) closest-saturday saturday< ;
+: day< ( timestamp quot -- timestamp' )
+ over clone [ call dup ] dip after=? [ -7 days time+ ] when ; inline
+: day<= ( timestamp quot -- timestamp' )
+ over clone [ call dup ] dip after? [ -7 days time+ ] when ; inline
+: day> ( timestamp quot -- timestamp' )
+ over clone [ call dup ] dip before=? [ 7 days time+ ] when ; inline
+: day>= ( timestamp quot -- timestamp' )
+ over clone [ call dup ] dip before? [ 7 days time+ ] when ; inline
+
+: sunday< ( timestamp -- timestamp' ) [ sunday ] day< ;
+: monday< ( timestamp -- timestamp' ) [ monday ] day< ;
+: tuesday< ( timestamp -- timestamp' ) [ tuesday ] day< ;
+: wednesday< ( timestamp -- timestamp' ) [ wednesday ] day< ;
+: thursday< ( timestamp -- timestamp' ) [ thursday ] day< ;
+: friday< ( timestamp -- timestamp' ) [ friday ] day< ;
+: saturday< ( timestamp -- timestamp' ) [ saturday ] day< ;
+
+: sunday<= ( timestamp -- timestamp' ) [ sunday ] day<= ;
+: monday<= ( timestamp -- timestamp' ) [ monday ] day<= ;
+: tuesday<= ( timestamp -- timestamp' ) [ tuesday ] day<= ;
+: wednesday<= ( timestamp -- timestamp' ) [ wednesday ] day<= ;
+: thursday<= ( timestamp -- timestamp' ) [ thursday ] day<= ;
+: friday<= ( timestamp -- timestamp' ) [ friday ] day<= ;
+: saturday<= ( timestamp -- timestamp' ) [ saturday ] day<= ;
+
+: sunday> ( timestamp -- timestamp' ) [ sunday ] day> ;
+: monday> ( timestamp -- timestamp' ) [ monday ] day> ;
+: tuesday> ( timestamp -- timestamp' ) [ tuesday ] day> ;
+: wednesday> ( timestamp -- timestamp' ) [ wednesday ] day> ;
+: thursday> ( timestamp -- timestamp' ) [ thursday ] day> ;
+: friday> ( timestamp -- timestamp' ) [ friday ] day> ;
+: saturday> ( timestamp -- timestamp' ) [ saturday ] day> ;
+
+: sunday>= ( timestamp -- timestamp' ) [ sunday ] day>= ;
+: monday>= ( timestamp -- timestamp' ) [ monday ] day>= ;
+: tuesday>= ( timestamp -- timestamp' ) [ tuesday ] day>= ;
+: wednesday>= ( timestamp -- timestamp' ) [ wednesday ] day>= ;
+: thursday>= ( timestamp -- timestamp' ) [ thursday ] day>= ;
+: friday>= ( timestamp -- timestamp' ) [ friday ] day>= ;
+: saturday>= ( timestamp -- timestamp' ) [ saturday ] day>= ;
+
+: next-sunday ( timestamp -- timestamp' ) closest-sunday sunday> ;
+: next-monday ( timestamp -- timestamp' ) closest-monday monday> ;
+: next-tuesday ( timestamp -- timestamp' ) closest-tuesday tuesday> ;
+: next-wednesday ( timestamp -- timestamp' ) closest-wednesday wednesday> ;
+: next-thursday ( timestamp -- timestamp' ) closest-thursday thursday> ;
+: next-friday ( timestamp -- timestamp' ) closest-friday friday> ;
+: next-saturday ( timestamp -- timestamp' ) closest-saturday saturday> ;
+
+: last-sunday ( timestamp -- timestamp' ) closest-sunday sunday< ;
+: last-monday ( timestamp -- timestamp' ) closest-monday monday< ;
+: last-tuesday ( timestamp -- timestamp' ) closest-tuesday tuesday< ;
+: last-wednesday ( timestamp -- timestamp' ) closest-wednesday wednesday< ;
+: last-thursday ( timestamp -- timestamp' ) closest-thursday thursday< ;
+: last-friday ( timestamp -- timestamp' ) closest-friday friday< ;
+: last-saturday ( timestamp -- timestamp' ) closest-saturday saturday< ;
: sunday? ( timestamp -- ? ) day-of-week 0 = ;
: monday? ( timestamp -- ? ) day-of-week 1 = ;
: december? ( timestamp -- ? ) month>> 12 = ;
: weekend? ( timestamp -- ? ) day-of-week { 0 6 } member? ;
-: weekday? ( timestamp -- ? ) day-of-week weekend? not ;
+: weekday? ( timestamp -- ? ) weekend? not ;
-: same-or-next-business-day ( timestamp -- timestamp )
+: same-or-next-business-day ( timestamp -- timestamp' )
dup day-of-week {
{ 0 [ monday ] }
- { 6 [ 2 days (time+) ] }
+ { 6 [ 2 days time+ ] }
[ drop ]
} case ;
-: same-or-previous-business-day ( timestamp -- timestamp )
+: same-or-previous-business-day ( timestamp -- timestamp' )
dup day-of-week {
- { 0 [ -2 days (time+) ] }
+ { 0 [ -2 days time+ ] }
{ 6 [ friday ] }
[ drop ]
} case ;
day-of-week 6 = [ [ 1 - ] dip ] when
day-of-week 0 = [ 1 - ] when ;
-CONSTANT: weekday-offsets { 0 0 1 2 3 4 5 }
-
-: weekdays-between2 ( date1 date2 -- n )
- [ swap time- duration>days 1 + ]
- [ [ day-of-week ] bi@ 6 swap - ] 2bi
-
- [ + + 1.4 /i ]
- [ [ weekday-offsets nth ] bi@ + ] 2bi - ;
-
-: sunday-of-month ( timestamp n -- timestamp ) 0 nth-day-this-month ;
-: monday-of-month ( timestamp n -- timestamp ) 1 nth-day-this-month ;
-: tuesday-of-month ( timestamp n -- timestamp ) 2 nth-day-this-month ;
-: wednesday-of-month ( timestamp n -- timestamp ) 3 nth-day-this-month ;
-: thursday-of-month ( timestamp n -- timestamp ) 4 nth-day-this-month ;
-: friday-of-month ( timestamp n -- timestamp ) 5 nth-day-this-month ;
-: saturday-of-month ( timestamp n -- timestamp ) 6 nth-day-this-month ;
-
-: last-sunday-of-month ( timestamp -- timestamp ) last-day-of-month sunday<= ;
-: last-monday-of-month ( timestamp -- timestamp ) last-day-of-month monday<= ;
-: last-tuesday-of-month ( timestamp -- timestamp ) last-day-of-month tuesday<= ;
-: last-wednesday-of-month ( timestamp -- timestamp ) last-day-of-month wednesday<= ;
-: last-thursday-of-month ( timestamp -- timestamp ) last-day-of-month thursday<= ;
-: last-friday-of-month ( timestamp -- timestamp ) last-day-of-month friday<= ;
-: last-saturday-of-month ( timestamp -- timestamp ) last-day-of-month saturday<= ;
-
-: start-of-week ( timestamp -- timestamp )
+: sunday-of-month ( timestamp n -- timestamp' ) 0 nth-day-this-month ;
+: monday-of-month ( timestamp n -- timestamp' ) 1 nth-day-this-month ;
+: tuesday-of-month ( timestamp n -- timestamp' ) 2 nth-day-this-month ;
+: wednesday-of-month ( timestamp n -- timestamp' ) 3 nth-day-this-month ;
+: thursday-of-month ( timestamp n -- timestamp' ) 4 nth-day-this-month ;
+: friday-of-month ( timestamp n -- timestamp' ) 5 nth-day-this-month ;
+: saturday-of-month ( timestamp n -- timestamp' ) 6 nth-day-this-month ;
+
+: last-sunday-of-month ( timestamp -- timestamp' ) last-day-of-month sunday<= ;
+: last-monday-of-month ( timestamp -- timestamp' ) last-day-of-month monday<= ;
+: last-tuesday-of-month ( timestamp -- timestamp' ) last-day-of-month tuesday<= ;
+: last-wednesday-of-month ( timestamp -- timestamp' ) last-day-of-month wednesday<= ;
+: last-thursday-of-month ( timestamp -- timestamp' ) last-day-of-month thursday<= ;
+: last-friday-of-month ( timestamp -- timestamp' ) last-day-of-month friday<= ;
+: last-saturday-of-month ( timestamp -- timestamp' ) last-day-of-month saturday<= ;
+
+: start-of-week ( timestamp -- timestamp' )
sunday midnight ;
-: end-of-week ( timestamp -- timestamp )
+: end-of-week ( timestamp -- timestamp' )
saturday end-of-day ;
-: o'clock ( timestamp n -- timestamp )
+: o'clock ( timestamp n -- timestamp' )
[ midnight ] dip >>hour ;
-: am ( timestamp n -- timestamp )
+: am ( timestamp n -- timestamp' )
1 12 [a,b] check-interval 12 mod o'clock ;
-: pm ( timestamp n -- timestamp )
+: pm ( timestamp n -- timestamp' )
1 12 [a,b] check-interval 12 mod 12 + o'clock ;
: time-since-midnight ( timestamp -- duration )
: year-ordinal>timestamp ( year ordinal -- timestamp )
[ 1 1 julian-day-number ] dip
- + 1 - julian-day-number>date <date> ;
+ + 1 - julian-day-number>date <date-gmt> ;
GENERIC: weeks-in-week-year ( obj -- n )
M: timestamp weeks-in-week-year
{ [ january 1 >>day thursday? ] [ december 31 >>day thursday? ] } 1|| 53 52 ? ;
+! https://gml.noaa.gov/grad/solcalc/solareqns.PDF
+
+<PRIVATE
+
+: fractional-year ( timestamp -- radians )
+ [ days-in-year 2pi swap / ]
+ [ day-of-year 1 - ]
+ [ hour>> 12 - 24 / + * ] tri ;
+
+:: declination ( timestamp -- radians )
+ timestamp fractional-year :> γ
+ 0.006918
+ 0.399912 γ cos * -
+ 0.070257 γ sin * +
+ 0.006758 γ 2 * cos * -
+ 0.000907 γ 2 * sin * +
+ 0.002697 γ 3 * cos * -
+ 0.00148 γ 3 * sin * + ;
+
+:: hour-angle ( timestamp latitude -- degrees )
+ timestamp declination :> decl
+ latitude deg>rad :> lat
+ 90.833 deg>rad cos
+ lat cos decl cos * /
+ lat tan decl tan * -
+ acos rad>deg ;
+
+:: equation-of-time ( timestamp -- minutes )
+ timestamp fractional-year :> γ
+ 0.000075
+ 0.001868 γ cos * +
+ 0.032077 γ sin * -
+ 0.014615 γ 2 * cos * -
+ 0.040849 γ 2 * sin * -
+ 229.18 * ;
+
+: preserve-gmt-offset ( timestamp quot -- timestamp' )
+ '[ >utc @ ] [ gmt-offset>> convert-timezone ] bi ; inline
+
+: (sunrise/sunset) ( timestamp latitude longitude quot -- new-timestamp )
+ '[
+ [ noon ]
+ [ _ hour-angle _ swap @ 4 * ]
+ [ equation-of-time ] tri + round >integer minutes time-
+ ] preserve-gmt-offset ; inline
+
+PRIVATE>
+
+: sunrise ( timestamp latitude longitude -- new-timestamp )
+ [ + ] (sunrise/sunset) ;
+
+: sunset ( timestamp latitude longitude -- new-timestamp )
+ [ - ] (sunrise/sunset) ;
+
+: solar-noon ( timestamp longitude -- new-timestamp )
+ '[
+ [ noon _ 4 * ] [ equation-of-time ] bi + minutes time-
+ [ round >integer ] change-second
+ ] preserve-gmt-offset ;
+
{
{ [ os unix? ] [ "calendar.unix" ] }
{ [ os windows? ] [ "calendar.windows" ] }
projects / factor.git / blobdiff