extra/calendar/holidays/holidays.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs calendar fry kernel locals parser
   4 sequences vocabs words memoize ;
   5 IN: calendar.holidays
   6
   7 SINGLETONS: all world commonwealth-of-nations ;
   8
   9 <<
  10 SYNTAX: HOLIDAY:
  11     scan-new-word
  12     dup "holiday" word-prop [
  13         dup H{ } clone "holiday" set-word-prop
  14     ] unless
  15     parse-definition ( timestamp/n -- timestamp ) define-declared ;
  16
  17 SYNTAX: HOLIDAY-NAME:
  18     [let scan-word "holiday" word-prop :> holidays scan-word :> name scan-object :> value
  19     value name holidays set-at ] ;
  20 >>
  21
  22 GENERIC: holidays ( n singleton -- seq )
  23
  24 <PRIVATE
  25
  26 : (holidays) ( singleton -- seq )
  27     all-words swap '[ "holiday" word-prop _ swap key? ] filter ;
  28
  29 M: object holidays
  30     (holidays) [ execute( timestamp -- timestamp' ) ] with map ;
  31
  32 PRIVATE>
  33
  34 M: all holidays
  35     drop
  36     all-words [ "holiday" word-prop key? ] with filter ;
  37
  38 : holiday? ( timestamp/n singleton -- ? )
  39     [ holidays ] [ drop ] 2bi '[ _ same-day? ] any? ;
  40
  41 : holiday-assoc ( timestamp singleton -- assoc )
  42     (holidays) swap
  43     '[ [ _ swap execute( ts -- ts' ) >gmt midnight ] keep ] { } map>assoc ;
  44
  45 : holiday-name ( singleton word -- string/f )
  46     "holiday" word-prop at ;
  47
  48 : holiday-names ( timestamp/n singleton -- seq )
  49     [
  50         [ >gmt midnight ] dip
  51         [ drop ] [ holiday-assoc ] 2bi swap
  52         '[ drop _ same-day? ] assoc-filter values
  53     ] keep '[ _ swap "holiday" word-prop at ] map ;
  54
  55 HOLIDAY: armistice-day november 11 >>day ;
  56 HOLIDAY-NAME: armistice-day world "Armistice Day"