! 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 ;
+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
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 }
>>
: (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> ;
: 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>
month>> 3 /mod [ drop 1 + ] unless-zero ; inline
: same-quarter? ( ts1 ts2 -- ? )
- [ [ year>> ] [ quarter ] bi 2array ] same? ;
+ {
+ [ [ year>> ] same? ]
+ [ [ quarter ] same? ]
+ } 2&& ;
: same-month? ( ts1 ts2 -- ? )
- [ slots{ year month } ] same? ;
+ {
+ [ [ year>> ] same? ]
+ [ [ month>> ] same? ]
+ } 2&& ;
-:: (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 )
>date< (day-of-year) ;
: same-day? ( ts1 ts2 -- ? )
- [ slots{ year month day } ] same? ;
+ {
+ [ [ year>> ] same? ]
+ [ [ month>> ] same? ]
+ [ [ day>> ] same? ]
+ } 2&& ;
: same-day-of-year? ( ts1 ts2 -- ? )
- [ slots{ month day } ] same? ;
+ {
+ [ [ 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
[ [ 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 ] bi@
- {
+ [ >gmt ] bi@ {
[ [ second>> floor ] bi@ = ]
- [ [ slots{ year month day hour minute } ] same? ]
+ [ same-minute? ]
} 2&& ;
<PRIVATE
: 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
: end-of-day ( timestamp -- timestamp' )
clone 23 >>hour 59 >>minute 59+999/1000 >>second ; inline
+: first-day-of-month ( timestamp -- timestamp' )
+ clone 1 >>day ;
+
+: last-day-of-month ( timestamp -- timestamp' )
+ clone dup days-in-month >>day ; inline
+
: start-of-month ( timestamp -- timestamp' )
- midnight 1 >>day ; inline
+ midnight first-day-of-month ; inline
: end-of-month ( timestamp -- timestamp' )
[ end-of-day ] [ days-in-month ] bi >>day ;
: end-of-quarter ( timestamp -- timestamp' )
dup quarter 1 - 3 * 3 + >>month end-of-month ; inline
-: first-day-of-month ( timestamp -- timestamp' )
- clone 1 >>day ;
-
-: last-day-of-month ( timestamp -- timestamp' )
- clone dup days-in-month >>day ; inline
-
GENERIC: first-day-of-year ( object -- timestamp )
M: timestamp first-day-of-year clone 1 >>month 1 >>day ;
M: integer first-day-of-year <year> ;
over day-of-week - ; inline
: day-this-week ( timestamp n -- timestamp' )
- day-offset days (time+) ;
+ day-offset days time+ ;
: closest-day ( timestamp n -- timestamp' )
[ 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>
: 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' )
dup day-of-week {
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 ;
: 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