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 northt. A number of functions
# facilitating cartography are added for convinience.
# The shape primitives of the canvas widget are not affected by the carto command.
# Two new virtual primitives are added: symbol and crosshair which are special
# composit canvas primitives.
# Usage :
# carto pathName ?options?
# Example:
# carto .c -setview {0 200 200 200}
# pack .c
# (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} {
}
}