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

diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor
index 256b4e1b424d1734a6e63baf2b511ae912c4768b..8d1071122d98f5c58bb214097f785a460311a6cf 100644 (file)
--- a/basis/calendar/calendar-tests.factor
+++ b/basis/calendar/calendar-tests.factor
@@ -1,5 +1,5 @@
 USING: arrays calendar kernel math sequences tools.test
-continuations system math.order threads ;
+continuations system math.order threads accessors ;
 IN: calendar.tests
 
 [ 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 swap after? ] 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

diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index 7a03fe44089323f929f406fd4a0e6001fa6ae35d..4b58b1b496b825302690c82dca6bbd9312d9189f 100644 (file)
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays classes.tuple combinators combinators.short-circuit
-    kernel locals math math.functions math.order namespaces sequences strings
-    summary system threads vocabs.loader ;
+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 )
@@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3
 :: 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 ;