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