working on holiday names from timestamp

extra/calendar/holidays/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/calendar/holidays/canada/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/calendar/holidays/canada/canada-tests.factor

@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar.holidays calendar.holidays.canada kernel
+tools.test ;
+IN: calendar.holidays.canada.tests
+
+[ ] [ 2009 canada holidays drop ] unit-test

extra/calendar/holidays/canada/canada.factor

@@ -0,0 +1,11 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar calendar.holidays ;
+IN: calendar.holidays.canada
+
+SINGLETONS: canada canadian-federal ;
+
+HOLIDAY: canadian-thanksgiving-day october 2 monday-of-month ;
+HOLIDAY-NAME: canadian-thanksgiving-day canadian-federal "Thanksgiving Day"
+
+HOLIDAY-NAME: armistice-day commonwealth-of-nations "Remembrance Day"

extra/calendar/holidays/holidays.factor

@@ -0,0 +1,55 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar fry kernel parser sequences
+shuffle vocabs words memoize ;
+IN: calendar.holidays
+
+SINGLETONS: all world commonwealth-of-nations ;
+
+<<
+SYNTAX: HOLIDAY:
+    CREATE-WORD
+    dup "holiday" word-prop [
+        dup H{ } clone "holiday" set-word-prop
+    ] unless
+    parse-definition (( timestamp/n -- timestamp )) define-declared ;
+
+SYNTAX: HOLIDAY-NAME:
+    scan-word "holiday" word-prop scan-word scan-object spin set-at ;
+>>
+
+GENERIC: holidays ( n singleton -- seq )
+
+<PRIVATE
+
+: (holidays) ( singleton -- seq )
+    all-words swap '[ "holiday" word-prop _ swap key? ] filter ;
+
+M: object holidays
+    (holidays) [ execute( timestamp -- timestamp' ) ] with map ;
+
+PRIVATE>
+
+M: all holidays
+    drop
+    all-words [ "holiday" word-prop key? ] with filter ;
+
+: holiday? ( timestamp/n singleton -- ? )
+    [ holidays ] [ drop ] 2bi '[ _ same-day? ] any? ;
+
+: holiday-assoc ( timestamp/n singleton -- assoc )
+    [ >gmt midnight ] dip
+    [ dup (holidays) ] [ drop ] 2bi
+    '[ [ _ swap execute( ts -- ts' ) >gmt midnight ] keep ] { } map>assoc
+    rot '[ drop _ same-day? ] assoc-filter
+    values [ "holiday" word-prop at ] with map ;
+
+: holiday-name ( singleton word -- string/f )
+    "holiday" word-prop at ;
+
+: holiday-names ( timestamp/n singleton -- seq )
+    [ nip ] [ holiday-assoc ] 2bi
+    [ holiday-name ] with map ;
+
+HOLIDAY: armistice-day november 11 >>day ;
+HOLIDAY-NAME: armistice-day world "Armistice Day"

extra/calendar/holidays/us/us-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: calendar.holidays.us kernel sequences tools.test ;
+USING: calendar.holidays calendar.holidays.us kernel sequences
+tools.test ;
 IN: calendar.holidays.us.tests
 
 [ 10 ] [ 2009 us-federal holidays length ] unit-test
-[ ] [ 2009 canada holidays drop ] unit-test

extra/calendar/holidays/us/us.factor

@@ -1,29 +1,15 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs calendar combinators
-combinators.short-circuit fry kernel lexer math namespaces
-parser sequences shuffle vocabs words ;
+USING: accessors assocs calendar calendar.holidays
+calendar.holidays.private combinators combinators.short-circuit
+fry kernel lexer math namespaces parser sequences shuffle
+vocabs words ;
 IN: calendar.holidays.us
 
-SINGLETONS: world us us-federal canada commonwealth-of-nations ;
-
-<<
-SYNTAX: HOLIDAY:
-    CREATE-WORD
-    dup H{ } clone "holiday" set-word-prop
-    parse-definition (( timestamp/n -- timestamp )) define-declared ;
-
-SYNTAX: HOLIDAY-NAME:
-    scan-word "holiday" word-prop scan-word scan-object spin set-at ;
->>
-
-GENERIC: holidays ( n symbol -- seq )
+SINGLETONS: us us-federal ;
 
 <PRIVATE
 
-: (holidays) ( singleton -- seq )
-    all-words swap '[ "holiday" word-prop _ swap key? ] filter ;
-
 : adjust-federal-holiday ( timestamp -- timestamp' )
     {
         { [ dup saturday? ] [ 1 days time- ] }
@@ -31,18 +17,12 @@ GENERIC: holidays ( n symbol -- seq )
         [ ]
     } cond ;
 
+PRIVATE>
+
 M: us-federal holidays
     (holidays)
     [ execute( timestamp -- timestamp' ) adjust-federal-holiday ] with map ;
 
-M: object holidays
-    (holidays) [ execute( timestamp -- timestamp' ) ] with map ;
-
-PRIVATE>
-
-: holiday? ( timestamp/n singleton -- ? )
-    [ holidays ] [ drop ] 2bi '[ _ same-day? ] any? ;
-
 : us-post-office-open? ( timestamp -- ? )
     { [ sunday? not ] [ us-federal holiday? not ] } 1&& ;
 
@@ -71,17 +51,11 @@ HOLIDAY-NAME: labor-day us-federal "Labor Day"
 HOLIDAY: columbus-day october 2 monday-of-month ;
 HOLIDAY-NAME: columbus-day us-federal "Columbus Day"
 
-HOLIDAY: veterans-day november 11 >>day ;
-HOLIDAY-NAME: veterans-day us-federal "Veterans Day"
-HOLIDAY-NAME: veterans-day world "Armistice Day"
-HOLIDAY-NAME: veterans-day commonwealth-of-nations "Remembrance Day"
+HOLIDAY-NAME: armistice-day us-federal "Veterans Day"
 
 HOLIDAY: thanksgiving-day november 4 thursday-of-month ;
 HOLIDAY-NAME: thanksgiving-day us-federal "Thanksgiving Day"
 
-HOLIDAY: canadian-thanksgiving-day october 2 monday-of-month ;
-HOLIDAY-NAME: canadian-thanksgiving-day canada "Thanksgiving Day"
-
 HOLIDAY: christmas-day december 25 >>day ;
 HOLIDAY-NAME: christmas-day world "Christmas Day"
 HOLIDAY-NAME: christmas-day us-federal "Christmas Day"