
 #----------------------------------------------------------------------
 #
 # 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]
 }

 #----------------------------------------------------------------------

