TkMapper

Overall summary, as of October 2004: TkMapper is neat stuff--when it works. Mostly it doesn't work, because it depends on extraction of data from Yahoo, and Yahoo sees it as in its best interest to foil such "Web scraping". In principle, we could continue to counter their (monthly? weekly?) efforts by recoding "by hand" the details of the Yahoo interface--or even to work with Yahoo to legitimize our access! It's probably not worth our collective efforts.


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....


Beware: this program will not work out of the box. It generates several error messages. The code is long, I'm still trying to figure out what is wrong with it. LES, May 07, 2003 -- fixed now KPV

escargo It used to work, but now it doesn't. Maybe something dealing with network connections isn't working now.

KPV - I haven't looked closely yet but I'd bet the problem is one common to all web scrapings. Namely, the web pages that the information is extracted from have changed thereby breaking the script. I'll look into the problem shortly.

KPV 2003-05-07 : okay, it is fixed, at least for now. It turns out that Yahoo now returns http code 302 for the url I was fetching-actually it redirects you twice. Since the http package doesn't support automatic redirection (grrr), it broke the script. Fixing this was non-trivial because I was using the -command option to http::geturl. Also, Yahoo also changed the url when clicking on the image. I was simulating a mouse click to determine the lat/long distance between neighboring images.

Vince 2004-29-04 : Unfortunately broken again. I get this error:

    Unsupported URL: /maps_result?ed=hqzBj.p_0Tom2J3DTTitXZ6dbTRJ9dYSEosRsMDW5AOYHYE-&csz=&country=us&mag=9&cat=
    Unsupported URL: /maps_result?ed=hqzBj.p_0Tom2J3DTTitXZ6dbTRJ9dYSEosRsMDW5AOYHYE-&csz=&country=us&mag=9&cat=
        while executing
    "::http::geturl $url"
        (procedure "MyGetURL" line 3)
        invoked from within
    "MyGetURL http://maps.yahoo.com/py/maps.py?Pyt=Tmap&slt=0&sln=0&mlt=38.8987&mln=-77.03645&mag=9&city=abc&ds=n {GotMapPage 0 0}"
        ("after" script)

Siva 2004-15-10: It does not work for me either. It looks like Yahoo does not support long/lat parameters anymore.

KPV This has been broken for a while. Yahoo! constantly changing its interface to break people from scrapping their pages--they even insert funny comments to that effect into the html pages. I tracked the changes a couple of times then gave up.


 #+##########################################################################
 #
 # TkMapper -- extracts neighboring maps from Yahoo and tiles them for you
 # by Keith Vetter, January 2003
 # KPV May 07, 2003 - updated to handle HTTP redirects that Yahoo now has;
 #                    ComputeDeltas url changed
 #
 package require Tk
 package require http 2.0
 
 set pname TkMapper
 set version 1.1
 
 ##+##########################################################################
 #
 # 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
    wm geom . [wm geom .]
    .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} {
    set msg "ERROR: $msg"
    tk_messageBox -icon error -title "$::pname Error" -message $msg
    return -code error                          ;# This clears call stack
 }
 ##+##########################################################################
 #
 # 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 data $::mapInfo(data,0,0)
    set n [regexp -nocase {<form name=.map.*?</form>} $data form]
    if {! $n} {ERROR "can't determine map deltas"}
 
    # Extract the form action plus all the hidden variables for this image map
    regexp -nocase {action="(.*?)"} $form _ xurl
    append xurl "?"
    set start 0
    while {1} {
        set n [regexp -nocase -indices -line -start $start \
                   {<input .*name=(.*?) value="(.*)"} $form all name value]
        if {! $n} break
        set nname [eval string range [list $form] $name]
        set vvalue [eval string range [list $form] $value]
        append xurl "$nname=$vvalue&"
        set start [lindex $value 1]
    }
    append xurl "map.x=599&map.y=599"
 
    #set token [::http::geturl $xurl]
    set token [MyGetURL $xurl]
    SetWantInfo -1
    if {$token == {}} {return -code error}
    set data [::http::data $token]
    ::http::cleanup $token
 
    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"}
 
    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]
    after 1 [list MyGetURL $xurl [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"}
    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
 
    set ncode [::http::ncode $token]            ;# What http code we got
    if {$ncode != 200} {
        SetWantInfo -1
        ERROR "Couldn't get map for cell $x $y: status => [::http::code $token]"
    }
    INFO "got map page for $x $y"
    SetWantInfo -1
 
    set data [::http::data $token]
    if {$x == 0 && $y == 0} {set mapInfo(data,$x,$y) $data}
    
    ::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]
        after 1 [list MyGetURL $url [list GotMapGif $x $y]]
    } else {
        SetWantInfo -1
        ERROR "couldn't get map for cell $x $y"
    }
 }
 proc MyGetURL {url {cmd {}}} {
    while {1} {
        set token [::http::geturl $url]
        set ncode [::http::ncode $token]
        if {$ncode < 300 || $ncode >= 400} break ;# Not a redirect
        
        array set meta [set [set token](meta)]
        ::http::cleanup $token
        
        set n [lsearch -regexp [array names meta] (?i)location]
        if {$n == -1} {ERROR "bad redirection, no location given"}
        set url $meta([lindex [array names meta] $n])
        INFO "redirecting to $url"
    }
    if {$cmd != {}} {
        eval $cmd $token
    }
    return $token
 }
 
 ##+##########################################################################
 #
 # 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 token [MyGetURL $url]
        if {$token == {}} return
        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} {ERROR "can't get map for $UI(addr) / $UI(csz)"}
        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

uniquename 2013aug19

For readers who do not have the time/facilities/whatever to setup this code and execute it, here is an image that shows the GUI created by this code.

vetter_TkMapper_wiki6277_screenshot_1024x547.jpg

I do not have the 'http' package installed, so I commented out the check for that package at the top of this code. On starting up, this GUI tries to go to the Yahoo URL. Even if I had the 'http' package installed, the Yahoo URL is no longer accessible by this code, as indicated by the comments above.

The interpreter fails to execute the http code and shows a Tk traceback error window. So I dummied out the 'MyGetURL' proc, so that I could display this GUI.

Apparently, this GUI is meant to replace the TkMapper title in the big canvas with data retrieved from the Yahoo site. There may be Tclers out there who can repurpose this GUI --- hence I think it is worthwhile providing this image.