Artifact
d358b71e54ddcfaf51edcdf998d258dc927965d3:
Attachment "crosshair.tcl" to
ticket [3603562fff]
added by
franktx
2013-02-07 13:29:54.
#----------------------------------------------------------------------
#
# crosshair.tcl -
#
# Display 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
#
#----------------------------------------------------------------------
namespace eval crosshair {
# Holds information describing crosshairs in canvases
variable config
# Controller that positions crosshairs according to user actions
bind Crosshair <Destroy> "[namespace code off] %W"
bind Crosshair <Enter> "[namespace code unhide] %W %x %y"
bind Crosshair <Leave> "[namespace code hide] %W"
bind Crosshair <Motion> "[namespace code move] %W %x %y"
}
#----------------------------------------------------------------------
#
# crosshair::crosshair --
#
# Displays a pair of cross-hairs in a canvas widget. The
# cross-hairs track the pointing device.
#
# Parameters:
# w - The path name of the canvas
# args - Remaining args are treated as options as for
# [$w create line]. Of particular interest are
# -fill and -dash.
#
# Results:
# None.
#
# Side effects:
# Adds the 'crosshair' bind tag to the widget so that
# 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
}
#----------------------------------------------------------------------
#
# crosshair::off -
#
# Removes the crosshairs from a canvas widget
#
# Parameters:
# w - The canvas from which the crosshairs should be removed
#
# Results:
# None.
#
# Side effects:
# If the widget has crosshairs, they are removed. The 'Crosshair'
# bind tag is removed so that mouse motion will not restore them.
#
#----------------------------------------------------------------------
proc crosshair::off { w } {
variable config
if { ![info exists config($w)] } return
array set opts $config($w)
if { [winfo exists $w] } {
hide
set bindtags [bindtags $w]
set pos [lsearch -exact $bindtags Configure]
if { $pos >= 0 } {
eval [list bindtags $w] [lreplace $bindtags $pos $pos]
}
}
unset config($w)
return
}
#----------------------------------------------------------------------
#
# crosshair::configure --
#
# Changes the appearance of crosshairs in the canvas widget.
#
# Parameters:
# w - Path name of the widget
# args - Additional args are flags to [$w create line]. Interesting
# ones include -fill and -dash
#
# Results:
# Returns the crosshairs' current configuration settings.
#
#----------------------------------------------------------------------
proc crosshair::configure { w args } {
variable config
if { ![info exists config($w)] } {
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(hhair)] } {
eval [list $w itemconfig $opts(hhair)] $args
eval [list $w itemconfig $opts(vhair)] $args
}
set config($w) [array get opts]
}
return $opts(args)
}
#----------------------------------------------------------------------
#
# crosshair::bbox --
#
# Confines the crosshairs to an area in the canvas widget.
#
# Parameters:
# w - Path name of the widget
# bbox - Area in the canvas. A list 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
#
#----------------------------------------------------------------------
proc crosshair::bbox { w bbox } {
variable config
if { ![info exists config($w)] } {
return -code error "no crosshairs in $w"
}
array set opts $config($w)
set opts(bbox_llx) [lindex $bbox 0]
set opts(bbox_lly) [lindex $bbox 1]
set opts(bbox_urx) [lindex $bbox 2]
set opts(bbox_ury) [lindex $bbox 3]
set config($w) [array get opts]
}
#----------------------------------------------------------------------
#
# crosshair::hide --
#
# Hides the crosshair temporarily
#
# Parameters:
# w - Canvas widget containing crosshairs
#
# Results:
# None.
#
# Side effects:
# If the canvas contains crosshairs, they are hidden.
#
# This procedure is invoked in response to the <Leave> event to
# hide the crosshair when the pointer is not in the window.
#
#----------------------------------------------------------------------
proc crosshair::hide { w } {
variable config
if { ![info exists config($w)] } return
array set opts $config($w)
if { ![info exists opts(hhair)] } return
$w delete $opts(hhair)
$w delete $opts(vhair)
unset opts(hhair)
unset opts(vhair)
set config($w) [array get opts]
return
}
#----------------------------------------------------------------------
#
# crosshair::unhide --
#
# Places a hidden crosshair back on display
#
# Parameters:
# w - Canvas widget containing crosshairs
# x - x co-ordinate relative to the window where the vertical
# crosshair should appear
# y - y co-ordinate relative to the window where the horizontal
# crosshair should appear.
#
# Results:
# None.
#
# Side effects:
# Crosshairs are put on display.
#
# This procedure is invoked in response to the <Enter> event to
# restore the crosshair to the display.
#
#----------------------------------------------------------------------
proc crosshair::unhide { w x y } {
variable config
if { ![info exists config($w)] } return
array set opts $config($w)
if { ![info exists opts(hhair)] } {
if {[info exists opts(bbox_llx)] } {
set opts(hhair) [eval [list $w create line $opts(bbox_llx) $opts(bbox_lly) $opts(bbox_llx) $opts(bbox_lly)] $opts(args)]
set opts(vhair) [eval [list $w create line $opts(bbox_llx) $opts(bbox_lly) $opts(bbox_llx) $opts(bbox_lly)] $opts(args)]
} else {
set opts(hhair) [eval [list $w create line 0 0 0 0] $opts(args)]
set opts(vhair) [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
#
# Parameters:
# w - Canvas widget containing crosshairs
# x - x co-ordinate relative to the window where the vertical
# crosshair should appear
# y - y co-ordinate relative to the window where the horizontal
# crosshair should appear.
#
# Results:
# None.
#
# Side effects:
# Crosshairs move.
#
# This procedure is called in response to a <Move> event in a canvas
# 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(hhair)] } {
if {[info exists opts(bbox_llx)]} {
if {($opts(x) >= $opts(bbox_llx)) && ($opts(x) <= $opts(bbox_urx))
&& ($opts(y) <= $opts(bbox_lly)) && ($opts(y) >= $opts(bbox_ury)) } {
$w coords $opts(hhair) $opts(bbox_llx) $opts(y) $opts(bbox_urx) $opts(y)
$w coords $opts(vhair) $opts(x) $opts(bbox_lly) $opts(x) $opts(bbox_ury)
$w raise $opts(hhair)
$w raise $opts(vhair)
}
} else {
$w coords $opts(hhair) $opts(x0) $opts(y) $opts(x1) $opts(y)
$w coords $opts(vhair) $opts(x) $opts(y0) $opts(x) $opts(y1)
$w raise $opts(hhair)
$w raise $opts(vhair)
}
}
set config($w) [array get opts]
}
#----------------------------------------------------------------------
