steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

use new locals syntax in calendar, add routine for calculating easter

db4
Doug Coleman 2009-04-25 21:21:15 -05:00
parent 3f764fc872
commit bada2176bc
2 changed files with 52 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/calendar/calendar-tests.factor
View File

@ -1,5 +1,5 @@
USING: arrays calendar kernel math sequences tools.test USING: arrays calendar kernel math sequences tools.test
continuations system math.order threads ; continuations system math.order threads accessors ;
IN: calendar.tests IN: calendar.tests
[ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test [ f ] [ 2004 12 32 0 0 0 instant <timestamp> valid-timestamp? ] unit-test
@ -163,3 +163,10 @@ IN: calendar.tests
[ t ] [ now 50 milliseconds sleep now before? ] unit-test [ t ] [ now 50 milliseconds sleep now before? ] unit-test
[ t ] [ now 50 milliseconds sleep now swap after? ] unit-test [ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
[ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test [ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test
[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test
[ f ] [ now dup midnight eq? ] unit-test
[ f ] [ now dup easter eq? ] unit-test
[ f ] [ now dup beginning-of-year eq? ] unit-test

64
basis/calendar/calendar.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.tuple combinators combinators.short-circuit USING: accessors arrays classes.tuple combinators
kernel locals math math.functions math.order namespaces sequences strings combinators.short-circuit kernel locals math math.functions
summary system threads vocabs.loader ; math.order sequences summary system threads vocabs.loader ;
IN: calendar IN: calendar
HOOK: gmt-offset os ( -- hours minutes seconds ) HOOK: gmt-offset os ( -- hours minutes seconds )
@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3
:: julian-day-number ( year month day -- n ) :: julian-day-number ( year month day -- n )
#! Returns a composite date number #! Returns a composite date number
#! Not valid before year -4800 #! Not valid before year -4800
[let* | a [ 14 month - 12 /i ] 14 month - 12 /i :> a
y [ year 4800 + a - ] year 4800 + a - :> y
m [ month 12 a * + 3 - ] | 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 #! Inverse of julian-day-number
[let* | a [ n 32044 + ] n 32044 + :> a
b [ 4 a * 3 + 146097 /i ] 4 a * 3 + 146097 /i :> b
c [ a 146097 b * 4 /i - ] a 146097 b * 4 /i - :> c
d [ 4 c * 3 + 1461 /i ] 4 c * 3 + 1461 /i :> d
e [ c 1461 d * 4 /i - ] c 1461 d * 4 /i - :> e
m [ 5 e * 2 + 153 /i ] | 5 e * 2 + 153 /i :> m
100 b * d + 4800 -
m 10 /i + m 3 + 100 b * d + 4800 -
12 m 10 /i * - m 10 /i + m 3 +
e 153 m * 2 + 5 /i - 1+ 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 ) : >date< ( timestamp -- year month day )
[ year>> ] [ month>> ] [ day>> ] tri ; [ year>> ] [ month>> ] [ day>> ] tri ;