Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | Merged latest crosshair work to the pending release. |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | tklib-0-6-rc |
| Files: | files | file ages | folders |
| SHA1: | 22070c5233006e7c8ef0395a4cede473d3e65ddf |
| User & Date: | andreask 2013-03-11 20:05:23 |
Context
|
2013-03-11
| ||
| 20:08 | Merged latest plotchart work into the pending release. check-in: c2b933f8dd user: andreask tags: tklib-0-6-rc | |
| 20:05 | Merged latest crosshair work to the pending release. check-in: 22070c5233 user: andreask tags: tklib-0-6-rc | |
|
2013-02-25
| ||
| 20:13 | Do not invoke the tracking callback while the crosshairs are out of bounds. Closed-Leaf check-in: 9804fb212f user: andreask tags: crosshair-bboxes-3603562 | |
|
2013-02-20
| ||
| 17:57 | Merged plotchart test corrections into the release. check-in: 5e22b3d715 user: andreask tags: tklib-0-6-rc | |
Changes
Changes to examples/canvas/city.tcl.
7 8 9 10 11 12 13 14 15 16 17 18 19 20 .. 22 23 24 25 26 27 28 29 30 31 32 33 34 35 .. 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
## (*) Random + restrictions about what tiles can be neighbours. ## This part in citygrid.tcl # ### ### ### ######### ######### ######### ## For data files found relative to the example's location. set selfdir [file dirname [file normalize [info script]]] source $selfdir/citygrid.tcl # ### ### ### ######### ######### ######### ## Other requirements for this example. package require Tk ................................................................................ package require canvas::sqmap package require crosshair package require struct::set ; # citygrid.tcl package require snit ; # canvas::sqmap dependency package require uevent::onidle ; # ditto package require cache::async 0.2 ; # ditto # ### ### ### ######### ######### ######### set location {} proc GUI {} { widget::scrolledwindow .sw ................................................................................ bind .map <ButtonPress-2> {%W scan mark %x %y} bind .map <B2-Motion> {%W scan dragto %x %y} # Cross hairs ... .map configure -cursor tcross crosshair::crosshair .map -width 0 -fill \#999999 -dash {.} crosshair::track on .map TRACK set tile [city::tile] set city [expr {$tile * 64}] #.map configure -grid-show-borders 1 ;# This leaks items = memory if 0 { # This routes the requests and results through GOT/GET logging |
> > > > > > > |
7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 .. 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 .. 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
## (*) Random + restrictions about what tiles can be neighbours. ## This part in citygrid.tcl # ### ### ### ######### ######### ######### ## For data files found relative to the example's location. set selfdir [file dirname [file normalize [info script]]] #lappend auto_path $selfdir/../../modules source $selfdir/citygrid.tcl # ### ### ### ######### ######### ######### ## Other requirements for this example. package require Tk ................................................................................ package require canvas::sqmap package require crosshair package require struct::set ; # citygrid.tcl package require snit ; # canvas::sqmap dependency package require uevent::onidle ; # ditto package require cache::async 0.2 ; # ditto #puts [package ifneeded crosshair [package present crosshair]] # ### ### ### ######### ######### ######### set location {} proc GUI {} { widget::scrolledwindow .sw ................................................................................ bind .map <ButtonPress-2> {%W scan mark %x %y} bind .map <B2-Motion> {%W scan dragto %x %y} # Cross hairs ... .map configure -cursor tcross crosshair::crosshair .map -width 0 -fill \#999999 -dash {.} crosshair::track on .map TRACK puts [crosshair::bbox_add .map {100 100 300 300}] puts [crosshair::bbox_add .map {50 50 150 150}] set tile [city::tile] set city [expr {$tile * 64}] #.map configure -grid-show-borders 1 ;# This leaks items = memory if 0 { # This routes the requests and results through GOT/GET logging |
Added examples/canvas/crosshairs_for_axes.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
# test_axis.tcl -- # Test the drawing of the axis: nice rounded values? # And vertical text to right axis? # # NOTE: # Negative values require floor() instead of ceil()! # # NOTE: # Problem with right axis! # # TODO: # Floor and Ceil and less stringent check for bounds! # set base [file dirname [file dirname [file dirname [file normalize [info script]]]]] source "$base/modules/plotchart/plotchart.tcl" source "$base/modules/crosshair/crosshair.tcl" package require Plotchart grid [canvas .c1] [canvas .c2] grid [canvas .c3] [canvas .c4] # # Create the plots # set plot_axes [list { 0.12 10.4 1.0} {-0.12 10.4 2.5} \ {10.12 -10.4 -2.0} {-5.1 -4.5 0.1} \ {-0.12 10.4 2.5} { 0.12 10.4 1.0} \ {-5.1 -4.5 0.1} {10.12 -10.4 -2.0}] set i 1 foreach {x y} $plot_axes { set p($i) [::Plotchart::createXYPlot .c${i} $x $y ] incr i } set p(5) [::Plotchart::createRightAxis $p(2) {-5.99 -4.5 0.1}] $p(2) plot data 10.0 -5.0 $p(2) plot data -10.0 -5.0 $p(5) dataconfig data -colour green $p(5) plot data 10.0 -4.7 $p(5) plot data -10.0 -4.7 $p(2) vtext "my_changes" $p(5) vtext "Data" # Adding crosshairs to the plots set i 1 array set color {1 blue 2 red 3 green 4 black} foreach {x y} $plot_axes { .c${i} configure -cursor tcross crosshair::crosshair .c$i -dash {.} -fill $color($i) crosshair::track on .c$i put_coords set bbox_ll [::Plotchart::coordsToPixel [$p($i) canvas] [lindex $x 0] [lindex $y 0]] set bbox_ur [::Plotchart::coordsToPixel [$p($i) canvas] [lindex $x 1] [lindex $y 1]] #--- testing coordinate mixed up if {$i==0} { set bbox [concat $bbox_ll $bbox_ur] } elseif {$i==1} { set bbox [list [lindex $bbox_ur 0] [lindex $bbox_ll 1] [lindex $bbox_ll 0] [lindex $bbox_ur 1]] } elseif {$i==2} { set bbox [list [lindex $bbox_ll 0] [lindex $bbox_ur 1] [lindex $bbox_ur 0] [lindex $bbox_ll 1]] } else { set bbox [concat $bbox_ur $bbox_ll] } crosshair::bbox_add .c$i "$bbox" puts "plot $i ==> bbox== $bbox color = $color($i)" incr i } proc put_coords {a b c d e f g} { set pcoords [::Plotchart::pixelToCoords $a $b $c] set pcoord_x [lindex $pcoords 0] set pcoord_y [lindex $pcoords 1] puts "Canvas=$a Canvas_Coords=($b $c) PlotChart_plot_coords=([format "%.2f %.2f" $pcoord_x $pcoord_y])" } catch { console show } |
Added examples/canvas/crosshairs_for_multixyplot.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
# test_txplot.tcl -- # Test the -box options for time-x-plots set base [file dirname [file dirname [file dirname [file normalize [info script]]]]] source "$base/modules/plotchart/plotchart.tcl" source "$base/modules/crosshair/crosshair.tcl" package require Plotchart pack [canvas .c -width 600 -height 410 -bg white] ::Plotchart::plotstyle configure default xyplot bottomaxis subtextcolor blue ::Plotchart::plotstyle configure default xyplot bottomaxis font "Helvetica 14" ::Plotchart::plotstyle configure default xyplot bottomaxis subtextfont "Helvetica 12 bold" ::Plotchart::plotstyle configure default xyplot leftaxis font "Helvetica 14" ::Plotchart::plotstyle configure default xyplot leftaxis subtextfont "Helvetica 12 bold" ::Plotchart::plotstyle configure default xyplot leftaxis subtextcolor red ::Plotchart::plotstyle configure default xyplot leftaxis usesubtext 1 set p1 [::Plotchart::createXYPlot .c {0 100 30} {0 20 5} -box {0 0 400 200}] set p2 [::Plotchart::createXYPlot .c {0 100 30} {0 20 5} -box {100 210 400 200}] #.c create rectangle 0 210 400 410 $p1 plot data 0 10 $p1 plot data 100 15 $p1 xtext Aha #$p1 xsubtext "1, 2, 3" $p1 ytext "Same spot?" $p2 plot data 0 10 $p2 plot data 100 15 $p2 ytext "Higher up" #$p2 ysubtext "Lower down" $p2 vtext "To the left" #$p2 vsubtext "To the right" .c configure -cursor tcross crosshair::crosshair .c -dash {.} -fill blue #crosshair::track on .c put_coords set bbox_ll [::Plotchart::coordsToPixel [$p1 canvas] 0 0 ] set bbox_ur [::Plotchart::coordsToPixel [$p1 canvas] 100 20] set bbox_p1 [concat $bbox_ll $bbox_ur] crosshair::bbox_add .c "$bbox_p1" set bbox_ll [::Plotchart::coordsToPixel [$p2 canvas] 0 0 ] set bbox_ur [::Plotchart::coordsToPixel [$p2 canvas] 100 20] set bbox_p2 [concat $bbox_ll $bbox_ur] crosshair::bbox_add .c "$bbox_p2" catch { console show } |
Changes to modules/crosshair/ChangeLog.
1
2
3
4
5
6
7
8
9
10
11
12
..
23
24
25
26
27
28
29
30
|
2009-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * Released and tagged Tklib 0.5 ======================== * 2008-11-27 Andreas Kupries <andreas_kupries@users.sourceforge.net> * crosshair.tcl: Split the two crosshair lines into four, one per * crosshair.man: direction, and changed the locations so that the * pkgIndex.tcl: canvas will not pick the crosshairs as the 'current' object under the cursor. Bumped version to 1.0.2 ................................................................................ * crosshair.man: Fixed doc bugs found by Larry Virden [Bug 2255255]. These were my bad, not Kevin's. 2008-11-04 Andreas Kupries <andreask@activestate.com> * crosshair.man: New module and package, crosshairs for * crosshair.tcl: Tk canvas. By Kevin Kenny. * pkgIndex.tcl: |
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
..
35
36
37
38
39
40
41
42
|
2013-02-25 Andreas Kupries <andreas_kupries@users.sourceforge.net> * crosshair.tcl: [Bug 3603562]: Tweaks and fixes for robustness. * ../../examples/canvas/crosshair_for_axes.tcl: Examples of bounded * ../../examples/canvas/crosshair_for_multixyplot.tcl: crosshairs. 2013-02-13 Andreas Kupries <andreas_kupries@users.sourceforge.net> * crosshair.tcl: [Bug 3603562]: Allow the confinement of the * crosshair.man: crosshairs to one or more rectangular bounding * pkgIndex.tcl: boxes. Bumped version to 1.1. 2009-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * Released and tagged Tklib 0.5 ======================== * 2008-11-27 Andreas Kupries <andreas_kupries@users.sourceforge.net> * crosshair.tcl: Split the two crosshair lines into four, one per * crosshair.man: direction, and changed the locations so that the * pkgIndex.tcl: canvas will not pick the crosshairs as the 'current' object under the cursor. Bumped version to 1.0.2 ................................................................................ * crosshair.man: Fixed doc bugs found by Larry Virden [Bug 2255255]. These were my bad, not Kevin's. 2008-11-04 Andreas Kupries <andreask@activestate.com> * crosshair.man: New module and package, crosshairs for * crosshair.tcl: Tk canvas. By Kevin Kenny. * pkgIndex.tcl: |
Changes to modules/crosshair/crosshair.man.
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
..
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin crosshair n 1.0.2]
[copyright {2003 Kevin Kenny}]
[copyright {2008 (docs) Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
[moddesc Crosshairs]
[titledesc {Crosshairs for Tk canvas}]
[require Tcl [opt 8.4]]
[require Tk [opt 8.4]]
[require crosshair [opt 1.0.2]]
[keywords canvas cross-hairs tracking viewport location]
[description]
The [package crosshair] package provides commands to (de)activate and
track crosshairs on canvas widgets.
................................................................................
[call [cmd crosshair::track] [method off] [arg w]]
This command disables the reporting of the location of the cross-hairs
in the canvas widget [arg w]. It is an error to use this command for a
canvas which has no cross-hairs. The result of the command is the
empty string.
[list_end]
[section {BUGS, IDEAS, FEEDBACK}]
This document, and the package it describes, will undoubtedly contain
bugs and other problems.
Please report such in the category [emph {tklib :: crosshair}] of the
[uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}].
Please also report any ideas for enhancements you may have for either
package and/or documentation.
[manpage_end]
|
|
>
|
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
..
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
[comment {-*- tcl -*- doctools manpage}]
[manpage_begin crosshair n 1.1]
[copyright {2003 Kevin Kenny}]
[copyright {2008 (docs) Andreas Kupries <andreas_kupries@users.sourceforge.net>}]
[copyright {2013 Frank Gover, Andreas Kupries}]
[moddesc Crosshairs]
[titledesc {Crosshairs for Tk canvas}]
[require Tcl [opt 8.4]]
[require Tk [opt 8.4]]
[require crosshair [opt 1.1]]
[keywords canvas cross-hairs tracking viewport location]
[description]
The [package crosshair] package provides commands to (de)activate and
track crosshairs on canvas widgets.
................................................................................
[call [cmd crosshair::track] [method off] [arg w]]
This command disables the reporting of the location of the cross-hairs
in the canvas widget [arg w]. It is an error to use this command for a
canvas which has no cross-hairs. The result of the command is the
empty string.
[call [cmd crosshair::bbox_add] [arg w] [arg bbox]]
This command adds a bounding box to the crosshairs for canvas [arg w].
The crosshairs will only be active within that area.
[para] The result of the command is a token with which the bounding
box can be removed again, see [cmd crosshair::bbox_remove] below.
[para] The bounding box [arg bbox] is specified thorugh a list of 4
values, the lower left and upper right corners of the box. The order
of values in the list is:
[example {llx lly urx ury}]
[para] Note that this command can be used multiple times, each call
adding one more bounding box. In such a case the visible area is the
[emph union] of all the specified bounding boxes.
[call [cmd crosshair::bbox_remove] [arg token]]
This command removes the bounding box specified by the [arg token] (a
result of [cmd crosshair::bbox_add]) from the crosshairs for its
canvas widget.
[list_end]
[section {BUGS, IDEAS, FEEDBACK}]
This document, and the package it describes, will undoubtedly contain
bugs and other problems.
Please report such in the category [emph {tklib :: crosshair}] of the
[uri {http://sourceforge.net/tracker/?group_id=12883} {Tcllib SF Trackers}].
Please also report any ideas for enhancements you may have for either
package and/or documentation.
[manpage_end]
|
Changes to modules/crosshair/crosshair.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 .. 44 45 46 47 48 49 50 51 52 53 54 55 56 57 ... 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 ... 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 ... 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 ... 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 ... 329 330 331 332 333 334 335 336 |
# crosshair.tcl - # # Kevin's mouse-tracking crosshair in Tk's canvas widget. # # This package displays a mouse-tracking crosshair in the canvas widget. # # Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. # Redistribution permitted under the terms in # http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/tcl/tcl/license.terms?rev=1.3&content-type=text/plain # # Copyright (c) 2008 Andreas Kupries. Added ability to provide the tracking # information to external users. # # ### ### ### ######### ######### ######### ## Requisites package require Tcl 8.4 package require Tk 8.4 ................................................................................ # crosshairs will be displayed on pointing device motion. # #---------------------------------------------------------------------- proc ::crosshair::crosshair { w args } { variable config set opts(args) $args bindtags $w [linsert [bindtags $w] 1 Crosshair] set config($w) [array get opts] return } #---------------------------------------------------------------------- # ................................................................................ return -code error "no crosshairs in $w" } array set opts $config($w) if { [llength $args] > 0 } { array set flags $opts(args) array set flags $args set opts(args) [array get flags] if { [info exists opts(hhairl)] } { eval [list $w itemconfig $opts(hhairl)] $args eval [list $w itemconfig $opts(hhairr)] $args eval [list $w itemconfig $opts(vhaird)] $args eval [list $w itemconfig $opts(vhairu)] $args } set config($w) [array get opts] } return $opts(args) } #---------------------------------------------------------------------- # # ::crosshair::track -- # # (De)activates reporting of the cross-hair coordinates through # a user-specified callback. ................................................................................ # #---------------------------------------------------------------------- proc ::crosshair::Hide { w } { variable config if { ![info exists config($w)] } return array set opts $config($w) if { ![info exists opts(hhairl)] } return $w delete $opts(hhairl) $w delete $opts(hhairr) $w delete $opts(vhaird) $w delete $opts(vhairu) unset opts(hhairl) unset opts(hhairr) unset opts(vhairu) unset opts(vhaird) set config($w) [array get opts] return } #---------------------------------------------------------------------- # # ::crosshair::Unhide -- ................................................................................ # #---------------------------------------------------------------------- proc ::crosshair::Unhide { w x y } { variable config if { ![info exists config($w)] } return array set opts $config($w) if { ![info exists opts(hhairl)] } { set opts(hhairl) [eval [list $w create line 0 0 0 0] $opts(args)] set opts(hhairr) [eval [list $w create line 0 0 0 0] $opts(args)] set opts(vhaird) [eval [list $w create line 0 0 0 0] $opts(args)] set opts(vhairu) [eval [list $w create line 0 0 0 0] $opts(args)] } set config($w) [array get opts] Move $w $x $y return } #---------------------------------------------------------------------- # # ::crosshair::Move -- # # Moves the crosshairs in a camvas # ................................................................................ # with crosshairs. # #---------------------------------------------------------------------- proc ::crosshair::Move { w x y } { variable config array set opts $config($w) set opts(x) [$w canvasx $x] set opts(y) [$w canvasy $y] set opts(x0) [$w canvasx 0] set opts(x1) [$w canvasx [winfo width $w]] set opts(y0) [$w canvasy 0] set opts(y1) [$w canvasy [winfo height $w]] if { [info exists opts(hhairl)] } { # +/-4 is the minimal possible distance which still prevents # the canvas from choosing the crosshairs as 'current' object # under the cursor. set n 4 $w coords $opts(hhairl) $opts(x0) $opts(y) [expr {$opts(x)-$n}] $opts(y) $w coords $opts(hhairr) [expr {$opts(x)+$n}] $opts(y) $opts(x1) $opts(y) $w coords $opts(vhairu) $opts(x) $opts(y0) $opts(x) [expr {$opts(y)-$n}] $w coords $opts(vhaird) $opts(x) [expr {$opts(y)+$n}] $opts(x) $opts(y1) $w raise $opts(hhairl) $w raise $opts(hhairr) $w raise $opts(vhaird) $w raise $opts(vhairu) } set config($w) [array get opts] if {[info exists opts(track)]} { uplevel \#0 [linsert $opts(track) end $w $opts(x) $opts(y) $opts(x0) $opts(y0) $opts(x1) $opts(y1)] } return } # ### ### ### ######### ######### ######### ## State namespace eval ::crosshair { # Array holding information describing crosshairs in canvases ................................................................................ bind Crosshair <Leave> "[namespace code Hide] %W" bind Crosshair <Motion> "[namespace code Move] %W %x %y" } # ### ### ### ######### ######### ######### ## Ready package provide crosshair 1.0.2 |
| < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | < < > | | | < | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | < | < > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > | | | | > > > > > > > > > > > > > > > | | | | > > > > | < > > > > > > > > > > > | < | > > > > > > > > > | |
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 .. 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 ... 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 ... 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 ... 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 ... 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 ... 585 586 587 588 589 590 591 592 |
# crosshair.tcl - # # Kevin's mouse-tracking crosshair in Tk's canvas widget. # # This package displays a mouse-tracking crosshair in the canvas widget. # # Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. # Redistribution permitted under the terms of the Tcl License. # # Copyright (c) 2008 Andreas Kupries. Added ability to provide the tracking # information to external users. # # Copyright (c) 2013 Frank Gover, Andreas Kupries. Added ability to # bound the crosshairs to an area of the canvas. Useful # for plots. # (Actual code inspired by Frank's, but modified and extended (multiple bboxes)). # ### ### ### ######### ######### ######### ## Requisites package require Tcl 8.4 package require Tk 8.4 ................................................................................ # crosshairs will be displayed on pointing device motion. # #---------------------------------------------------------------------- proc ::crosshair::crosshair { w args } { variable config set opts(args) $args set opts(hidden) 0 bindtags $w [linsert [bindtags $w] 1 Crosshair] set config($w) [array get opts] return } #---------------------------------------------------------------------- # ................................................................................ return -code error "no crosshairs in $w" } array set opts $config($w) if { [llength $args] > 0 } { array set flags $opts(args) array set flags $args set opts(args) [array get flags] # Immediately apply to a visible crosshair if { [info exists opts(hhairl)] } { eval [list $w itemconfig $opts(hhairl)] $args eval [list $w itemconfig $opts(hhairr)] $args eval [list $w itemconfig $opts(vhaird)] $args eval [list $w itemconfig $opts(vhairu)] $args } set config($w) [array get opts] } return $opts(args) } #---------------------------------------------------------------------- # # ::crosshair::bbox_add -- # # Confines the crosshairs to a rectangular area in the canvas widget. # Multiple calls add areas, each allowing the crosshairs. # # NOTE: Bounding boxes can overlap to the point of being identical. # # Parameters: # w - Path name of the widget # bbox - Area in the canvas. A list of 4 numbers in the form # {bbox_llx bbox_lly bbox_urx bbox_ury} # where: # bbox-llx = Lower left X coordinate of the area # bbox-lly = Lower left Y coordinate of the area # bbox-urx = Upper right X coordinate of the area # bbox-ury = Upper right Y coordinate of the area # # Result: # A token identifying the bounding box, for future removal. # #---------------------------------------------------------------------- proc ::crosshair::bbox_add { w bbox } { variable config if { ![info exists config($w)] } { return -code error "no crosshairs in $w" } array set opts $config($w) # Sort the coordinates and make sure the bbox is in format # "lower-left upper-right". The larger Y is on the lower left and # the larger X is on the upper right. set x_coords [lsort -real -increasing [list [lindex $bbox 0] [lindex $bbox 2]]] set y_coords [lsort -real -decreasing [list [lindex $bbox 1] [lindex $bbox 3]]] set bbox [list \ [lindex $x_coords 0] [lindex $y_coords 0] \ [lindex $x_coords 1] [lindex $y_coords 1]] lappend opts(bbox) $bbox set config($w) [array get opts] set token bbox$w/[llength $opts(bbox)] return $token } #---------------------------------------------------------------------- # # ::crosshair::bbox_remove -- # # Remove a bounding box for the crosshairs, identified by token. # The crosshairs are confined to the remaining boxes, or not at # all if no boxes remain. # # NOTE: Bounding boxes can overlap to the point of being identical. # # Parameters: # token - The bbox token, identifying both canvas and bbox in it. # # Result: # Nothing. # #---------------------------------------------------------------------- proc ::crosshair::bbox_remove { token } { variable config if {![regexp {^bbox([^/]+)/(\d+)$} -> w index]} { return -code error "Expected a bbox token, got \"$token\"" } if { ![info exists config($w)] } { return -code error "no crosshairs in $w" } array set opts $config($w) # Replace chosen box with nothing. incr index -1 set newboxes [lreplace $opts(bbox) $index $index {}] # Remove empty boxes from the end of the list. while {[llength $newboxes] && ![llength [lindex $newboxes end]]} { set newboxes [lreplace $newboxes end end] } if {![llength $newboxes]} { # Nothing left, disable entirely unset opts(bbox) } else { # Keep remainder. set opts(bbox) $newboxes } set config($w) [array get opts] return } #---------------------------------------------------------------------- # # ::crosshair::track -- # # (De)activates reporting of the cross-hair coordinates through # a user-specified callback. ................................................................................ # #---------------------------------------------------------------------- proc ::crosshair::Hide { w } { variable config if { ![info exists config($w)] } return array set opts $config($w) # Already hidden, do nothing if { $opts(hidden) } return set opts(hidden) 1 # Destroy the parts of a visible cross-hair Kill $w opts set config($w) [array get opts] return } #---------------------------------------------------------------------- # # ::crosshair::Unhide -- ................................................................................ # #---------------------------------------------------------------------- proc ::crosshair::Unhide { w x y } { variable config if { ![info exists config($w)] } return array set opts $config($w) # Already unhidden, do nothing if { !$opts(hidden) } return set opts(hidden) 0 # Recreate cross-hair. This takes the bounding boxes, if any, into # account, i.e. if we are out of bounds nothing will appear. Move $w $x $y return } proc ::crosshair::GetBoundaries { w x y llxv llyv urxv uryv } { upvar 1 $llxv llx $llyv lly $urxv urx $uryv ury variable config array set opts $config($w) # Defaults set llx [$w canvasx 0] set lly [$w canvasy 0] set urx [$w canvasx [winfo width $w]] set ury [$w canvasy [winfo height $w]] # (x) No boxes confining the crosshair. if {![info exists opts(bbox)]} { #puts ANY($x,$y) return 1 } # Determine active boundaries based on the boxes we are in (or not). # NOTE: This is linear in the number of active boundaries on the # canvas. If this is a really large number this will become # slow. If that happens consider creation and maintenance of some # fast data structure (R-tree, or similar) which can take # advantage of overlap and nesting to quickly rule out large # areas. Note that such a structure has its own price in time, # memory, and code complexity. set first 1 foreach box $opts(bbox) { # Ignore removed boxes, not yet cleaned up. Note that we have # at least one active box here to touch by the loop. If we had # none the bbox_remove command ensured that (x) above # triggered. if {![llength $box]} continue # Ignore all boxes we are outside of. They do not go into the # boundary calculation. if {[Outside $box $x $y]} continue # Unfold the box data and check if its boundaries are better # (less restrictive) than we currently have, or if this is the # first restriction. set nllx [lindex $box 0] set nlly [lindex $box 1] set nurx [lindex $box 2] set nury [lindex $box 3] if {$first || ($nllx < $llx)} { set llx $nllx } if {$first || ($nlly > $lly)} { set lly $nlly } if {$first || ($nurx > $urx)} { set urx $nurx } if {$first || ($nury < $ury)} { set ury $nury } set first 0 } if {$first} { # We have boxes limiting us (See both (x)), and we are outside # of all of them. Time to hide the crosshairs. #puts OUT($x,$y) return 0 } # We are inside of some box and have the proper boundaries of # visibility. #puts LIMIT($x,$y):$llx,$lly,$urx,$ury return 1 } proc ::crosshair::Outside { box x y } { # Unfold box set llx [lindex $box 0] set lly [lindex $box 1] set urx [lindex $box 2] set ury [lindex $box 3] #puts \tTEST($x,$y):$llx,$lly,$urx,$ury:[expr {($x < $llx) || ($x > $urx) || ($y < $lly) || ($y > $ury)}] # Test each edge. Note that the border lines are considered as "outside". expr {($x <= $llx) || ($x >= $urx) || ($y >= $lly) || ($y <= $ury)} } #---------------------------------------------------------------------- # # ::crosshair::Move -- # # Moves the crosshairs in a camvas # ................................................................................ # with crosshairs. # #---------------------------------------------------------------------- proc ::crosshair::Move { w x y } { variable config array set opts $config($w) set x [$w canvasx $x] set y [$w canvasy $y] set opts(x) $x set opts(y) $y if {![GetBoundaries $w $x $y opts(x0) opts(y0) opts(x1) opts(y1)]} { # We are out of bounds. Kill the crosshair, store changes, and # return. This last disables the use of the tracking # callback. The crosshairs track only inside the allowed # boxes. Kill $w opts # Store changes back. set config($w) [array get opts] return } # Inside the boundaries, create or move. Place $w opts # Store changes back. set config($w) [array get opts] # And run the tracking callback, if active. if {![info exists opts(track)]} return uplevel \#0 [linsert $opts(track) end \ $w $opts(x) $opts(y) \ $opts(x0) $opts(y0) $opts(x1) $opts(y1)] return } # ### ### ### ######### ######### ######### ## Create, destroy, or modify the parts of a crosshair. proc ::crosshair::Place {w ov} { upvar 1 $ov opts # +/-4 is the minimal possible distance which still prevents the # canvas from choosing the crosshairs as 'current' object under # the cursor. set n 4 set x $opts(x) set y $opts(y) set x0 $opts(x0) set y0 $opts(y0) set x1 $opts(x1) set y1 $opts(y1) set ax [expr {$x-$n}] set bx [expr {$x+$n}] set ay [expr {$y-$n}] set by [expr {$y+$n}] if { [info exists opts(hhairl)] } { # Modify a visible crosshair. $w coords $opts(hhairl) $x0 $y $ax $y $w coords $opts(hhairr) $bx $y $x1 $y $w coords $opts(vhairu) $x $y0 $x $ay $w coords $opts(vhaird) $x $by $x $y1 $w raise $opts(hhairl) $w raise $opts(hhairr) $w raise $opts(vhaird) $w raise $opts(vhairu) } else { # Create a newly visible crosshair. After unhide and/or # entering into one of the active bboxes, if any. set opts(hhairl) [eval [list $w create line $x0 $y $ax $y] $opts(args)] set opts(hhairr) [eval [list $w create line $bx $y $x1 $y] $opts(args)] set opts(vhaird) [eval [list $w create line $x $y0 $x $ay] $opts(args)] set opts(vhairu) [eval [list $w create line $x $by $x $y1] $opts(args)] } return } proc ::crosshair::Kill {w ov} { upvar 1 $ov opts if { ![info exists opts(hhairl)] } return $w delete $opts(hhairl) $w delete $opts(hhairr) $w delete $opts(vhaird) $w delete $opts(vhairu) unset opts(hhairl) unset opts(hhairr) unset opts(vhairu) unset opts(vhaird) return } # ### ### ### ######### ######### ######### ## State namespace eval ::crosshair { # Array holding information describing crosshairs in canvases ................................................................................ bind Crosshair <Leave> "[namespace code Hide] %W" bind Crosshair <Motion> "[namespace code Move] %W %x %y" } # ### ### ### ######### ######### ######### ## Ready package provide crosshair 1.1 |
Changes to modules/crosshair/pkgIndex.tcl.
1 2 |
if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded crosshair 1.0.2 [list source [file join $dir crosshair.tcl]]
|
| |
1 2 |
if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded crosshair 1.1 [list source [file join $dir crosshair.tcl]]
|