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