Delete empty unit tests files, remove 1- and 1+, reorder IN: lines in a lot of places...

[factor.git] / basis / calendar / calendar.factor

diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index 522e0c52f34e11b3dd0574aa0fb7b55569f7b23d..81bcff03c1524c7bb99584909ed3a8e11b52111f 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: 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 )
@@ -39,29 +39,31 @@ M: not-a-month summary
     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 )
     {
@@ -70,17 +72,17 @@ PRIVATE>
 
 : 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
@@ -92,26 +94,50 @@ PRIVATE>
 :: 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 ;
@@ -134,7 +160,7 @@ PRIVATE>
 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? ;
@@ -170,7 +196,7 @@ M: real +year ( timestamp n -- timestamp )
     [ 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 [ >>month ] dip +year ] unless-zero ;
@@ -345,10 +371,10 @@ M: duration time-
     #! http://web.textfiles.com/computers/formulas.txt
     #! good for any date since October 15, 1582
     [
-        dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
-        [ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
-        [ 1+ 3 * 5 /i + ] keep 2 * +
-    ] dip 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 )
 
@@ -369,7 +395,7 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
     year leap-year? [
         year month day <date>
         year 3 1 <date>
-        after=? [ 1+ ] when
+        after=? [ 1 + ] when
     ] when ;
 
 : day-of-year ( timestamp -- n )