! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions namespaces sequences
-strings system vocabs.loader threads accessors combinators
-locals classes.tuple math.order summary combinators.short-circuit ;
+USING: accessors arrays classes.tuple combinators
+combinators.short-circuit kernel locals math math.functions
+math.order sequences summary system threads vocabs.loader ;
IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds )
drop "Months are indexed starting at 1" ;
<PRIVATE
+
: check-month ( n -- n )
dup zero? [ not-a-month ] when ;
+
PRIVATE>
-: month-names ( -- array )
+CONSTANT: month-names
{
"January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"
- } ;
+ }
: month-name ( n -- string )
- check-month 1- month-names nth ;
+ check-month 1 - month-names nth ;
-: month-abbreviations ( -- array )
+CONSTANT: month-abbreviations
{
"Jan" "Feb" "Mar" "Apr" "May" "Jun"
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
- } ;
+ }
: month-abbreviation ( n -- string )
- check-month 1- month-abbreviations nth ;
+ check-month 1 - month-abbreviations nth ;
-: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
+CONSTANT: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 }
: day-names ( -- array )
{
: day-name ( n -- string ) day-names nth ;
-: day-abbreviations2 ( -- array )
- { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" } ;
+CONSTANT: day-abbreviations2
+ { "Su" "Mo" "Tu" "We" "Th" "Fr" "Sa" }
: day-abbreviation2 ( n -- string )
- day-abbreviations2 nth ;
+ day-abbreviations2 nth ; inline
-: day-abbreviations3 ( -- array )
- { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" } ;
+CONSTANT: day-abbreviations3
+ { "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat" }
: day-abbreviation3 ( n -- string )
- day-abbreviations3 nth ;
+ day-abbreviations3 nth ; inline
: average-month ( -- ratio ) 30+5/12 ; inline
: months-per-year ( -- integer ) 12 ; inline
:: julian-day-number ( year month day -- n )
#! Returns a composite date number
#! Not valid before year -4800
- [let* | a [ 14 month - 12 /i ]
- y [ year 4800 + a - ]
- m [ month 12 a * + 3 - ] |
- day 153 m * 2 + 5 /i + 365 y * +
- y 4 /i + y 100 /i - y 400 /i + 32045 -
- ] ;
+ 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 - ;
:: julian-day-number>date ( n -- year month day )
#! Inverse of julian-day-number
- [let* | a [ n 32044 + ]
- b [ 4 a * 3 + 146097 /i ]
- c [ a 146097 b * 4 /i - ]
- d [ 4 c * 3 + 1461 /i ]
- e [ c 1461 d * 4 /i - ]
- m [ 5 e * 2 + 153 /i ] |
- 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 :> c :> b
+ b 4 /mod :> e :> d
+ b 8 + 25 /i :> f
+ b f - 1 + 3 /i :> g
+ 19 a * b + d - g - 15 + 30 mod :> h
+ c 4 /mod :> k :> i
+ 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 + :> day :> month
+ month day ;
+
+M: integer easter ( year -- timestamp )
+ dup easter-month-day <date> ;
+
+M: timestamp easter ( timestamp -- timestamp )
+ clone
+ dup year>> easter-month-day
+ swapd >>day swap >>month ;
: >date< ( timestamp -- year month day )
[ year>> ] [ month>> ] [ day>> ] tri ;
GENERIC: leap-year? ( obj -- ? )
M: integer leap-year? ( year -- ? )
- dup 100 mod zero? 400 4 ? mod zero? ;
+ dup 100 divisor? 400 4 ? divisor? ;
M: timestamp leap-year? ( timestamp -- ? )
year>> leap-year? ;
[ float>whole-part swapd days-per-year * +day swap +year ] unless-zero ;
: months/years ( n -- months years )
- 12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
+ 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 ;
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 )
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 ;
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 ;
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+)
+: (time+) ( timestamp duration -- timestamp' duration )
[ second>> +second ] keep
[ minute>> +minute ] keep
[ hour>> +hour ] keep
[ month>> +month ] keep
[ year>> +year ] keep ; inline
-: +slots [ bi@ + ] curry 2keep ; inline
+: +slots ( obj1 obj2 quot -- n obj1 obj2 )
+ [ bi@ + ] curry 2keep ; inline
PRIVATE>
GENERIC# time+ 1 ( time1 time2 -- time3 )
M: timestamp time+
- >r clone r> (time+) drop ;
+ [ clone ] dip (time+) drop ;
M: duration time+
dup timestamp? [
: (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
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 ;
#! 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 + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
+ [ 1 + 3 * 5 /i + ] keep 2 * +
+ ] dip 1 + + 7 mod ;
GENERIC: days-in-year ( obj -- n )
year leap-year? [
year month day <date>
year 3 1 <date>
- after=? [ 1+ ] when
+ after=? [ 1 + ] when
] when ;
: day-of-year ( timestamp -- n )
projects / factor.git / blobdiff