Tk Library Source Code

#!/bin/sh
# -*- tcl -*- \
exec tclsh "$0" ${1+"$@"}
# ### ### ### ######### ######### #########

## DEMO. Show pseudo-city map using semi-random (*) street tiles.
##       (*) 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 widget::scrolledwindow
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

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

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

2013-02-25  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* 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  <[email protected]>

	*
	* Released and tagged Tklib 0.5 ========================
	*

2008-11-27  Andreas Kupries  <[email protected]>

	* 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  <[email protected]>

	* crosshair.man: New module and package, crosshairs for
	* crosshair.tcl: Tk canvas. By Kevin Kenny.
	* pkgIndex.tcl:

[comment {-*- tcl -*- doctools manpage}]
[manpage_begin crosshair n 1.1]
[copyright {2003 Kevin Kenny}]
[copyright {2008 (docs) Andreas Kupries <[email protected]>}]
[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]

# 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

if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded crosshair 1.1 [list source [file join $dir crosshair.tcl]]