! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs calendar fry kernel locals parser
-sequences vocabs words memoize ;
+USING: accessors assocs calendar hashtables kernel
+parser sequences vocabs words ;
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 ;
+ scan-new-word
+ parse-definition ( timestamp/n -- timestamp ) define-declared ;
SYNTAX: HOLIDAY-NAME:
- [let scan-word "holiday" word-prop :> holidays scan-word :> name scan-object :> value
- value name holidays set-at ] ;
+ scan-word "holiday" scan-word scan-object swap
+ '[ _ _ rot ?set-at ] change-word-prop ;
>>
-GENERIC: holidays ( n singleton -- seq )
+GENERIC: holidays ( timestamp/n singleton -- seq )
<PRIVATE
: (holidays) ( singleton -- seq )
- all-words swap '[ "holiday" word-prop _ swap key? ] filter ;
+ all-words [ "holiday" word-prop key? ] with filter ;
M: object holidays
- (holidays) [ execute( timestamp -- timestamp' ) ] with map ;
+ (holidays) [ [ clone ] dip execute( timestamp -- timestamp ) ] with map ;
PRIVATE>
-M: all holidays
- drop
- all-words [ "holiday" word-prop key? ] with filter ;
+M: all holidays drop (holidays) ;
: holiday? ( timestamp/n singleton -- ? )
[ holidays ] [ drop ] 2bi '[ _ same-day? ] any? ;
: holiday-assoc ( timestamp singleton -- assoc )
- (holidays) swap
- '[ [ _ swap execute( ts -- ts' ) >gmt midnight ] keep ] { } map>assoc ;
+ (holidays) swap '[
+ [ _ clone swap execute( timestamp -- timestamp ) ] keep
+ ] { } map>assoc ;
: holiday-name ( singleton word -- string/f )
"holiday" word-prop at ;
: holiday-names ( timestamp/n singleton -- seq )
[
- [ >gmt midnight ] dip
+ [ clone ] dip
[ drop ] [ holiday-assoc ] 2bi swap
'[ drop _ same-day? ] assoc-filter values
] keep '[ _ swap "holiday" word-prop at ] map ;