extra/zoneinfo/zoneinfo.factor

   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 ;
   7 IN: zoneinfo
   8
   9 CONSTANT: zoneinfo-paths
  10 {
  11     "vocab:zoneinfo/africa"
  12     "vocab:zoneinfo/antarctica"
  13     "vocab:zoneinfo/asia"
  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"
  24 }
  25
  26 SYMBOL: last-zone
  27
  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 ;
  32
  33 TUPLE: zone name ;
  34 TUPLE: rule name from to at-time ;
  35 TUPLE: link ;
  36 TUPLE: leap ;
  37
  38 : rule-to ( m string -- m n )
  39     {
  40         { "only" [ dup ] }
  41         { "max" [ 1/0. ] }
  42         [ string>number ]
  43     } case ;
  44
  45 : raw-rule>rule ( raw-rule -- rule )
  46     ;
  47
  48 : parse-rule ( seq -- rule )
  49     [
  50         {
  51             [ drop ]
  52             [ ]
  53             [ ]
  54             [ ]
  55             [ ]
  56             [ ]
  57             [ ]
  58             [ ]
  59             [ ]
  60             [ ]
  61         } spread
  62     ] input<sequence raw-rule boa ;
  63
  64 : raw-zone>zone ( raw-zone -- zone )
  65     ;
  66
  67 : parse-zone ( seq -- zone )
  68     {
  69         [ second ]
  70         [ third ]
  71         [ fourth ]
  72         [ 4 swap nth ]
  73         [ 5 tail harvest ]
  74     } cleave raw-zone boa ;
  75
  76 : parse-partial-zone ( seq -- zone )
  77     [ last-zone get name>> ] dip
  78     {
  79         [ first ]
  80         [ second ]
  81         [ 2 swap nth ]
  82         [ 3 tail harvest ]
  83     } cleave raw-zone boa ;
  84
  85 : raw-link>link ( raw-link -- link )
  86     ;
  87
  88 : parse-link ( seq -- link )
  89     [
  90         {
  91             [ drop ]
  92             [ ]
  93             [ ]
  94         } spread
  95     ] input<sequence raw-link boa ;
  96
  97 : raw-leap>leap ( raw-leap -- leap )
  98     ;
  99
 100 : parse-leap ( seq -- link )
 101     [
 102         {
 103             [ drop ]
 104             [ ]
 105             [ ]
 106             [ ]
 107             [ ]
 108             [ ]
 109             [ ]
 110         } spread
 111     ] input<sequence raw-leap boa ;
 112
 113 : parse-line ( seq -- tuple )
 114     dup first >lower
 115     {
 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 ]
 121     } case ;
 122
 123 : parse-zoneinfo-file ( path -- seq )
 124     utf8 file-lines
 125     [ "#" split1 drop ] map harvest
 126     [ "\t " split harvest ] map harvest
 127     [ [ parse-line ] map ] with-scope ;
 128
 129 MEMO: zoneinfo-files ( -- seq )
 130     zoneinfo-paths [ parse-zoneinfo-file ] map ;
 131
 132 MEMO: zoneinfo-array ( -- seq )
 133     zoneinfo-files concat ;
 134
 135
 136 : raw-rule-map ( -- assoc )
 137     zoneinfo-array [ raw-rule? ] filter [ name>> ] collect-by ;
 138
 139 : raw-zone-map ( -- assoc )
 140     zoneinfo-array [ raw-zone? ] filter [ name>> ] collect-by ;
 141
 142 GENERIC: zone-matches? ( string rule -- ? )
 143
 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 ;
 148
 149 : find-rules ( string -- rules )
 150     raw-rule-map
 151     [ [ to>> "max" = ] filter ] assoc-map at ;
 152
 153 ERROR: zone-not-found name ;
 154
 155 : find-zone ( string -- rules )
 156     raw-zone-map
 157     [ last ] assoc-map ?at [ zone-not-found ] unless ;
 158
 159 : find-zone-rules ( string -- zone rules )
 160     find-zone dup rules/save>> find-rules ;
 161
 162 : number>value ( n -- n' )
 163     {
 164         { "only" [ f ] }
 165         { "min" [ f ] }
 166         { "max" [ t ] }
 167         [ string>number ]
 168     } case ;
 169
 170 : on>value ( n -- n' )
 171     ! "3", "Thu>=8" always >=, "lastFri"
 172     {
 173         { [ dup 3 swap ?nth CHAR: > = ] [
 174             3 cut 2 tail [ day-abbreviation3-predicate ] [ string>number ] bi* 2array
 175         ] }
 176         { [ dup "last" head? ] [ 4 tail day-abbreviation3-index ] }
 177         [ string>number ]
 178     } cond ;
 179
 180 : raw-rule>triple ( raw-rule -- quot )
 181     {
 182         [ from>> string>number ]
 183         [ in>> month-abbreviation-index ]
 184         [ on>> on>value ]
 185     } cleave>array ;
 186
 187 ! "Europe/Helsinki" find-zone-rules
 188
 189 ! Rule
 190 ! name - string
 191 ! from - year or "min"
 192 ! name    "France"
 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"
 201
 202 ! Zone
 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"
 207 ! until      { "1880" }
 208     ! { "1847" "Dec" "1" "0:00s" }
 209     ! { "1883" "Nov" "18" "12:12:57" }
 210     ! { "1989" "Sep" "lastSun" "2:00s" }
 211
 212 ! Link
 213 ! T{ link { from "Asia/Riyadh88" } { to "Mideast/Riyadh88" } }