tkWorld 0.2
Richard Suchenwirth - Here's version 0.2 of the map viewer tkWorld. Still preliminary, but contains better color scheme (light blue for lakes, shades of green for land, white for polar regions) and, best of all, an improved zooming that reacts on left/right mouse click as well.
The name has now changed to Tclworld, the projection of the map is now by default a quasi-Winkel, and a database browse/zoom-in mechanism has been added.
namespace eval geo {variable db ;# array that holds our database}
proc geo::Set args {
variable db
if {[llength $args]==1} {set args [lindex $args 0]}
foreach line [split $args \n] {
set name [lindex $line 0]
if {[llength $line]>2 && $name !="#"} {
set db($name) [lrange $line 1 end]
}
}
}
proc geo::Get arg {
variable db
if {[info exists db($arg)]} {
set value $db($arg)
} elseif {![catch {expr [join $arg +]}]} {
set value [concat point $arg]
} else {return ""}
set rest [lrange $value 1 end]
if {[llength $rest]==1} {set res [lindex $rest 0]}
switch -glob -- [lindex $value 0] {
area - lake {set res [Make polygon $rest]}
bound* {set res [Make line $rest]}
city {set res [city $arg]}
point {
if {[llength $rest] != 2} return
foreach {x y} $rest break
set res [list point [expr {-$x}] [expr {-$y}]]
}
road {set res [Make line $rest]}
default {return -code error "cannot get $arg"}
}
set res
}
proc geo::Make {item argl} {
foreach arg $argl {
eval lappend item [lrange [Get $arg] 1 end]
}
Join $item
}
proc geo::city name {
variable db
foreach {x y} [lrange $db($name) 1 2] break
concat oval [expr {-$x-.01}] [expr {-$y-.01}] \
[expr {-$x+.01}] [expr {-$y+.01}]
}
proc geo::Join list {
set res [lrange $list 0 2]
set lastx [lindex $res 1]
set lasty [lindex $res 2]
foreach {x y} [lrange $list 3 end] {
if {$x!=$lastx || $y!=$lasty} {
lappend res $x $y
}
set lastx $x
set lasty $y
}
join $res
}# Rendering is done with an overloaded canvas:
proc geo::swapxy L {
variable zoom
set res [lindex $L 0]
foreach {lat lon} [lrange $L 1 end] {
lappend res [expr {$lon*$zoom}] [expr {$lat*$zoom}]}
set res
}
proc geo::Canvas {} {
variable canvas
set canvas
}
proc geo::Map {w args} {
variable zoom 2. canvas
eval canvas $w $args ;# create the base widget
set canvas $w
rename ::$w ::_$w
proc ::$w {cmd args} [string map [list @w@ _$w] {
variable db
set w [lindex [info level 1] 0]
set name [lindex $args 0]
set rest [lrange $args 1 end]
switch -- $cmd {
show {
set data [geo::swapxy [geo::Get $name]]
#if {[llength $data]<4} return
set item [eval _$w create $data -tag [list $name]]
eval _$w itemconfig $item $rest
set type [lindex $geo::db($name) 0]
if {$type=="city"} {
_$w itemconfig $item -fill red
} elseif {$type=="lake"} {
_$w addtag lake withtag $item
_$w itemconfig $item -fill lightblue
}
set item
}
default {eval @w@ $cmd $args}
}
}]
set w
}
proc geo::Names {{pat *}} {
variable db
array names db $pat
}
#----------------------------------------------------------------------
proc scrolled {type w args} {
frame $w
set res [eval $type $w.0 \
[list -xscrollc "$w.x set" -yscrollc "$w.y set"] $args]
scrollbar $w.x -ori hori -command "$w.0 xview"
scrollbar $w.y -ori vert -command "$w.0 yview"
grid $w.0 $w.y -sticky news
grid $w.x -sticky news
grid columnconfigure $w 0 -weight 1
grid rowconfigure $w 0 -weight 1
set res
}
proc lpick L {lindex $L [expr {int(rand()*[llength $L])}]}
proc scale {w factor} {
if {$factor==0} {set factor [expr {2./$::scale}]}
$w scale all 0 0 $factor $factor
$w config -scrollregion [$w bbox all]
set ::scale [expr {$::scale*$factor}]
}
proc scale2 {w x y factor} {
if {$x=="."} {
set x [expr [$w cget -width]/2]
set y [expr [$w cget -height]/2]
}
foreach {x0 y0 x1 y1} [$w bbox all] break
set width [expr double($x1-$x0)]
set height [expr double($y1-$y0)]
set cx [$w canvasx $x]
set cy [$w canvasy $y]
set relw [expr {($cx-$x0-$x/$factor)/$width}]
set relh [expr {($cy-$y0-$y/$factor)/$height}]
#scale $w $factor
if {$factor==0} {set factor [expr {2./$::scale}]}
$w scale all 0 0 $factor $factor
$w config -scrollregion [$w bbox all]
set ::scale [expr {$::scale*$factor}]
$w xview moveto $relw
$w yview moveto $relh
}
proc where {w x y} {
global scale
set here [$w find withtag current]
if {[llength $here]} {
set ::where [string map {
current {} lake {}
} [$w itemcget $here -tags]]
} else {set ::where ""}
set lat [format %.2f [expr {-[$w canvasy $y]/$scale}]]
if {$lat>0} {append lat N} else {set lat [expr {-$lat}]S}
set lon [format %.2f [expr {-[$w canvasx $x]/$scale}]]
if {$lon>0} {append lon W} else {set lon [expr {-$lon}]E}
set ::position "$lat $lon"
}
#----------------------------------------------------------------------
set c [scrolled geo::Map .m -width 720 -height 360 -bg lightblue]
frame .top
label .top.scale -textvar scale -width 10
button .top.plus -text + -width 3 -pady 0 -command [list scale2 $c . . 2.0]
button .top.minus -text - -width 3 -pady 0 -command [list scale2 $c . . 0.5]
button .top.all -text {[]} -width 3 -pady 0 \
-command [list scale $c 0]
label .top.pos -textvar position -width 20 -bg white
label .top.where -textvar where
eval pack [winfo children .top] -side left
pack .top .m -fill x
pack .m -fill both -expand 1
wm title . Wait...
$c create line -360 0 360 0 -fill white
$c create line 0 -180 0 180 -fill white
$c config -scrollregion [$c bbox all]
$c create text 0 0 -text "TkWorld..." -font "Helvetica 96 italic" \
-fill blue -tag wait
. config -cursor watch
update
set scale 2.0
set colors {
green2 green3 green4 olivedrab2 olivedrab3 olivedrab4
palegreen3 palegreen4
}
cd [file dirname [info script]] ;# requires all files in one dir
source world.tg
foreach name [geo::Names] {
set id [$c show $name -fill [lpick $colors]]
set bbox [$c bbox $id]
if {[lindex $bbox 3]>120 || [lindex $bbox 3]<-117} {
$c itemconfig $id -fill white
}
update
}
$c raise lake
cities $c
$c delete wait
. config -cursor {}
wm title . "Welcome to TkWorld 0.2!"
bind $c <Motion> [list where $c %x %y]
focus $c
bind $c + [list scale2 $c . . 2.0]
bind $c - [list scale2 $c . . 0.5]
bind $c <1> [list scale2 $c %x %y 2.0]
bind $c <3> [list scale2 $c %x %y 0.5]
update
bind . ? {console show}
if [catch {source bodensee.tg}] {puts $errorInfo}world.tg is too big to put here (110kB). mailto:[email protected] for a complimentary copy, or, if you have tkWorld 0.1, modify the end after the data to read like this:
proc cities w {
foreach {city lat lon} {
Beijing 40 -117
Berlin 52.5 -13.5
"Buenos Aires" -35 58
London 51.8 0.1
Madrid 40.5 3.5
Melbourne -38 -144.5
"Mexico City" 20 99
Moskva 55.9 -37.5
"New Delhi" 28 -77
"New York" 41 73.5
Paris 48.8 -2.4
Roma 41.9 -12.4
"Sao Paulo" -23 46
Tokyo 36 -138
Varna 43.5 -27.9
} {
set lon2 [expr {-$lon-$lon-.5}]
set lat2 [expr {-$lat-$lat-.5}]
$w create oval $lon2 $lat2 [expr {$lon2+.5}] [expr {$lat2+.5}]\
-fill red -tag $city
update
}
}
foreach {id coords} $data {
set t [lrange $coords 6 end]
if {[llength $t]>=4} {
set type [expr {[string match {[~A-Z]*} $id]? "area": "bound"}]
if {[string index $id 0]=="~"} {
set type lake
set id [string range $id 1 end]
}
set cmd [list geo::Set $id $type]
foreach {lat lon} $t {lappend cmd [list $lat [expr {-$lon}]]}
eval $cmd
}
}bodensee.tg is short enough to go here completely: # sample extension for Tkworld, displaying Lake Constance (Bodensee)
geo::Set {
Bodensee lake Bo-DE Bo-CH AT-Bo
Bo-DE bound AT.Bo.DE Lindau Nonnenhorn \
Langenargen Friedrichshafen \
Immenstaad Meersburg Bodman-Ludwigshafen Bodman \
KN-Dingelsdorf KN-Staad KN-Hörnle Konstanz Allensbach \
{47.75 -8.95} {47.72 -9.01} Radolfzell Moos Gaienhofen-Horn \
Gaienhofen Öhningen
Bo-CH bound Eschenz Steckborn Ermatingen Kreuzlingen Romanshorn \
Rorschach AT.Bo.CH
AT-Bo bound AT.Bo.CH Bregenz AT.Bo.DE
AT.Bo.DE point 47.6 -9.72
AT.Bo.CH point 47.51 -9.6
Bodman point 47.8 -9.03
Bodman-Ludwigshafen point 47.81 -9.05
Bregenz city 47.55 -9.69
Eschenz point 47.64 -8.73
Friedrichshafen city 47.7 -9.48
Gaienhofen point 47.68 -8.98
Gaienhofen-Horn point 47.7 -9.0
Immenstaad city 47.7 -9.37
Konstanz city 47.7 -9.13
KN-Dingelsdorf point 47.74 -9.14
KN-Hörnle point 47.7 -9.15
Kreuzlingen city 47.69 -9.13
Langenargen point 47.65 -9.55
Lindau city 47.63 -9.7
Nonnenhorn point 47.651 -9.65
Öhningen point 47.66 -8.75
Radolfzell city 47.75 -8.92
Romanshorn city 47.6 -9.37
Rorschach city 47.49 -9.5
}
foreach i {
Bodensee Lindau Bregenz Radolfzell Konstanz Kreuzlingen
Friedrichshafen Rorschach Romanshorn
} {
[geo::Canvas] show $i
}