--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+! 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"
--- /dev/null
+! 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"
! 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
! 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- ] }
[ ]
} 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&& ;
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"