factor: trim using lists

[factor.git] / extra / calendar / holidays / holidays.factor

diff --git a/extra/calendar/holidays/holidays.factor b/extra/calendar/holidays/holidays.factor
index 0b8a1bb781d4e94cf7954014502f439f496182b7..dc92086f29474cb8642ea2cab3fa44933c875ec8 100644 (file)
--- a/extra/calendar/holidays/holidays.factor
+++ b/extra/calendar/holidays/holidays.factor
@@ -1,52 +1,49 @@
 ! 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 ;
+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:
-    scan-word "holiday" word-prop scan-word scan-object spin 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 ;