Keith Vetter 2003-01-15 - I got sick of Yahoo maps being too small so I wrote this program that grabs neighboring maps and tiles them in the window letting you build up a larger, more complete map of an area.
You first supply a zoom level and either a latitude, longitude or a street and city address and TkMapper goes out to Yahoo and grabs that map. It then determines what the latitude/longitude offsets are to the neighboring maps [surprisingly, these offsets vary depending on map location], and then grabs and tiles the 8 surrounding maps. You can then click on North, South, East or West buttons to extend the map.
At any time you can enter and map a new location (alternatively, double clicking anywhere on the map loads in that location into the new map form).
Vince -- this looks great! I found one small bug -- if you zoom out a long way, alaska and canada don't match up with the rest of the USA properly....
#+##########################################################################
#
# TkMapper -- extracts neighboring maps from Yahoo and tiles them for you
# by Keith Vetter, January 2003
#
package require Tk
package require http 2.0
set pname TkMapper
set version 1.0
##+##########################################################################
#
# Init -- creates a blank canvas w/ all variables reset
#
proc Init {} {
if {[winfo exists .c]} {
.c delete all
.over delete all
.sb_x set 0 1
.sb_y set 0 1
foreach img [image names] {
if {[string match map* $img]} {image delete $img}
}
.c create text 0 0 -tag title -text $::pname -anchor s -font {Times 72}
.c create text 0 50 -tag title -font {Times 24} -text "by Keith Vetter"
.c create text 0 100 -tag title -font {Times 12} \
-text "loading center image..."
set h [expr {[winfo height .c] / 2.0}] ;# Recenter display
set w [expr {[winfo width .c] / 2.0}]
if {$h > 1} {
.c config -scrollregion [list -$w -$h $w $h]
}
}
set ::want 0 ;# Count of outstanding requests
catch {unset ::mapInfo}
array set ::mapInfo {minX 0 maxX 0 minY 0 maxY 0}
set ::overview(bbox) 0
set ::delta(cx) 400 ;# Screen offset between maps
set ::delta(cy) 400 ;# try 365 to remove map scale
set ::delta(cy) 365 ;# try 365 to remove map scale
}
##+##########################################################################
#
# DoDisplay -- sets up the GUI display
#
proc DoDisplay {} {
raise .
wm title . $::pname
wm protocol . WM_DELETE_WINDOW exit
frame .ctrl -bd 2 -relief ridge
frame .maps
frame .info
pack .ctrl -side right -fill y
pack .info -side bottom -fill x
pack .maps -side left -fill both -expand 1
label .w -textvariable WANT -anchor w -width 15 -relief ridge
label .l -textvariable INFO -anchor c -relief ridge
canvas .c -width 800 -height 800 -highlightthickness 0 -takefocus 1
.c config -scrollregion [list -400 -400 400 400]
.c config -yscrollcommand {MyScroller y .sb_y}
.c config -xscrollcommand {MyScroller x .sb_x}
.c config -bd 2 -relief ridge
bind .c <1> {focus .c}
bind .c <Double-1> [list canvas2pos %W %x %y]
bind .c <2> [bind Text <2>]
bind .c <B2-Motion> [bind Text <B2-Motion>]
set mw {%W yview scroll [expr {- (%D / 120) * 1}] units}
regsub yview $mw xview mw2
bind .c <MouseWheel> $mw
bind .c <Shift-MouseWheel> $mw2
scrollbar .sb_x -command {.c xview} -orient horizontal
scrollbar .sb_y -command {.c yview} -orient vertical
grid .c .sb_y -in .maps -row 0 -sticky news
grid .sb_x -in .maps -sticky ew
grid rowconfigure .maps 0 -weight 1
grid columnconfigure .maps 0 -weight 1
pack .w -in .info -side left
pack .l -in .info -side left -expand 1 -fill x
focus .c
DoControls
bind all <Alt-c> {console show}
update
.c config -scrollregion {}
return
}
##+##########################################################################
#
# DoControls -- displays GUI for the control panel
#
proc DoControls {} {
# Overview window
frame .fover -bd 2 -relief ridge
label .lover -text "Overview"
canvas .over -width 204 -height 204 -highlightthickness 0 -takefocus 0
.over config -bd 0 -bg gray50
bind .over <Button-1> [list OverviewX %W %x %y down]
bind .over <B1-Motion> [list OverviewX %W %x %y move]
bind .over <ButtonRelease-1> [list OverviewX %W %x %y done]
bind .over <Button-2> [list OverviewX %W %x %y down]
bind .over <B2-Motion> [list OverviewX %W %x %y move]
bind .over <ButtonRelease-2> [list OverviewX %W %x %y done]
.over xview moveto 0; .over yview moveto 0
grid .over -in .fover -row 0
grid .lover -in .fover
button .bn -text N -command {GoDir N}
button .be -text E -command {GoDir E}
button .bw -text W -command {GoDir W}
button .bs -text S -command {GoDir S}
frame .fnew -bd 2 -relief ridge
grid rowconfigure .ctrl 0 -minsize 5 ;# Top spacing
grid .fover - - - - -in .ctrl -row 1 -sticky ew -padx 10 -pady 10
grid rowconfigure .ctrl 50 -minsize 10 ;# Spacing
grid x x .bn x x -in .ctrl -row 51
grid x .bw x .be x -in .ctrl
grid x x .bs x x -in .ctrl
grid rowconfigure .ctrl 60 -minsize 10 ;# Spacing
grid rowconfigure .ctrl 100 -weight 1 ;# Push everything to top
grid columnconfigure .ctrl {0 4} -weight 1 ;# Push everything to right
grid .fnew - - - - -in .ctrl -row 100 -stick news
# FNEW pane
label .new -text "New Maps" -font "[.lover cget -font] bold"
label .llat -text "Latitude:"
entry .elat -textvariable UI(mlt)
label .llong -text "Longitude:"
entry .elong -textvariable UI(mln)
label .lzoom1 -text "Zoom:"
tk_optionMenu .ezoom1 UI(zoom1) 1 2 3 4 5 6 7 8 9 10
button .getmap1 -text "Get Map" -command {GetNewMap 1}
label .lstreet -text "Street:"
entry .estreet -textvariable UI(addr)
label .lcity -text "City:"
entry .ecity -textvariable UI(csz)
label .lzoom2 -text "Zoom:"
tk_optionMenu .ezoom2 UI(zoom2) 1 2 3 4 5 6 7 8 9 10
button .getmap2 -text "Get Map" -command {GetNewMap 2}
grid .new - - - -in .fnew -row 0
grid rowconfigure .fnew 1 -minsize 10
grid .llat .elat - - -in .fnew -row 10
grid .llong .elong - - -in .fnew
grid .lzoom1 .ezoom1 - - -in .fnew -sticky ew
grid .getmap1 - - - -in .fnew -pady 10
grid rowconfigure .fnew 20 -minsize 50
grid .lstreet .estreet - - -in .fnew -row 21
grid .lcity .ecity - - -in .fnew
grid .lzoom2 .ezoom2 - - -in .fnew -sticky ew
grid .getmap2 - - - -in .fnew -pady 10
grid rowconfigure .fnew 100 -weight 1
catch {image create photo ::img::blank -width 1 -height 1}
button .about -image ::img::blank -command About -highlightthickness 0
place .about -in .fnew -relx 1 -rely 1 -anchor se
}
##+##########################################################################
#
# MyScroller -- catches scroll requests so we can update overview window
#
proc MyScroller {xy w top bottom} {
$w set $top $bottom ;# Call the scrollbar
DoOverview ;# Update overview window
}
##+##########################################################################
#
# GoDir -- gets new maps on specified edge.
#
proc GoDir {dir} {
global mapInfo delta
if {! [info exists delta(dx)]} return
if {$dir == "E" || $dir == "W"} {
if {$dir == "E"} {
set x [expr {$mapInfo(maxX) + 1}]
} else {
set x [expr {$mapInfo(minX) - 1}]
}
for {set y $mapInfo(minY)} {$y <= $mapInfo(maxY)} {incr y} {
GetMapDelta $x $y
}
} else { ;# North/south
if {$dir == "N"} {
set y [expr {$mapInfo(minY) - 1}]
} else {
set y [expr {$mapInfo(maxY) + 1}]
}
for {set x $mapInfo(minX)} {$x <= $mapInfo(maxX)} {incr x} {
GetMapDelta $x $y
}
}
}
##+##########################################################################
#
# INFO -- prints out information messages
#
proc INFO {msg} {
#puts stderr $msg
set ::INFO $msg
update
}
proc ERROR {msg} {
tk_messageBox -icon error -title "$::pname Error" -message $msg
}
##+##########################################################################
#
# GetRootMap -- Gets the center map, computes deltas then gets
# neighboring cells.
#
proc GetRootMap {mlt mln} {
global want
Init ;# Erase everything
GetMapAt $mlt $mln 0 0 ;# Get center map
while {1} {
vwait want
if {$want == 0} break
}
.c delete title
ComputeDeltas $mlt $mln
# Get all neighboring cells
#GetMapDelta 0 -1 0 1 -1 0 1 0 -1 -1 1 -1 -1 1 1 1
GetMapDelta -1 -1 0 -1 1 -1 -1 0 1 0 -1 1 0 1 1 1
}
##+##########################################################################
#
# ComputeDeltas -- computes how many lat/long units the map image is.
#
# This varies per location so we ask Yahoo for this info by simulating
# a mouse click exactly one image unit away.
#
proc ComputeDeltas {mlt mln} {
global delta mag
foreach w [list .bn .be .bs .bw] { $w config -state disabled }
INFO "Computing map offsets"
SetWantInfo 1
set xurl "http://maps.yahoo.com/py/maps.py?Pyt=Tmap&slt=0&sln=0"
append xurl "&mlt=$mlt&mln=$mln&mag=$mag&city=abc"
append xurl "&map.x=599&map.y=599"
set token [::http::geturl $xurl]
set data [::http::data $token]
::http::cleanup $token
SetWantInfo -1
set n1 [regexp {mlt=([-0-9.]+)} $data => mlt2]
set n2 [regexp {mln=([-0-9.]+)} $data => mln2]
if {! $n1 || ! $n2} {
ERROR "can't get map to compute deltas"
return
}
set delta(dx,$mag) [expr {$mln2 - $mln}]
set delta(dy,$mag) [expr {$mlt2 - $mlt}]
set delta(dx) [expr {$delta(dx,$mag) * $delta(cx) / 400.0}]
set delta(dy) [expr {$delta(dy,$mag) * $delta(cy) / 400.0}]
foreach w [list .bn .be .bs .bw] { $w config -state normal }
INFO "Computing map offsets: $delta(dx,$mag), $delta(dy,$mag)"
}
##+##########################################################################
#
# GetMapAt -- gets the map at lat, long and puts it onto the canvas at x,y
#
proc GetMapAt {mlt mln x y} {
global mag mapInfo
SetWantInfo 2
SetMapInfo $x $y $mlt $mln
INFO "Want $x, $y ($mlt $mln)"
set xurl http://maps.yahoo.com/py/maps.py?Pyt=Tmap&slt=0&sln=0
append xurl &mlt=$mlt&mln=$mln&mag=$mag
append xurl &city=abc&ds=n
set mapInfo(url,$x,$y) $xurl
#INFO "url is $xurl"
::http::geturl $xurl -command [list GotMapPage $x $y]
}
##+##########################################################################
#
# GetMapDelta -- like GetMapAt but lat, long is derived from units from
# the image at 0,0.
#
proc GetMapDelta {args} {
global mapInfo delta
if ![info exists mapInfo(0,0)] {
ERROR "missing root map"
return
}
foreach {mlt0 mln0} $mapInfo(0,0) break
foreach {dx dy} $args {
set mlt1 [expr {$mlt0 + $dy * $delta(dy)}]
set mln1 [expr {$mln0 + $dx * $delta(dx)}]
GetMapAt $mlt1 $mln1 $dx $dy
}
}
##+##########################################################################
#
# GotMapPage -- callback when a map page is gotten. Extracts the GIF
# info and requests that page.
#
proc GotMapPage {x y token} {
global mapInfo
INFO "got map page for $x $y"
SetWantInfo -1
set data [::http::data $token]
::http::cleanup $token
set n [regexp -- {name="map"[^>]+src="([^ ]*)"} $data {} url]
if {$n} {
set mapInfo(gifurl,$x,$y) $url
::http::geturl $url -command [list GotMapGif $x $y]
} else {
ERROR "couln't get map for cell $x $y"
SetWantInfo -1
}
}
##+##########################################################################
#
# GotMapGif -- callback when a GIF map image is gotten.
#
proc GotMapGif {x y token} {
global delta mapInfo ;# Canvas deltas
SetWantInfo -1
INFO "got map gif for $x $y"
set mapInfo(done,$x,$y) 1
set gif [::http::data $token]
::http::cleanup $token
set id "${x}_$y"
image create photo ::map::$id
::map::$id put $gif
set xx [expr {$x * $delta(cx)}] ;# This is were it goes
set xy [expr {$y * $delta(cy)}]
set tag "c,$x,$y"
.c create image $xx $xy -image ::map::$id -tag $tag
#.c create rect [.c bbox $tag] -tag [list $tag frill]
#.c create text $xx $xy -text "$x $y" -font {{MS Sans Serif} 16 bold} \
# -tag [list $tag frill]
#.c lower frill
RaiseMaps $x $y
OverviewCell $x $y
update
.c config -scrollregion [Expand [.c bbox all] 20]
}
##+##########################################################################
#
# RaiseMaps -- when we have overlap, make sure the correct image is on top
#
proc RaiseMaps {x y} {
global mapInfo delta
RaiseMapsAll
return
set me "c,$x,$y"
if {$delta(cy) != 400} { ;# Fix up vertical overlap
set y1 [expr {$y - 1}]
set y2 [expr {$y + 1}]
RaiseMap2 $me "c,$x,$y1"
RaiseMap2 "c,$x,$y2" $me
}
if {$delta(cx) != 400} {
RaiseMap2 $me "c,[expr {$x + 1}],$y"
RaiseMap2 "c,[expr {$x - 1}],$y" $me
}
#.c lower frill
}
proc RaiseMap2 {m1 m2} {
if {[llength [.c find withtag $m1]] == 0} return
if {[llength [.c find withtag $m2]] == 0} return
.c raise $m1 $m2
}
proc RaiseMapsAll {} {
global mapInfo delta
if {$delta(cy) == 400 && $delta(cx) == 400} return
for {set x $mapInfo(minX)} {$x <= $mapInfo(maxX)} {incr x} {
for {set y $mapInfo(maxY)} {$y >= $mapInfo(minY)} {incr y -1} {
.c lower c,$x,$y
}
}
.c lower frill
}
##+##########################################################################
#
# SetMapInfo -- updates global data on which maps have been read in.
#
proc SetMapInfo {x y mlt mln} {
global mapInfo
set mapInfo($x,$y) [list $mlt $mln]
if {$x < $mapInfo(minX)} { set mapInfo(minX) $x }
if {$x > $mapInfo(maxX)} { set mapInfo(maxX) $x }
if {$y < $mapInfo(minY)} { set mapInfo(minY) $y }
if {$y > $mapInfo(maxY)} { set mapInfo(maxY) $y }
}
##+##########################################################################
#
# SetWantInfo -- gives some GUI information on outstanding HTTP requests.
#
proc SetWantInfo {dw} {
global want WANT
incr want $dw
if {$want} { ;# Waiting for some pages
.w config -fg red
set WANT "Want: $want page"
if {$WANT != 1} {append WANT "s"}
} else {
.w config -fg SystemButtonText
set WANT "Done"
}
}
##+##########################################################################
#
# DoOverview -- updates viewport on the overview window
#
proc DoOverview {} {
global mapInfo overview
if {! [winfo exists .over]} return
set bbox [.c bbox all]
if {[llength $bbox] != 4} return
foreach {left top right bottom} $bbox break
set width [expr {$right - $left}]
set height [expr {$bottom - $top}]
# Create the grid here
if {[string compare $bbox $overview(bbox)]} { ;# Did size change
if {$width > $height} {
set scale [expr {200.0 / $width}]
} else {
set scale [expr {200.0 / $height}]
}
.over delete outline
set x2 [expr {2 + $width * $scale}]
set y2 [expr {2 + $height * $scale}]
.over create rectangle 2 2 $x2 $y2 -outline black -width 3 \
-tag outline -fill [.c cget -bg]
set overview(r) [list 2 2 $x2 $y2]
set x_ticks [expr {$mapInfo(maxX) - $mapInfo(minX) + 1}]
set y_ticks [expr {$mapInfo(maxY) - $mapInfo(minY) + 1}]
set xstep [expr {$width * $scale / $x_ticks}]
set ystep [expr {$height * $scale / $y_ticks}]
for {set i 1} {$i < $x_ticks} {incr i} {
set x [expr {2 + $i * $xstep}]
.over create line $x 2 $x $y2 -tag {grid outline} -dash 1
}
for {set i 1} {$i < $y_ticks} {incr i} {
set y [expr {2 + $i * $ystep}]
.over create line 2 $y $x2 $y -tag {grid outline} -dash 1
}
set overview(bbox) $bbox ;# Determines if things changed
set overview(scale) $scale
set overview(xstep) $xstep
set overview(ystep) $ystep
}
# Now draw the viewport
.over delete view
set scale $overview(scale)
foreach {left right} [.c xview] break
set x1 [expr {2 + $width * $scale * $left}]
set x2 [expr {2 + $width * $scale * $right}]
foreach {top bottom} [.c yview] break
set y1 [expr {2 + $height * $scale * $top}]
set y2 [expr {2 + $height * $scale * $bottom}]
.over create rectangle $x1 $y1 $x2 $y2 -outline blue -width 2 -tag view
set overview(v) [list $x1 $y1 $x2 $y2]
OverviewCell
}
proc OverviewCell {args} {
global mapInfo
if {[llength $args] == 0} {
set args [array names mapInfo done,*]
regsub -all {done|,} $args " " args
}
foreach {x y} $args {
set tag "${x}_$y"
set xy [OverviewCellXY $x $y]
.over delete $tag
.over create rect $xy -tag $tag -fill beige -outline beige
}
.over raise grid
.over raise view
}
proc OverviewCellXY {x y} {
global mapInfo overview
set dx [expr {$x - $mapInfo(minX)}]
set dy [expr {$y - $mapInfo(minY)}]
set l [expr {2 + 1 + $dx * $overview(xstep)}]
set t [expr {2 + 1 + $dy * $overview(ystep)}]
set r [expr {-2 + $l + $overview(xstep)}]
set b [expr {-2 + $t + $overview(ystep)}]
return [list $l $t $r $b]
}
##+##########################################################################
#
# OverviewX -- handles mousing in the overview window. It moves the
# view box to follow the cursor.
#
proc OverviewX {W x y what} {
global overview
if {$what == "done"} {
$W config -cursor {}
focus .c
return
}
if {![info exists overview(r)]} return
if {![info exists overview(v)]} return
focus $W
$W config -cursor dotbox
set px [$W canvasx $x] ;# Convert into canvas coords
set py [$W canvasy $y]
foreach {rl rt rr rb} $overview(r) break ;# Region box
foreach {vl vt vr vb} $overview(v) break ;# View box
set vw2 [expr {($vr - $vl) / 2.0}] ;# View width & height
set vh2 [expr {($vb - $vt) / 2.0}]
# Now constrain box to be w/i the region box
set nl [expr {$px - $vw2}]
set nr [expr {$px + $vw2}]
if {$nl < $rl} {
set d [expr {$nl - $rl}]
set nl [expr {$nl - $d}]
set nr [expr {$nr - $d}]
} elseif {$nr > $rr} {
set d [expr {$nr - $rr}]
set nl [expr {$nl - $d}]
set nr [expr {$nr - $d}]
}
set nt [expr {$py - $vh2}]
set nb [expr {$py + $vh2}]
if {$nt < $rt} {
set d [expr {$nt - $rt}]
set nt [expr {$nt - $d}]
set nb [expr {$nb - $d}]
} elseif {$nb > $rb} {
set d [expr {$nb - $rb}]
set nt [expr {$nt - $d}]
set nb [expr {$nb - $d}]
}
# Create the new view box
$W delete view
$W create rectangle $nl $nt $nr $nb -outline blue \
-tag view -width 2
set overview(v2) [list $nl $nt $nr $nb]
OverviewLink $nl $nt
}
##+##########################################################################
#
# OverviewLink -- scrolls the main canvas so that it matches the
# overview view box
#
proc OverviewLink {vl vt} {
global overview
foreach {rl rt rr rb} $overview(r) break
set rw [expr {double($rr - $rl)}]
set rh [expr {double($rb - $rt)}]
set l [expr { ($vl - $rl) / $rw}]
set t [expr { ($vt - $rt) / $rh}]
.c yview moveto $t
.c xview moveto $l
}
##+##########################################################################
#
# Expand -- grows a box by delta amount
#
proc Expand {xy delta} {
foreach {a b c d} $xy break
incr a -$delta ; incr b -$delta ; incr c $delta ; incr d $delta
return [list $a $b $c $d]
}
##+##########################################################################
#
# canvas2pos -- converts a canvas position into lat/long
#
proc canvas2pos {W X Y} {
global mapInfo delta mag mln UI
if {$W != ".c"} return
focus .c
set x [$W canvasx $X]
set y [$W canvasy $Y]
# Point (0, 0) is at (lat,long) = $mapInfo(0,0)
foreach {lat long} $mapInfo(0,0) break
set UI(mlt) [expr {$lat + $y * $delta(dy) / 400}]
set UI(mln) [expr {$long + $x * $delta(dx) / 400}]
}
##+##########################################################################
#
# GetNewMap -- remapping with a new root map based on the form values.
#
proc GetNewMap {how} {
global UI mag
if {$how == 2} { ;# By address
set UI(addr) [string trim $UI(addr)]
set UI(csz) [string trim $UI(csz)]
if {$UI(csz) == ""} return
Init
set url "http://maps.yahoo.com/py/maps.py?"
append url [::http::formatQuery addr $UI(addr) csz $UI(csz)]
INFO "fetching $url"
set token [::http::geturl $url]
set data [::http::data $token]
::http::cleanup $token
set n1 [regexp {slt=([-0-9.]+)} $data => slt]
set n2 [regexp {sln=([-0-9.]+)} $data => sln]
if {! $n1 || ! $n2} {
INFO "ERROR: can't get map for $UI(addr) / $UI(csz)"
return
}
foreach {UI(mln) UI(mlt)} [list $sln $slt] break
set mag $UI(zoom2)
} else {
set UI(mln) [string trim $UI(mln) " 0"]
set UI(mlt) [string trim $UI(mlt) " 0"]
if {$UI(mln) == "" || $UI(mlt) == ""} return
set mag $UI(zoom1)
Init
}
set UI(zoom1) [set UI(zoom2) $mag]
GetRootMap $UI(mlt) $UI(mln)
}
proc About {} {
set msg "$::pname\n\nby Keith Vetter\nJanuary 2003"
tk_messageBox -title "About $::pname" -message $msg -icon info
}
##+##########################################################################
#############################################################################
#############################################################################
Init
DoDisplay
set mag 9
set UI(zoom1) $mag
set UI(zoom2) $mag
if {$argc == 2} {
foreach {UI(mlt) UI(mln)} $argv break
} else {
set UI(mlt) 38.8987
set UI(mln) -77.03645
set UI(addr) "1600 Pennsylvania Ave"
set UI(csz) "Washington, DC"
}
GetRootMap $UI(mlt) $UI(mln) ;# Center of our map
Category Application | Category Graphics | Category Internet