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 [L1 ] and [L2 ].
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