extra/metar/metar.factor

   1 ! Copyright (C) 2013 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3
   4 USING: accessors arrays ascii assocs calendar calendar.format
   5 combinators continuations csv formatting fry grouping
   6 http.client io io.encodings.ascii io.files io.styles kernel math
   7 math.extras math.parser memoize regexp sequences sorting.human
   8 splitting strings urls wrap.strings ;
   9
  10 IN: metar
  11
  12 TUPLE: station cccc name state country latitude longitude ;
  13
  14 C: <station> station
  15
  16 <PRIVATE
  17
  18 ERROR: bad-location str ;
  19
  20 : parse-location ( str -- n )
  21     "-" split dup length {
  22         { 3 [ first3 [ string>number ] tri@ 60.0 / + 60.0 / + ] }
  23         { 2 [ first2 [ string>number ] bi@ 60.0 / + ] }
  24         { 1 [ first string>number ] }
  25         [ drop bad-location ]
  26     } case ;
  27
  28 : string>longitude ( str -- lon/f )
  29     dup R/ \d+-\d+(-\d+(\.\d+)?)?[WE]/ matches? [
  30         unclip-last
  31         [ parse-location ]
  32         [ CHAR: W = [ neg ] when ] bi*
  33     ] [ drop f ] if ;
  34
  35 : string>latitude ( str -- lat/f )
  36     dup R/ \d+-\d+(-\d+(\.\d+)?)?[NS]/ matches? [
  37         unclip-last
  38         [ parse-location ]
  39         [ CHAR: S = [ neg ] when ] bi*
  40     ] [ drop f ] if ;
  41
  42 : stations-data ( -- seq )
  43     URL" http://weather.noaa.gov/data/nsd_cccc.txt"
  44     http-get nip CHAR: ; [ string>csv ] with-delimiter ;
  45
  46 PRIVATE>
  47
  48 MEMO: all-stations ( -- seq )
  49     stations-data [
  50         {
  51             [ 0 swap nth ]
  52             [ 3 swap nth ]
  53             [ 4 swap nth ]
  54             [ 5 swap nth ]
  55             [ 7 swap nth string>latitude ]
  56             [ 8 swap nth string>longitude ]
  57         } cleave <station>
  58     ] map ;
  59
  60 : find-by-cccc ( cccc -- station )
  61     all-stations swap '[ cccc>> _ = ] find nip ;
  62
  63 : find-by-country ( country -- stations )
  64     all-stations swap '[ country>> _ = ] filter ;
  65
  66 : find-by-state ( state -- stations )
  67     all-stations swap '[ state>> _ = ] filter ;
  68
  69 <PRIVATE
  70
  71 TUPLE: metar-report type station timestamp modifier wind
  72 visibility rvr weather sky-condition temperature dew-point
  73 altimeter remarks raw ;
  74
  75 CONSTANT: pressure-tendency H{
  76     { "0" "increasing then decreasing" }
  77     { "1" "increasing more slowly" }
  78     { "2" "increasing" }
  79     { "3" "increasing more quickly" }
  80     { "4" "steady" }
  81     { "5" "decreasing then increasing" }
  82     { "6" "decreasing more slowly" }
  83     { "7" "decreasing" }
  84     { "8" "decreasing more quickly" }
  85 }
  86
  87 CONSTANT: lightning H{
  88     { "CA" "cloud-air lightning" }
  89     { "CC" "cloud-cloud lightning" }
  90     { "CG" "cloud-ground lightning" }
  91     { "IC" "in-cloud lightning" }
  92 }
  93
  94 CONSTANT: weather H{
  95     { "BC" "patches" }
  96     { "BL" "blowing" }
  97     { "BR" "mist" }
  98     { "DR" "low drifting" }
  99     { "DS" "duststorm" }
 100     { "DU" "widespread dust" }
 101     { "DZ" "drizzle" }
 102     { "FC" "funnel clouds" }
 103     { "FG" "fog" }
 104     { "FU" "smoke" }
 105     { "FZ" "freezing" }
 106     { "GR" "hail" }
 107     { "GS" "small hail and/or snow pellets" }
 108     { "HZ" "haze" }
 109     { "IC" "ice crystals" }
 110     { "MI" "shallow" }
 111     { "PL" "ice pellets" }
 112     { "PO" "well-developed dust/sand whirls" }
 113     { "PR" "partial" }
 114     { "PY" "spray" }
 115     { "RA" "rain" }
 116     { "RE" "recent" }
 117     { "SA" "sand" }
 118     { "SG" "snow grains" }
 119     { "SH" "showers" }
 120     { "SN" "snow" }
 121     { "SQ" "squalls" }
 122     { "SS" "sandstorm" }
 123     { "TS" "thuderstorm" }
 124     { "UP" "unknown" }
 125     { "VA" "volcanic ash" }
 126 }
 127
 128 MEMO: glossary ( -- assoc )
 129     "vocab:metar/glossary.txt" ascii file-lines
 130     [ "," split1 ] H{ } map>assoc ;
 131
 132 : parse-glossary ( str -- str' )
 133     "/" split [
 134         find-numbers [
 135             dup number?
 136             [ number>string ]
 137             [ glossary ?at drop ] if
 138         ] map " " join
 139     ] map "/" join ;
 140
 141 : parse-timestamp ( str -- str' )
 142     [ now [ year>> ] [ month>> ] bi ] dip
 143     2 cut 2 cut 2 cut drop [ string>number ] tri@
 144     0 instant <timestamp> timestamp>rfc822 ;
 145
 146 CONSTANT: compass-directions H{
 147     { 0.0 "N" }
 148     { 22.5 "NNE" }
 149     { 45.0 "NE" }
 150     { 67.5 "ENE" }
 151     { 90.0 "E" }
 152     { 112.5 "ESE" }
 153     { 135.0 "SE" }
 154     { 157.5 "SSE" }
 155     { 180.0 "S" }
 156     { 202.5 "SSW" }
 157     { 225.0 "SW" }
 158     { 247.5 "WSW" }
 159     { 270.0 "W" }
 160     { 292.5 "WNW" }
 161     { 315.0 "NW" }
 162     { 337.5 "NNW" }
 163     { 360.0 "N" }
 164 }
 165
 166 : direction>compass ( direction -- compass )
 167     22.5 round-to-step compass-directions at ;
 168
 169 : parse-compass ( str -- str' )
 170     string>number [ direction>compass ] keep "%s (%s°)" sprintf ;
 171
 172 : parse-direction ( str -- str' )
 173     dup "VRB" = [ drop "variable" ] [
 174         parse-compass "from %s" sprintf
 175     ] if ;
 176
 177 : kt>mph ( kt -- mph ) 1.15077945 * ;
 178
 179 : mph>kt ( mph -- kt ) 1.15077945 / ;
 180
 181 : parse-speed ( str -- str'/f )
 182     string>number [
 183         dup kt>mph "%s knots (%.1f mph)" sprintf
 184     ] [ f ] if* ;
 185
 186 : parse-wind ( str -- str' )
 187     dup "00000KT" = [ drop "calm" ] [
 188         3 cut "KT" ?tail drop "G" split1
 189         [ parse-direction ] [ parse-speed ] [ parse-speed ] tri*
 190         [ "%s at %s with gusts to %s " sprintf ]
 191         [ "%s at %s" sprintf ] if*
 192     ] if ;
 193
 194 : parse-wind-variable ( str -- str' )
 195     "V" split1 [ parse-compass ] bi@
 196     ", variable from %s to %s" sprintf ;
 197
 198 : parse-visibility ( str -- str' )
 199     dup first {
 200         { CHAR: M [ rest "less than " ] }
 201         { CHAR: P [ rest "more than " ] }
 202         [ drop "" ]
 203     } case swap "SM" ?tail drop
 204     CHAR: / over index [ 1 > [ 1 cut "+" glue ] when ] when*
 205     string>number "%s%s statute miles" sprintf ;
 206
 207 : parse-rvr ( str -- str' )
 208     "R" ?head drop "/" split1 "FT" ?tail drop
 209     "V" split1 [
 210         [ string>number ] bi@
 211         "varying between %s and %s" sprintf
 212     ] [
 213         string>number "of %s" sprintf
 214     ] if* "runway %s visibility %s ft" sprintf ;
 215
 216 : (parse-weather) ( str -- str' )
 217     dup "+FC" = [ drop "tornadoes or waterspouts" ] [
 218         dup first {
 219             { CHAR: + [ rest "heavy " ] }
 220             { CHAR: - [ rest "light " ] }
 221             [ drop f ]
 222         } case [
 223             2 group dup [ weather key? ] all?
 224             [ [ weather at ] map " " join ]
 225             [ concat parse-glossary ] if
 226         ] dip prepend
 227     ] if ;
 228
 229 : parse-weather ( str -- str' )
 230     "VC" over subseq? [ "VC" "" replace t ] [ f ] if
 231     [ (parse-weather) ]
 232     [ [ " in the vicinity" append ] when ] bi* ;
 233
 234 : parse-altitude ( str -- str' )
 235     string>number " at %s00 ft" sprintf ;
 236
 237 CONSTANT: sky H{
 238     { "BKN" "broken" }
 239     { "FEW" "few" }
 240     { "OVC" "overcast" }
 241     { "SCT" "scattered" }
 242     { "SKC" "clear sky" }
 243     { "CLR" "clear sky" }
 244     { "NSC" "clear sky" }
 245
 246     { "ACC" "altocumulus castellanus" }
 247     { "ACSL" "standing lenticular altocumulus" }
 248     { "CCSL" "cirrocumulus standing lenticular cloud" }
 249     { "CU" "cumulus" }
 250     { "SC" "stratocumulus" }
 251     { "SCSL" "stratocumulus standing lenticular cloud" }
 252     { "TCU" "towering cumulus" }
 253 }
 254
 255 : parse-sky-condition ( str -- str' )
 256     sky ?at [
 257         3 cut 3 cut
 258         [ sky at ]
 259         [ parse-altitude ]
 260         [ sky at [ " (%s)" sprintf ] [ f ] if* ]
 261         tri* 3append
 262     ] unless ;
 263
 264 : F>C ( F -- C ) 32 - 5/9 * ;
 265
 266 : C>F ( C -- F ) 9/5 * 32 + ;
 267
 268 : parse-temperature ( str -- temp dew-point )
 269     "/" split1 [
 270         [ f ] [
 271             "M" ?head [ string>number ] [ [ neg ] when ] bi*
 272             dup C>F "%d °C (%.1f °F)" sprintf
 273         ] if-empty
 274     ] bi@ ;
 275
 276 : parse-altimeter ( str -- str' )
 277     unclip [ string>number ] [ CHAR: A = ] bi*
 278     [ 100 /f "%.2f Hg" sprintf ] [ "%s hPa" sprintf ] if ;
 279
 280 CONSTANT: re-timestamp R! \d{6}Z!
 281 CONSTANT: re-station R! \w{4}!
 282 CONSTANT: re-temperature R! [M]?\d{2}/([M]?\d{2})?!
 283 CONSTANT: re-wind R! (VRB|\d{3})\d{2,3}(G\d{2,3})?KT!
 284 CONSTANT: re-wind-variable R! \d{3}V\d{3}!
 285 CONSTANT: re-visibility R! [MP]?\d+(/\d+)?SM!
 286 CONSTANT: re-rvr R! R\d{2}[RLC]?/\d{4}(V\d{4})?FT!
 287 CONSTANT: re-weather R! [+-]?(VC)?(\w{2}|\w{4})!
 288 CONSTANT: re-sky-condition R! (\w{2,3}\d{3}(\w+)?|\w{3}|CAVOK)!
 289 CONSTANT: re-altimeter R! [AQ]\d{4}!
 290
 291 : find-one ( seq quot: ( elt -- ? ) -- seq elt/f )
 292     dupd find drop [ tail unclip ] [ f ] if* ; inline
 293
 294 : find-all ( seq quot: ( elt -- ? ) -- seq elts )
 295     [ find-one swap ] keep '[
 296         dup [ f ] [ first @ ] if-empty
 297     ] [ unclip ] produce rot [ prefix ] when* ; inline
 298
 299 : metar-body ( report seq -- report )
 300
 301     [ { "METAR" "SPECI" } member? ] find-one
 302     [ pick type<< ] when*
 303
 304     [ re-station matches? ] find-one
 305     [ pick station<< ] when*
 306
 307     [ re-timestamp matches? ] find-one
 308     [ parse-timestamp pick timestamp<< ] when*
 309
 310     [ { "AUTO" "COR" } member? ] find-one
 311     [ pick modifier<< ] when*
 312
 313     [ re-wind matches? ] find-one
 314     [ parse-wind pick wind<< ] when*
 315
 316     [ re-wind-variable matches? ] find-one
 317     [ parse-wind-variable pick wind>> prepend pick wind<< ] when*
 318
 319     [ re-visibility matches? ] find-one
 320     [ parse-visibility pick visibility<< ] when*
 321
 322     [ re-rvr matches? ] find-all " " join
 323     [ parse-rvr ] map ", " join pick rvr<<
 324
 325     [ re-weather matches? ] find-all
 326     [ parse-weather ] map ", " join pick weather<<
 327
 328     [ re-sky-condition matches? ] find-all
 329     [ parse-sky-condition ] map ", " join pick sky-condition<<
 330
 331     [ re-temperature matches? ] find-one
 332     [
 333         parse-temperature
 334         [ pick temperature<< ]
 335         [ pick dew-point<< ] bi*
 336     ] when*
 337
 338     [ re-altimeter matches? ] find-one
 339     [ parse-altimeter pick altimeter<< ] when*
 340
 341     drop ;
 342
 343 : signed-number ( sign value -- n )
 344     [ string>number ] bi@ swap zero? [ neg ] unless 10.0 / ;
 345
 346 : single-value ( str -- str' )
 347     1 cut signed-number ;
 348
 349 : double-value ( str -- m n )
 350     1 cut 3 cut [ signed-number ] dip 1 cut signed-number ;
 351
 352 : parse-1hr-temp ( str -- str' )
 353     "T" ?head drop dup length 4 > [
 354         double-value
 355         [ dup C>F "%.1f °C (%.1f °F)" sprintf ] bi@
 356         "hourly temperature %s and dew point %s" sprintf
 357     ] [
 358         single-value dup C>F
 359         "hourly temperature %.1f °C (%.1f °F)" sprintf
 360     ] if ;
 361
 362 : parse-6hr-max-temp ( str -- str' )
 363     "1" ?head drop single-value dup C>F
 364     "6-hour maximum temperature %.1f °C (%.1f °F)" sprintf ;
 365
 366 : parse-6hr-min-temp ( str -- str' )
 367     "2" ?head drop single-value dup C>F
 368     "6-hour minimum temperature %.1f °C (%.1f °F)" sprintf ;
 369
 370 : parse-24hr-temp ( str -- str' )
 371     "4" ?head drop double-value
 372     [ dup C>F "%.1f °C (%.1f °F)" sprintf ] bi@
 373     "24-hour maximum temperature %s minimum temperature %s"
 374     sprintf ;
 375
 376 : parse-1hr-pressure ( str -- str' )
 377     "5" ?head drop 1 cut single-value [ pressure-tendency at ] dip
 378     "hourly pressure %s %s hPa" sprintf ;
 379
 380 : parse-snow-depth ( str -- str' )
 381     "4/" ?head drop string>number "snow depth %s inches" sprintf ;
 382
 383 CONSTANT: low-clouds H{
 384     { 1 "cumulus (fair weather)" }
 385     { 2 "cumulus (towering)" }
 386     { 3 "cumulonimbus (no anvil)" }
 387     { 4 "stratocumulus (from cumulus)" }
 388     { 5 "stratocumuls (not cumulus)" }
 389     { 6 "stratus or Fractostratus (fair)" }
 390     { 7 "fractocumulus / fractostratus (bad weather)" }
 391     { 8 "cumulus and stratocumulus" }
 392     { 9 "cumulonimbus (thunderstorm)" }
 393     { -1 "not valid" }
 394 }
 395
 396 CONSTANT: mid-clouds H{
 397     { 1 "altostratus (thin)" }
 398     { 2 "altostratus (thick)" }
 399     { 3 "altocumulus (thin)" }
 400     { 4 "altocumulus (patchy)" }
 401     { 5 "altocumulus (thickening)" }
 402     { 6 "altocumulus (from cumulus)" }
 403     { 7 "altocumulus (with altocumulus, altostratus, nimbostratus)" }
 404     { 8 "altocumulus (with turrets)" }
 405     { 9 "altocumulus (chaotic)" }
 406     { -1 "above overcast" }
 407 }
 408
 409 CONSTANT: high-clouds H{
 410     { 1 "cirrus (filaments)" }
 411     { 2 "cirrus (dense)" }
 412     { 3 "cirrus (often with cumulonimbus)" }
 413     { 4 "cirrus (thickening)" }
 414     { 5 "cirrus / cirrostratus (low in sky)" }
 415     { 6 "cirrus / cirrostratus (hi in sky)" }
 416     { 7 "cirrostratus (entire sky)" }
 417     { 8 "cirrostratus (partial)" }
 418     { 9 "cirrocumulus or cirrocumulus / cirrus / cirrostratus" }
 419     { -1 "above overcast" }
 420 }
 421
 422 : parse-cloud-cover ( str -- str' )
 423     "8/" ?head drop first3 [ CHAR: 0 - ] tri@
 424     [ [ f ] [ low-clouds at "low clouds are %s" sprintf ] if-zero ]
 425     [ [ f ] [ mid-clouds at "middle clouds are %s" sprintf ] if-zero ]
 426     [ [ f ] [ high-clouds at "high clouds are %s" sprintf ] if-zero ]
 427     tri* 3array " " join ;
 428
 429 : parse-inches ( str -- str' )
 430     dup [ CHAR: / = ] all? [ drop "unknown" ] [
 431         string>number
 432         [ "trace" ] [ 100 /f "%.2f inches" sprintf ] if-zero
 433     ] if ;
 434
 435 : parse-1hr-precipitation ( str -- str' )
 436     "P" ?head drop parse-inches
 437     "%s precipitation in last hour" sprintf ;
 438
 439 : parse-6hr-precipitation ( str -- str' )
 440     "6" ?head drop parse-inches
 441     "%s precipitation in last 6 hours" sprintf ;
 442
 443 : parse-24hr-precipitation ( str -- str' )
 444     "7" ?head drop parse-inches
 445     "%s precipitation in last 24 hours" sprintf ;
 446
 447 ! XXX: "on the hour" instead of "00 minutes past the hour" ?
 448
 449 : parse-recent-time ( str -- str' )
 450     dup length 2 >
 451     [ 2 cut ":" glue ]
 452     [ " minutes past the hour" append ] if ;
 453
 454 : parse-peak-wind ( str -- str' )
 455     "/" split1 [ parse-wind ] [ parse-recent-time ] bi*
 456     "%s occuring at %s" sprintf ;
 457
 458 : parse-sea-level-pressure ( str -- str' )
 459     "SLP" ?head drop string>number 10.0 /f 1000 +
 460     "sea-level pressure is %s hPa" sprintf ;
 461
 462 : parse-lightning ( str -- str' )
 463     "LTG" ?head drop 2 group [ lightning at ] map " " join ;
 464
 465 CONSTANT: re-recent-weather R! ((\w{2})?[BE]\d{2,4}((\w{2})?[BE]\d{2,4})?)+!
 466
 467 : parse-began/ended ( str -- str' )
 468     unclip swap
 469     [ CHAR: B = "began" "ended" ? ]
 470     [ parse-recent-time ] bi* "%s at %s" sprintf ;
 471
 472 : split-recent-weather ( str -- seq )
 473     [ dup empty? not ] [
 474         dup [ digit? ] find drop
 475         over [ digit? not ] find-from drop
 476         [ cut ] [ f ] if* swap
 477     ] produce nip ;
 478
 479 : (parse-recent-weather) ( str -- str' )
 480     dup [ digit? ] find drop 2 > [
 481         2 cut [ weather at " " append ] dip
 482     ] [ f swap ] if parse-began/ended "" append-as ;
 483
 484 : parse-recent-weather ( str -- str' )
 485     split-recent-weather
 486     [ (parse-recent-weather) ] map " " join ;
 487
 488 : parse-varying ( str -- str' )
 489     "V" split1 [ string>number ] bi@
 490     "varying between %s00 and %s00 ft" sprintf ;
 491
 492 : parse-from-to ( str -- str' )
 493     "-" split [ parse-glossary ] map " to " join ;
 494
 495 : parse-water-equivalent-snow ( str -- str' )
 496     "933" ?head drop parse-inches
 497     "%s water equivalent of snow on ground" sprintf ;
 498
 499 : parse-duration-of-sunshine ( str -- str' )
 500     "98" ?head drop string>number
 501     [ "no" ] [ "%s minutes of" sprintf ] if-zero
 502     "%s sunshine" sprintf ;
 503
 504 : parse-6hr-snowfall ( str -- str' )
 505     "931" ?head drop parse-inches
 506     "%s snowfall in last 6 hours" sprintf ;
 507
 508 : parse-probability ( str -- str' )
 509     "PROB" ?head drop string>number
 510     "probability of %d%%" sprintf ;
 511
 512 : parse-remark ( str -- str' )
 513     {
 514         { [ dup glossary key? ] [ glossary at ] }
 515         { [ dup R! 1\d{4}! matches? ] [ parse-6hr-max-temp ] }
 516         { [ dup R! 2\d{4}! matches? ] [ parse-6hr-min-temp ] }
 517         { [ dup R! 4\d{8}! matches? ] [ parse-24hr-temp ] }
 518         { [ dup R! 4/\d{3}! matches? ] [ parse-snow-depth ] }
 519         { [ dup R! 5\d{4}! matches? ] [ parse-1hr-pressure ] }
 520         { [ dup R! 6[\d/]{4}! matches? ] [ parse-6hr-precipitation ] }
 521         { [ dup R! 7\d{4}! matches? ] [ parse-24hr-precipitation ] }
 522         { [ dup R! 8/\d{3}! matches? ] [ parse-cloud-cover ] }
 523         { [ dup R! 931\d{3}! matches? ] [ parse-6hr-snowfall ] }
 524         { [ dup R! 933\d{3}! matches? ] [ parse-water-equivalent-snow ] }
 525         { [ dup R! 98\d{3}! matches? ] [ parse-duration-of-sunshine ] }
 526         { [ dup R! T\d{4,8}! matches? ] [ parse-1hr-temp ] }
 527         { [ dup R! \d{3}\d{2,3}/\d{2,4}! matches? ] [ parse-peak-wind ] }
 528         { [ dup R! P\d{4}! matches? ] [ parse-1hr-precipitation ] }
 529         { [ dup R! SLP\d{3}! matches? ] [ parse-sea-level-pressure ] }
 530         { [ dup R! LTG\w+! matches? ] [ parse-lightning ] }
 531         { [ dup R! PROB\d+! matches? ] [ parse-probability ] }
 532         { [ dup R! \d{3}V\d{3}! matches? ] [ parse-varying ] }
 533         { [ dup R! [^-]+(-[^-]+)+! matches? ] [ parse-from-to ] }
 534         { [ dup R! [^/]+(/[^/]+)+! matches? ] [ ] }
 535         { [ dup R! \d+.\d+! matches? ] [ ] }
 536         { [ dup re-recent-weather matches? ] [ parse-recent-weather ] }
 537         { [ dup re-weather matches? ] [ parse-weather ] }
 538         { [ dup re-sky-condition matches? ] [ parse-sky-condition ] }
 539         [ parse-glossary ]
 540     } cond ;
 541
 542 : metar-remarks ( report seq -- report )
 543     [ parse-remark ] map " " join >>remarks ;
 544
 545 : <metar-report> ( metar -- report )
 546     [ metar-report new ] dip [ >>raw ] keep
 547     [ blank? ] split-when { "RMK" } split1
 548     [ metar-body ] [ metar-remarks ] bi* ;
 549
 550 : row. ( name quot -- )
 551     '[
 552         [ _ write ] with-cell
 553         [ @ [ 65 wrap-string write ] when* ] with-cell
 554     ] with-row ; inline
 555
 556 : metar-report. ( report -- )
 557     standard-table-style [
 558         {
 559             [ "Station" [ station>> ] row. ]
 560             [ "Timestamp" [ timestamp>> ] row. ]
 561             [ "Wind" [ wind>> ] row. ]
 562             [ "Visibility" [ visibility>> ] row. ]
 563             [ "RVR" [ rvr>> ] row. ]
 564             [ "Weather" [ weather>> ] row. ]
 565             [ "Sky condition" [ sky-condition>> ] row. ]
 566             [ "Temperature" [ temperature>> ] row. ]
 567             [ "Dew point" [ dew-point>> ] row. ]
 568             [ "Altimeter" [ altimeter>> ] row. ]
 569             [ "Remarks" [ remarks>> ] row. ]
 570             [ "Raw Text" [ raw>> ] row. ]
 571         } cleave
 572     ] tabular-output nl ;
 573
 574 PRIVATE>
 575
 576 GENERIC: metar ( station -- metar )
 577
 578 M: station metar cccc>> metar ;
 579
 580 M: string metar
 581     "http://weather.noaa.gov/pub/data/observations/metar/stations/%s.TXT"
 582     sprintf http-get nip ;
 583
 584 GENERIC: metar. ( station -- )
 585
 586 M: station metar. cccc>> metar. ;
 587
 588 M: string metar.
 589     [ metar <metar-report> metar-report. ]
 590     [ drop "%s METAR not found\n" printf ] recover ;
 591
 592 <PRIVATE
 593
 594 : parse-wind-shear ( str -- str' )
 595     "WS" ?head drop "/" split1
 596     [ parse-altitude ] [ parse-wind ] bi* prepend
 597     "wind shear " prepend ;
 598
 599 CONSTANT: re-from-timestamp R! FM\d{6}!
 600
 601 : parse-from-timestamp ( str -- str' )
 602     "FM" ?head drop parse-timestamp ;
 603
 604 CONSTANT: re-valid-timestamp R! \d{4}\/\d{4}!
 605
 606 : parse-valid-timestamp ( str -- str' )
 607     "/" split1 [ "00" append parse-timestamp ] bi@ " to " glue ;
 608
 609 TUPLE: taf-report station timestamp valid-timestamp wind
 610 visibility rvr weather sky-condition partials raw ;
 611
 612 TUPLE: taf-partial from-timestamp wind visibility rvr weather
 613 sky-condition raw ;
 614
 615 : taf-body ( report str -- report )
 616     [ blank? ] split-when
 617
 618     [ { "AMD" "COR" "RTD" } member? ] find-one drop
 619
 620     [ re-station matches? ] find-one
 621     [ pick station<< ] when*
 622
 623     [ re-timestamp matches? ] find-one
 624     [ parse-timestamp pick timestamp<< ] when*
 625
 626     [ re-valid-timestamp matches? ] find-one
 627     [ parse-valid-timestamp pick valid-timestamp<< ] when*
 628
 629     [ re-wind matches? ] find-one
 630     [ parse-wind pick wind<< ] when*
 631
 632     [ re-wind-variable matches? ] find-one
 633     [ parse-wind-variable pick wind>> prepend pick wind<< ] when*
 634
 635     [ re-visibility matches? ] find-one
 636     [ parse-visibility pick visibility<< ] when*
 637
 638     [ re-rvr matches? ] find-all " " join
 639     [ parse-rvr ] map ", " join pick rvr<<
 640
 641     [ re-weather matches? ] find-all
 642     [ parse-weather ] map ", " join pick weather<<
 643
 644     [ re-sky-condition matches? ] find-all
 645     [ parse-sky-condition ] map ", " join pick sky-condition<<
 646
 647     drop ;
 648
 649 : <taf-partial> ( str -- partial )
 650     [ taf-partial new ] dip [ blank? ] split-when
 651
 652     [ re-from-timestamp matches? ] find-one
 653     [ parse-from-timestamp pick from-timestamp<< ] when*
 654
 655     [ re-wind matches? ] find-one
 656     [ parse-wind pick wind<< ] when*
 657
 658     [ re-wind-variable matches? ] find-one
 659     [ parse-wind-variable pick wind>> prepend pick wind<< ] when*
 660
 661     [ re-visibility matches? ] find-one
 662     [ parse-visibility pick visibility<< ] when*
 663
 664     [ re-rvr matches? ] find-all " " join
 665     [ parse-rvr ] map ", " join pick rvr<<
 666
 667     [ re-weather matches? ] find-all
 668     [ parse-weather ] map ", " join pick weather<<
 669
 670     [ re-sky-condition matches? ] find-all
 671     [ parse-sky-condition ] map ", " join pick sky-condition<<
 672
 673     drop ;
 674
 675 : taf-partials ( report seq -- report )
 676     [ <taf-partial> ] map >>partials ;
 677
 678 : <taf-report> ( taf -- report )
 679     [ taf-report new ] dip [ >>raw ] keep
 680     string-lines [ [ blank? ] trim ] map
 681     rest dup first "TAF" = [ rest ] when
 682     harvest unclip taf-body taf-partials ;
 683
 684 : taf-report. ( report -- )
 685     [
 686         standard-table-style [
 687             {
 688                 [ "Station" [ station>> ] row. ]
 689                 [ "Timestamp" [ timestamp>> ] row. ]
 690                 [ "Valid From" [ valid-timestamp>> ] row. ]
 691                 [ "Wind" [ wind>> ] row. ]
 692                 [ "Visibility" [ visibility>> ] row. ]
 693                 [ "RVR" [ rvr>> ] row. ]
 694                 [ "Weather" [ weather>> ] row. ]
 695                 [ "Sky condition" [ sky-condition>> ] row. ]
 696                 [ "Raw Text" [ raw>> ] row. ]
 697             } cleave
 698         ] tabular-output nl
 699     ] [
 700         partials>> [
 701             standard-table-style [
 702                 {
 703                     [ "From" [ from-timestamp>> ] row. ]
 704                     [ "Wind" [ wind>> ] row. ]
 705                     [ "Visibility" [ visibility>> ] row. ]
 706                     [ "RVR" [ rvr>> ] row. ]
 707                     [ "Weather" [ weather>> ] row. ]
 708                     [ "Sky condition" [ sky-condition>> ] row. ]
 709                 } cleave
 710             ] tabular-output nl
 711         ] each
 712     ] bi ;
 713
 714 PRIVATE>
 715
 716 GENERIC: taf ( station -- taf )
 717
 718 M: station taf cccc>> taf ;
 719
 720 M: string taf
 721     "http://weather.noaa.gov/pub/data/forecasts/taf/stations/%s.TXT"
 722     sprintf http-get nip ;
 723
 724 GENERIC: taf. ( station -- )
 725
 726 M: station taf. cccc>> taf. ;
 727
 728 M: string taf.
 729     [ taf <taf-report> taf-report. ]
 730     [ drop "%s TAF not found\n" printf ] recover ;