diff --git a/extra/calendar/holidays/authors.txt b/extra/calendar/holidays/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/calendar/holidays/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/calendar/holidays/canada/authors.txt b/extra/calendar/holidays/canada/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/calendar/holidays/canada/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/calendar/holidays/canada/canada-tests.factor b/extra/calendar/holidays/canada/canada-tests.factor new file mode 100644 index 0000000000..916f5ee9ab --- /dev/null +++ b/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 diff --git a/extra/calendar/holidays/canada/canada.factor b/extra/calendar/holidays/canada/canada.factor new file mode 100644 index 0000000000..304388fe4b --- /dev/null +++ b/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" diff --git a/extra/calendar/holidays/holidays.factor b/extra/calendar/holidays/holidays.factor new file mode 100644 index 0000000000..a50c709cf5 --- /dev/null +++ b/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 ) + + + +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" diff --git a/extra/calendar/holidays/us/us-tests.factor b/extra/calendar/holidays/us/us-tests.factor index 995d1ff561..23ab535e98 100644 --- a/extra/calendar/holidays/us/us-tests.factor +++ b/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 diff --git a/extra/calendar/holidays/us/us.factor b/extra/calendar/holidays/us/us.factor index 2d66ec5468..a4fb19c597 100644 --- a/extra/calendar/holidays/us/us.factor +++ b/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 ; + 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"