1 ! Copyright (C) 2009 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators combinators.short-circuit
4 combinators.smart fry io.encodings.utf8 io.files kernel
5 math.parser math.statistics memoize namespaces sequences
6 splitting unicode.case calendar arrays ;
9 CONSTANT: zoneinfo-paths
11 "vocab:zoneinfo/africa"
12 "vocab:zoneinfo/antarctica"
14 "vocab:zoneinfo/australasia"
15 "vocab:zoneinfo/europe"
16 "vocab:zoneinfo/northamerica"
17 "vocab:zoneinfo/pacificnew"
18 "vocab:zoneinfo/solar87"
19 "vocab:zoneinfo/solar88"
20 "vocab:zoneinfo/solar89"
21 "vocab:zoneinfo/southamerica"
22 "vocab:zoneinfo/systemv"
23 "vocab:zoneinfo/leapseconds"
28 TUPLE: raw-zone name gmt-offset rules/save format until ;
29 TUPLE: raw-rule name from to type in on at-time save letters ;
30 TUPLE: raw-link from to ;
31 TUPLE: raw-leap year month day hms corr r/s ;
34 TUPLE: rule name from to at-time ;
38 : rule-to ( m string -- m n )
45 : raw-rule>rule ( raw-rule -- rule )
48 : parse-rule ( seq -- rule )
62 ] input<sequence raw-rule boa ;
64 : raw-zone>zone ( raw-zone -- zone )
67 : parse-zone ( seq -- zone )
74 } cleave raw-zone boa ;
76 : parse-partial-zone ( seq -- zone )
77 [ last-zone get name>> ] dip
83 } cleave raw-zone boa ;
85 : raw-link>link ( raw-link -- link )
88 : parse-link ( seq -- link )
95 ] input<sequence raw-link boa ;
97 : raw-leap>leap ( raw-leap -- leap )
100 : parse-leap ( seq -- link )
111 ] input<sequence raw-leap boa ;
113 : parse-line ( seq -- tuple )
116 { "zone" [ parse-zone dup last-zone set raw-zone>zone ] }
117 { "rule" [ parse-rule raw-rule>rule ] }
118 { "link" [ parse-link raw-link>link ] }
119 { "leap" [ parse-leap raw-leap>leap ] }
120 [ drop harvest parse-partial-zone ]
123 : parse-zoneinfo-file ( path -- seq )
125 [ "#" split1 drop ] map harvest
126 [ "\t " split harvest ] map harvest
127 [ [ parse-line ] map ] with-scope ;
129 MEMO: zoneinfo-files ( -- seq )
130 zoneinfo-paths [ parse-zoneinfo-file ] map ;
132 MEMO: zoneinfo-array ( -- seq )
133 zoneinfo-files concat ;
136 : raw-rule-map ( -- assoc )
137 zoneinfo-array [ raw-rule? ] filter [ name>> ] collect-by ;
139 : raw-zone-map ( -- assoc )
140 zoneinfo-array [ raw-zone? ] filter [ name>> ] collect-by ;
142 GENERIC: zone-matches? ( string rule -- ? )
144 M: raw-rule zone-matches? name>> = ;
145 M: raw-zone zone-matches? name>> = ;
146 M: raw-link zone-matches? from>> = ;
147 M: raw-leap zone-matches? 2drop f ;
149 : find-rules ( string -- rules )
151 [ [ to>> "max" = ] filter ] assoc-map at ;
153 ERROR: zone-not-found name ;
155 : find-zone ( string -- rules )
157 [ last ] assoc-map ?at [ zone-not-found ] unless ;
159 : find-zone-rules ( string -- zone rules )
160 find-zone dup rules/save>> find-rules ;
162 : number>value ( n -- n' )
170 : on>value ( n -- n' )
171 ! "3", "Thu>=8" always >=, "lastFri"
173 { [ dup 3 swap ?nth CHAR: > = ] [
174 3 cut 2 tail [ day-abbreviation3-predicate ] [ string>number ] bi* 2array
176 { [ dup "last" head? ] [ 4 tail day-abbreviation3-index ] }
180 : raw-rule>triple ( raw-rule -- quot )
182 [ from>> string>number ]
183 [ in>> month-abbreviation-index ]
187 ! "Europe/Helsinki" find-zone-rules
191 ! from - year or "min"
193 ! from "1938" or "min"
194 ! to "1945" or "max" or "only"
195 ! type "-" always "-"
196 ! in "Mar" -- 3-letter month name
197 ! on "26" or "Mon>=15" or lastSun lastFri
198 ! at "23:00s" "12:13:00s" "1:00s" "1:00u"
199 ! save "-0:00:05" "1:00" "0:14:15"
200 ! letters "S" or "-" or "AMT" "BDST"
203 ! name "Indian/Maldives"
204 ! gmt-offset "4:54:00" "9:55:56" "-9:55:56"
205 ! rules/save "-" "0:20" "0:30" "1:00" "AN" "W-Eur" "Winn" "Zion" "sol87" "sol88"
206 ! format "LMT" "%s" "%sT" "A%sT" "AC%sT" "ACT"
208 ! { "1847" "Dec" "1" "0:00s" }
209 ! { "1883" "Nov" "18" "12:12:57" }
210 ! { "1989" "Sep" "lastSun" "2:00s" }
213 ! T{ link { from "Asia/Riyadh88" } { to "Mideast/Riyadh88" } }