Updated 2011-04-18 20:04:48 by AKgnome

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