[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 [list canvas2pos %W %x %y] bind .c <2> [bind Text <2>] bind .c [bind Text ] set mw {%W yview scroll [expr {- (%D / 120) * 1}] units} regsub yview $mw xview mw2 bind .c $mw bind .c $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 {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 [list OverviewX %W %x %y down] bind .over [list OverviewX %W %x %y move] bind .over [list OverviewX %W %x %y done] bind .over [list OverviewX %W %x %y down] bind .over [list OverviewX %W %x %y move] bind .over [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]