dzach : This is a small package for plotting lines and symbols on cartographic (geographic) space. Any canvas can be converted to carto and use both canvas and carto spaces. The package is by no means complete, nor the best of species of tcl programming.
package provide carto 0.3
# Creates the carto command handler for canvas widgets.
# The canvas coordinate space is changed to a cartographic coordinate space
# where y coordinates are positive north. A number of functions
# facilitating cartography are added for convenience.
# The shape primitives of the canvas widget are not affected by the carto command.
# A new virtual primitive crosshair is added which is a special
# composite canvas primitive.
#
# Usage :
# carto pathName ?options?
#
# (C) 2004-2005, Dimitrios Zachariadis
# Licensed under the BSD License
#
proc carto {w args} {
namespace eval ::carto::${w} {
variable var
array set var [list \
-autoscale "meet" \
-detail 1 \
-meets "x" \
-pixelaspectratio 1 \
-space cartesian \
w 200 \
h 200 \
scale 1 \
cxy {}
]
}
upvar ::carto::${w}::var v
if {![winfo exists $w]} {
eval [list canvas $w -width 200 -height 200]
}
rename ::$w ::_$w
::carto::dispatchConfig $w $args
# the window dimensions returned by winfo include border and highlight
# which we must subtract to get the actual width and height
set brdrs [expr {2*([::_$w cget -highlightthickness]+[::_$w cget -borderwidth])}]
scan [winfo geometry $w] "%dx%d" v(ww) v(wh)
set v(ww) [expr {$v(ww)-$brdrs}]
set v(wh) [expr {$v(wh)-$brdrs}]
::_$w configure -xscrollincrement 1
::_$w configure -yscrollincrement 1
bind $w <Configure> {::carto::setScale %W}
proc ::$w {cmd args} "return \[eval ::carto::Handler $w \$cmd \$args]"
set w
}
namespace eval carto {
proc Handler {w cmd args} {
set debug 0
upvar ::carto::${w}::var v
switch -- $cmd {
center {
set vcx [expr {([::_$w canvasx 0]+$v(ww)/2.0)/($v(scale)*$v(-pixelaspectratio))}]
set vcy [expr {-([::_$w canvasy 0]+$v(wh)/2.0)/$v(scale)}]
if {$args=={}} {
return [list $vcx $vcy $v(scale)]
}
if {[llength $args]!=3} {
error "wrong # args: should be \"$w center x y scale\""
}
set redraw 0
# Set center of cartoview and scale
foreach {x y scale} $args {}
# if scale has changed find the new viewbox width
if {$scale!="-"} {
set v(scale) $scale
if {$debug} {puts "...set scale to $v(scale)"}
set v(w) [expr {double($v(ww))/($v(scale)*$v(-pixelaspectratio))}]
set v(h) [expr {double($v(wh))/$v(scale)}]
# scale changed so force a redraw
set redraw 1
}
# if x or y did not change, get them from current view
if {$x=="-" || $x==""} {
set x $vcx
}
if {$y=="-" || $y==""} {
set y $vcy
}
# set viewbox according to the new center
set x0 [expr {$x-$v(ww)/(2.0*$v(scale)*$v(-pixelaspectratio))}]
set y0 [expr {$y+$v(wh)/(2.0*$v(scale))}]
# Redraw or just scroll canvas to view
if {$redraw} {
if {$debug} {puts "...generating event $w <<CartoRedraw>>"}
event generate $w <<CartoRedraw>>
}
setScroll $w $x0 $y0
}
cget {
switch -- [lindex $args 0] {
-autoscale {return $v(-autoscale)}
-detail {return $v(-detail)}
-meets {return $v(-meets)}
-space {return $v(-space)}
-pixelaspectratio {return $v(-pixelaspectratio)}
default {eval {::_$w $cmd } $args}
}
}
config -
configure {eval [list dispatchConfig $w] $args}
create {
switch -- [lindex $args 0] {
crosshair {
if {[llength $args]<2} {
error "wrong # args: should be \"$w create crosshair tag ?option value?\""
}
set tag [lindex $args 1]
eval [list ::_$w create line -3000 0 3000 0 -tag [list $tag ${tag}x]] [lrange $args 2 end]
eval [list ::_$w create line 0 -3000 0 3000 -tag [list $tag ${tag}y]] [lrange $args 2 end]
foreach {x1 y1 x2 y2} [::_$w bbox $tag] {}
set v($tag,offset) [list [expr {(abs($x1)+abs($x2))/2.0}] [expr {(abs($y1)+abs($y2))/2.0}]]
# save tag in a list so that we can find it for redraw
}
default {eval [list ::_$w $cmd] $args}
}
}
delete {
set tag [lindex $args 0]
if {[info exists v($tag,offset)]} {
unset v($tag,offset)
}
eval [list ::_$w $cmd] $args
}
destroy {
# destroy canvas widget and carto command
namespace delete ::carto::${w}
destroy ::$w
rename ::$w {}
rename ::_$w {}
}
forget {
# destroy carto command but retain carto widget
namespace delete ::carto::${w}
rename ::$w {}
rename ::_$w ::$w
}
Move {
if {[llength $args]<3} {error "wrong # args: should be \"$w Move tagOrId x y\""}
foreach {tag x y} $args {}
# calculate tag's center coords
foreach {bbx1 bby1 bbx2 bby2} [::_$w bbox $tag] {}
if {![info exists bbx1]} {
# couldn't find tag
return
}
if {![info exists v($tag,offset)]} {
# tag is not a symbol
set cx0 $bbx1
set cy0 $bby1
} else {
set cx0 [expr {($bbx1+[lindex $v($tag,offset) 0])}]
set cy0 [expr {($bby1+[lindex $v($tag,offset) 1])}]
}
set cx [expr {$x*$v(scale)*$v(-pixelaspectratio)}]
set cy [expr {-$y*$v(scale)}]
::_$w move $tag [expr {$cx-$cx0}] [expr {$cy-$cy0}]
}
Plot {
# accepts one of:
# pathName Plot x y ?-tag tag? ?-mode [abs|rel]? ?-space [cartesian|polar]? ?-option option?
# pathName Plot {x y ...} ?-option option?
if {$debug} {puts "Plot...args=$args"}
set arglen [llength $args]
if {$arglen==0 || $arglen==2 || $arglen==4} {
return;error "wrong # args: should be \"$w Plot tagOrId ?x y ... ?\""
}
foreach {tag x1 y1 x2 y2} [lrange $args 0 4] {}
if {[::_$w find withtag $tag]=={}} {
# this is a new tag
if {$x2=={}} {
set x2 $x1
set y2 $y1
}
::_$w create line \
[expr {$x1*$v(scale)*$v(-pixelaspectratio)}] [expr {-$y1*$v(scale)}] \
[expr {$x2*$v(scale)*$v(-pixelaspectratio)}] [expr {-$y2*$v(scale)}] \
-tag $tag -fill grey
if {$arglen>5} {
set d [::_$w coords $tag]
foreach {x y} [lrange $args 5 end] {
lappend d [expr {$x*$v(scale)*$v(-pixelaspectratio)}] [expr {-$y*$v(scale)}]
}
::_$w coords $tag $d
}
} else {
set d [::_$w coords $tag]
foreach {x y} [lrange $args 1 end] {
lappend d [expr {$x*$v(scale)*$v(-pixelaspectratio)}] [expr {-$y*$v(scale)}]
}
::_$w coords $tag $d
}
}
lPlot {
if {$debug} {puts "lPlot...args=$args"}
if {[llength $args]<=5} {return;error "wrong # args: should be \"$w lPlot tagOrId ?x1 y1 x2 y2 ... ?\"" }
set tag [lindex $args 0]
if {[::_$w find withtag $tag]!={}} {
foreach {x y} [lrange $args 1 end] {
lappend d [expr {$x*$v(scale)*$v(-pixelaspectratio)}] [expr {-$y*$v(scale)}]
}
} else {
foreach {tag x1 y1 x2 y2} [lrange $args 0 4] {}
lappend d [expr {$x1*$v(scale)*$v(-pixelaspectratio)}] [expr {-$y1*$v(scale)}]
lappend d [expr {$x2*$v(scale)*$v(-pixelaspectratio)}] [expr {-$y2*$v(scale)}]
::_$w create line $d -tag $tag -fill grey
foreach {x y} [lrange $args 5 end] {
lappend d [expr {$x*$v(scale)*$v(-pixelaspectratio)}] [expr {-$y*$v(scale)}]
}
}
::_$w coords $tag $d
}
setview {
set args [join $args]
set vx0 [expr {[::_$w canvasx 0]/($v(scale)*$v(-pixelaspectratio))}]
set vy0 [expr {-[::_$w canvasy 0]/$v(scale)}]
if {$args=={}} {
return [list $vx0 $vy0 [expr {$v(ww)/($v(scale)*$v(-pixelaspectratio))}] [expr {$v(wh)/$v(scale)}]]
}
if {[llength $args]!=4} {
error "wrong # args: should be \"$w setview x y w h\""
}
set redraw 0
foreach {x0 y0 wi hi} $args {}
# do we need this ?
if {$x0=="-"} {
set x0 $vx0
}
if {$y0=="-"} {
set y0 $vy0
}
# if viewbox width changed force redraw
if {$wi!="-"} {
set v(w) $wi
set redraw 1
}
# if viewbox height changed force redraw
if {$hi!="-"} {
set v(h) $hi
set redraw 1
}
# Redraw or just scroll canvas to view
if {$redraw} {
setScale $w
}
setScroll $w $x0 $y0
}
symbolize {
if {[llength $args]!=1 && [llength $args]!=3} {
error "wrong # args: should be \"$w symbolize tag ?offsetx offsety?\""
}
set symbol [lindex $args 0]
if {[$w find withtag $symbol]=={}} {
error "tag $symbol does not exist"
}
if {[llength $args]==1} {
foreach {x1 y1 x2 y2} [::_$w bbox $symbol] {}
set v($symbol,offset) [list [expr {($x2-$x1)/2.0}] [expr {($y2-$y1)/2.0}]]
} else {
set v($symbol,offset) [lrange $args 1 end]
}
}
default {eval [list ::_$w $cmd] $args}
}
}
#dispatch configure pairs
proc dispatchConfig {w args} {
set debug 0
if {$debug} {puts "dispatchConfig called by [expr {[info level]>1?[lindex [info level -1] 0]:[list user]}]"}
# strip possible ::_ so that namespace is referenced properly
regexp {^(::_)*(.*)} $w m pre wg
upvar ::carto::${wg}::var v
if {[llength $args]==0} {
return [concat [eval {::_$w configure}] \
[list [list -space $v(-space)]] \
[list [list -pixelaspectratio $v(-pixelaspectratio)]] \
[list [list -autoscale $v(-autoscale)]] \
]
}
foreach {opt val} $args {
switch -- $opt {
-autoscale {
if {$val=={}} {return $v(-autoscale)}
if {![regexp -- {meet|slice|none} $val]} {
error "unknown option $val: should be meet, slice or none"
}
set v(-autoscale) $val
}
-detail {
if {$val=={}} {return $v(-detail)}
if {![string is int $val]} {
error "expected integer but got $val"
}
set v(-detail) $val
}
-space {
if {$val=={}} {return $v(-space)}
if {![regexp -- {meet|slice|none} $val]} {
error "unknown option $val: should be cartesian or polar"
}
set v(-space) $val
}
-pixelaspectratio {
if {$val=={}} {return $v(-pixelaspectratio)}
if {![string is double $val]} {
error "expected real but got $val"
}
set v(-pixelaspectratio) $val
}
default {eval {::_$w configure} $opt $val}
}
}
}
proc setScale wg {
set debug 0
if {$debug} {puts "setScale called by [expr {[info level]>1?[lindex [info level -1] 0]:[list user]}]"}
upvar ::carto::${wg}::var v
scan [winfo geometry $wg] "%dx%d" v(ww) v(wh)
set brdrs [expr {2*([::_$wg cget -highlightthickness]+[::_$wg cget -borderwidth])}]
set v(ww) [expr {$v(ww)-$brdrs}]
set v(wh) [expr {$v(wh)-$brdrs}]
set aspectratio [expr {double($v(ww))/$v(wh)}]
switch -regexp -- $v(-autoscale) {
meet {
# max(viewbox) -> min(window)
if {$v(wh)!=0 && $v(w)!=0 && $v(h)!=0} {
if {double($v(w))/$v(h)>$aspectratio} {
set v(-meets) "x"
set v(scale) [expr {double($v(ww))/$v(w)}]
} else {
set v(-meets) "y"
set v(scale) [expr {double($v(wh))/$v(h)}]
}
}
}
slice {
# min(viewbox) -> max(window)
if {$v(wh)!=0 && $v(w)!=0 && $v(h)!=0} {
if {double($v(w))/$v(h)>$aspectratio} {
set v(-meets) "y"
set v(scale) [expr {double($v(wh))/$v(h)}]
} else {
set v(-meets) "x"
set v(scale) [expr {double($v(ww))/$v(w)}]
}
}
}
none {
# no event is generated
return
}
default {
return
}
}
# set v(w) [expr {double($v(ww))/$v(scale)}]
# set v(h) [expr {double($v(wh))/$v(scale)}]
if {$debug} {puts "...event generate $wg <<CartoRedraw>>"}
event generate $wg <<CartoRedraw>>
if {$debug} {puts "...set scale to $v(scale)"}
}
proc setScroll {w x0 y0} {
upvar ::carto::${w}::var v
::_$w xview scroll [expr {round($x0*$v(scale)*$v(-pixelaspectratio)-[::_$w canvasx 0])}] u
::_$w yview scroll [expr {-round($y0*$v(scale)+[::_$w canvasy 0])}] u
}
proc screentocarto {w x y} {
upvar ::carto::${w}::var v
return [list \
[expr {($x+[::_$w canvasx 0])/($v(scale)*$v(-pixelaspectratio))}] \
[expr {-($y+[::_$w canvasy 0])/$v(scale)}]]
}
proc tocarto {w x y} {
upvar ::carto::${w}::var v
return [list [expr {$x/($v(scale)*$v(-pixelaspectratio))}] [expr {-$y/$v(scale)}]]
}
proc tocanvas {w x y} {
upvar ::carto::${w}::var v
return [list [expr {$x*$v(scale)*$v(-pixelaspectratio)}] [expr {-$y*$v(scale)}]]
}
proc centertoview {w args} {
}
proc viewtocenter {w args} {
}
}
# A sample of its usage:
package req Tk
package req carto
pack [carto .c --bg white]
# set cartographic origin in canvas units x0=0 y0=200
.c setview 0 200 - -
# create and plot line l1
.c Plot l1 10 10 20 25 23 56 100 23
# create symbol pt in canvas
.c create rect -5 -5 5 5 -tag pt
# create symbol offset so that it is centered on the coordinate. Here default centering is used
.c symbolize pt
.c Move pt 100 23