[Keith Vetter] 2007-01-23 : The National Oceanic and Atmospheric Administration (NOAA)
has a some nice web services providing current weather conditions and forecasts. 
For details on some of those services, check out [http://www.weather.gov/forecasts/xml/]
and [http://www.weather.gov/forecasts/xml/SOAP_server/ndfdSOAPByDay.htm].

Here's a little program that gets the weather forecast for
a given latitude and longitude. It parses the SOAP reply and displays
the result. 


----
 ##+##########################################################################
 #
 # noaa.tcl -- Displays weather forecast from NOAA
 # by Keith Vetter, Januayr 2007
 #
 
 package require Tk
 package require http
 package require tdom
 package require Img
 if {! [catch {package require tile}]} {
    namespace import -force ::ttk::button
 }
 
 # http://www.erh.noaa.gov/forecast/MapClick.php?CityName=Granville&state=OH&site=ILN
 # http://www.weather.gov/forecasts/xml/SOAP_server/ndfdSOAPByDay.htm
 # http://www.weather.gov/forecasts/xml/SOAP_server/ndfdSOAPclientByDay.php?lat=40.05&lon=-82.50&format=24+hourly&startDate=2007-01-22&numDays=7&Submit=Submit
 
 set S(url) http://www.weather.gov/forecasts/xml/SOAP_server/ndfdSOAPclientByDay.php
 set S(format) 12+hourly
 set S(days) 5
 
 proc GetNOAA {lat lon} {
    global doc root xml
 
    set xml [GetForecastXML $lat $lon]
 
    set n [catch {dom parse $xml doc}]
    if {$n} {
        tk_messageBox -icon error -message "Bad reply from NOAA"
        return 0
    }
    set root [$doc documentElement]
    ReadTimeLayouts $root
    GetIcons $root
    GetTemperatures $root
    GetPrecipitation $root
    GetWeather $root
 
    unset doc
    return 1
 }
 proc GetForecastXML {lat lon} {
    set startdate [clock format [clock scan now] -format "%Y-%m-%d"]
    set url $::S(url)
    append url "?lat=$lat&lon=$lon&format=$::S(format)&startDate=$startdate"
    append url "&numDays=$::S(days)&Submit=Submit"
    set ::URL $url
 
    set token [::http::geturl $url]
    ::http::wait $token
    set xml [::http::data $token] ; list
    ::http::cleanup $token
 
    return $xml
 }
 
 proc ReadTimeLayouts {root} {
    global WEATHER
 
    unset -nocomplain WEATHER
 
    set nodes [$root selectNodes /dwml/data/time-layout]
    foreach node $nodes {
        set key [[$node selectNodes layout-key/text()] data]
        set WEATHER($key,summary) [$node getAttribute summarization "???"]
 
        set starts [$node selectNodes start-valid-time]
        set ends [$node selectNodes end-valid-time]
        set cnt -1
        foreach start $starts end $ends {
            incr cnt
 
            set name [$start getAttribute period-name "???"]
            set stime [[$start firstChild] data]
            set etime [[$end firstChild] data]
 
            set WEATHER($key,$cnt,name) $name
            set WEATHER($key,$cnt,start) $stime
            set WEATHER($key,$cnt,end) $etime
        }
    }
 }
 
 proc GetIcons {root} {
    set node [$root selectNodes /dwml/data/parameters/conditions-icon]
    set key [$node getAttribute time-layout]
    set ::WEATHER(icon,key) $key
 
    set cnt -1
    foreach icon [$node selectNodes icon-link/text()] {
        incr cnt
        set ::WEATHER($key,$cnt,icon) [$icon data]
    }
 }
 
 proc GetTemperatures {root} {
    global WEATHER
 
    array unset WEATHER *temp*
    set nodes [$root selectNodes /dwml/data/parameters/temperature]
    foreach node $nodes {
        set type [$node getAttribute type]
        set units [$node getAttribute units]
        set key [$node getAttribute time-layout]
        set WEATHER(temp,$type,key) $key
        set WEATHER(temp,$type,units) $units
 
        set cnt -1
        foreach value [$node selectNodes value/text()] {
            incr cnt
            set WEATHER($key,$cnt,temp,$type) [$value data]
        }
    }
 }
 proc GetPrecipitation {root} {
    global WEATHER
 
    array unset WEATHER *rain*
    set node [$root selectNodes /dwml/data/parameters/probability-of-precipitation]
 
    set units [$node getAttribute units]
    set key [$node getAttribute time-layout]
    set WEATHER(rain,key) $key
    set WEATHER(rain,units) $units
 
    set cnt -1
    foreach value [$node selectNodes value/text()] {
        incr cnt
        set WEATHER($key,$cnt,rain) [$value data]
    }
 }
 proc GetWeather {root} {
    global WEATHER
 
    array unset WEATHER *weather*
    set node [$root selectNodes /dwml/data/parameters/weather]
 
    set key [$node getAttribute time-layout]
    set WEATHER(weather,key) $key
 
    set cnt -1
    foreach value [$node selectNodes weather-conditions] {
        incr cnt
        set WEATHER($key,$cnt,weather,summary) [$value getAttribute weather-summary]
    }
 }
 
 proc DoDisplay {} {
    wm title . "NOAA Weather Forecast"
 
    bind all <F2> {console show}
    frame .w -bd 2 -relief ridge
    frame .ctrl -bd 2 -relief ridge -pady 5 -padx 30
 
    pack .w -side top -fill both -expand 1
    pack .ctrl -side bottom -fill x
 
    label .ctrl.llat -text "Latitude" -anchor e
    entry .ctrl.elat -textvariable ::S(lat) -width 10 \
        -validate key -vcmd {string is double %P}
    label .ctrl.llon -text "Longitude" -anchor e
    entry .ctrl.elon -textvariable ::S(lon) -width 10 \
        -validate key -vcmd {string is double %P}
    label .ctrl.ldays -text "Days" -anchor e
    spinbox .ctrl.sbox -from 1 -to 7 -textvariable ::S(days) -width 7 \
        -justify c -state readonly
    .ctrl.sbox config -readonlybackground [.ctrl.sbox cget -bg]
    button .submit -text "Submit" -command Submit
 
    grid .ctrl.llat .ctrl.elat x .submit -pady 2 -sticky ew
    grid .ctrl.llon .ctrl.elon x ^ -pady 2 -sticky ew
    grid .ctrl.ldays .ctrl.sbox x ^ -pady 2 -sticky ew
    grid columnconfigure .ctrl 2 -minsize 30
 
    eval destroy [winfo child .w]
    label .w.icon -image ::img::noaa
    label .w.title1 -text "NOAA" -font {Times 32 bold}
    label .w.title2 -text "Weather Forecast" -font {Times 28 bold}
 
    grid .w.icon .w.title1
    grid .w.title2 - -sticky ew -padx 10
    grid config .w.icon -padx {30 0}
    grid columnconfigure .w 1 -weight 1
 }
 image create photo ::img::noaa -data {
    R0lGODlhNwA6ALMAACQybBSKtIzW9Eyy1DRGfHSCrJzy/ASe1FRilPwCBIyexPT+/Jy63CSaxMTa
    9CxKlCH5BAEAAAkALAAAAAA3ADoAAwT/MMlJq7046827/2AojmRpnmiqrmzrvqXDMEpdKIwDazJC
    /IBg8IfI7SgOxSP4IDyeUCAAodDtlAAndMtdAh6MlwPR7Jq3vwfCqmL4tOd4k1BsI75mePQ8DZ/G
    eFAIZFmDRG9qZVBZbCRugXQODgtFC5QKlgUFCzKBAAVGJZYLBV9OCJQMBWMzqjg0VU5OOaOilkk/
    kQQ0rFWTM5wOc5ijCyTFmUQLDw6rRTiv0A4EU8gyI8iZU6ygkqCaMwVrPwzIAw2NHdm3dz5kdO2n
    dHSf1g0BAiHA2dPU/llPZD3JsquYgHMBBoAw0KBSNgWm5ATcVGxAgAMHGhj4wDBAQgPZ/+5IXEJg
    kiUD5xqo1MixAcYGDEAWeyQnCDFLKV+y9GDg4gGPMZEx8Ndl3pqTCDFm3Nmhp8ufDQZkGwqQCzVi
    KAM81bmRp1alGQXIHDWG6Jx6Cw76BKuya9OtSj9aU/BGCEUGHsEqbQtCpd6lAvipohJTwD2/f/l+
    OPzXI8yx6wxIFvD3pcIQXysffuUAsoGDAypjDOCnL1y9HgNQMWmAQcrTbBuMsCga4wCxJw8ehg02
    4QjDtQ+InZw0+N7SIWgHv5fZ+OjLJBCL5r0cpgngzrO/RB6duvbYKpR/r+x7hfjxe6GvWOlds1b1
    LNSuNe7x9pHWFpvrZW79yITPr/G3kh19/l0g2WcCJChZgQw26OCDEEYo4YQUVmjhhSxEAAA7}
 
 proc DisplayWeather {} {
    global WEATHER
 
    set W .w
    label $W.tmp
    set font "[$W.tmp cget -font] bold"
    eval destroy [winfo child $W]
 
    set key $WEATHER(weather,key)
    foreach arr [lsort -dictionary [array names WEATHER $key,*,weather,summary]] {
        set id [lindex [split $arr ","] 1]
        set id2 [expr {$id/2}]
 
        set WF $W.col$id
        frame $WF -bd 2 -relief ridge
        label $WF.name -text $WEATHER($key,$id,name) -font $font
        label $WF.icon -image [GetIcon $WEATHER($key,$id,icon)] -relief ridge
 
        set key2 $WEATHER(temp,maximum,key)
        set key3 $WEATHER(temp,minimum,key)
        set txt "$WEATHER($key3,$id2,temp,minimum)\xB0 - $WEATHER($key2,$id2,temp,maximum)\xB0"
        append txt "\n$WEATHER($key,$id,rain)%"
        append txt "\n$WEATHER($key,$id,weather,summary)"
        label $WF.txt -text $txt -wraplength 100
 
        grid $WF -row 0 -column $id -sticky news
        grid columnconfigure $W $id -uniform a
        eval pack [winfo child $WF] -side top
        update
    }
 }
 proc GetIcon {url} {
    set sname [file rootname [file tail $url]]
    set iname ::img::$sname
    if {[lsearch [image names] $iname] == -1} {
        image create photo $iname -width 55 -height 58
        $iname copy ::img::noaa
        set token [::http::geturl $url -command [list GetIcon_Callback $iname]]
    }
 
    return $iname
 }
 proc GetIcon_Callback {iname token} {
    set ncode [::http::ncode $token]
 
    if {[::http::ncode $token] != 200} {
        error "bad http ncode for $iname"
    } else {
        $iname config -data [::http::data $token]
    }
    ::http::cleanup $token
 }
 proc Submit {} {
    set n [GetNOAA $::S(lat) $::S(lon)]
    if {$n} DisplayWeather
 }
 
 foreach {S(lat) S(lon)} {40.0731923 -82.5146661} break
 DoDisplay
 return
----

[Category Application]