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 hashtables kernel
   4 parser sequences vocabs words ;
   5 IN: calendar.holidays
   6
   7 SINGLETONS: all world commonwealth-of-nations ;
   8
   9 <<
  10 SYNTAX: HOLIDAY:
  11     scan-new-word
  12     parse-definition ( timestamp/n -- timestamp ) define-declared ;
  13
  14 SYNTAX: HOLIDAY-NAME:
  15     scan-word "holiday" scan-word scan-object swap
  16     '[ _ _ rot ?set-at ] change-word-prop ;
  17 >>
  18
  19 GENERIC: holidays ( timestamp/n singleton -- seq )
  20
  21 <PRIVATE
  22
  23 : (holidays) ( singleton -- seq )
  24     all-words [ "holiday" word-prop key? ] with filter ;
  25
  26 M: object holidays
  27     (holidays) [ [ clone ] dip execute( timestamp -- timestamp ) ] with map ;
  28
  29 PRIVATE>
  30
  31 M: all holidays drop (holidays) ;
  32
  33 : holiday? ( timestamp/n singleton -- ? )
  34     [ holidays ] [ drop ] 2bi '[ _ same-day? ] any? ;
  35
  36 : holiday-assoc ( timestamp singleton -- assoc )
  37     (holidays) swap '[
  38         [ _ clone swap execute( timestamp -- timestamp ) ] keep
  39     ] { } map>assoc ;
  40
  41 : holiday-name ( singleton word -- string/f )
  42     "holiday" word-prop at ;
  43
  44 : holiday-names ( timestamp/n singleton -- seq )
  45     [
  46         [ clone ] dip
  47         [ drop ] [ holiday-assoc ] 2bi swap
  48         '[ drop _ same-day? ] assoc-filter values
  49     ] keep '[ _ swap "holiday" word-prop at ] map ;
  50
  51 HOLIDAY: armistice-day november 11 >>day ;
  52 HOLIDAY-NAME: armistice-day world "Armistice Day"