KBK 17 July 2003 -
A user in one of the newsgroups has asked about placing crosshairs in the canvas widget. This is another little set of procedures that I've been using for some time but never troubled to post anywhere. It arranges things so that a given canvas contains crosshairs that track the pointing device.
#----------------------------------------------------------------------
#
# 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::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)] } {
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)] } {
$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]
}
#----------------------------------------------------------------------
# Usage example
grid [canvas .foo -width 300 -height 200 -cursor tcross]
crosshair::crosshair .foo -width 0 -fill \#999999
.foo configure -cursor tcross
crosshair::configure .foo -dash {.}