! 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 }
>>
: <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
[ 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 + {
>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
: 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*
: 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 ;
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