Support for an IE-like panning tool.
# This program is in the public domain.
#
# Please edit this as you see fit, but update the changelog.
#
# 2003-05-29 Paul Kienzle <pkienzle at users sf net>
# * initial release
# 2003-10-17 Paul Kienzle <pkienzle at users sf net>
# * fix blt graph scrolling so that it is a percentage of the
# zoomed width rather than a percentage of the total width
# 2004-02-06 Paul Kienzle <pkienzle at users sf net>
# * add package commands
# 2004-04-06 Paul Kienzle <pkienzle at users sf net>
# * use bindtags pan_widget for binding
# 2005-09-22 Kevin O'Donovan <odonovan at nist gov>
# * change graph_xview and graph_yview to base pan units on screen pixels
package provide pan 0.3
# Usage:
#
# pan bind $w
#
# Add pan capabilities to a tcl/tk widget, including BLT graphs.
#
# Either middle click to start pan, move the mouse in the direction you
# want to pan followed by any click to stop, or middle press to start
# pan, move the mouse in the direction you want to pan followed by middle
# release to stop. There is a timeout which stops panning after 10 seconds
# of no mouse movement.
#
# pan start $w
#
# Start panning the widget from current mouse position. Use this for
# example from a context sensitive menu with an entry for panning.
#
# Resources:
#
# The .pan widget is a toplevel undecorated window of class Pan
# which contains a label. The single .pan widget is shared by
# all graphs. You can control its features using the usual label
# resources, indicated by *Pan.Label*.
#
# You can control the pan repeat rate (milliseconds) and increment using
# *Pan.Rate: 200
# *Axis.ScrollIncrement: 1
# The step size is scaled linearly with the number of pixels.
# Pan.Accel determines the number of pixels away to increase
# speed by one scrollincrement per repeat.
# *Pan.Accel: 20
# Since we have an application grab, we also have a timeout set.
# *Pan.Timeout: 10000
# Alternatively, you can set the variables ::Pan::rate, ::Pan::accel
# and ::Pan::timeout
#
# Axis.ScrollIncrement is a BLT resource. It is set to 1 at the
# widgetDefault level when pan.tcl is sourced. Be sure to source
# pan.tcl before creating your graphs.
#
# Pan is attached to the middle mouse button. You could for example
# attach it to button 1 using the following in lieu of pan bind
#
# bind $w <ButtonPress-1> { pan start %W %X %Y }
# bind $w <ButtonRelease-1> { pan stop %W }
# bind $w <B1-Motion> { pan move %W %X %Y }
#
# Test using
# $wish pan.tcl
# zoom into a region with the left button and use the middle button to pan.
#
# To do:
# The pan widget and the cursors are not as pretty as they might be.
# Keyboard support --- bind arrow keys to cursor warping events.
namespace eval Pan {
namespace export -clear pan
bind pan_widget <ButtonPress-2> \
[namespace code { pan start %W %X %Y; break }]
bind pan_widget <ButtonRelease-2> \
[namespace code { pan stop %W; break }]
bind pan_widget <B2-Motion> \
[namespace code { pan move %W %X %Y; break }]
# use these cursors to indicate pan direction
variable cursor
array set cursor {
++ bottom_right_corner
+= bottom_side
+- bottom_left_corner
=+ right_side
== fleur
=- left_side
-+ top_right_corner
-= top_side
-- top_left_corner
}
# internal: improved xview and yview for BLT graphs which
# scroll as a number of screen pixels rather than a
# percentage of the entire visible range.
proc graph_xview { w scroll n units } {
foreach slimit {min max} limit [$w xaxis limits] {
set $slimit [$w xaxis transform $limit]
}
if {$max < $min} {
foreach {min max} [list $max $min] break
}
set step [expr {$n*4}]
foreach limit {min max} value [list $min $max] {
set $limit [expr {int($value + $step)}]
}
foreach side { xaxis x2axis } {
foreach axis [$w $side use] {
# find current limits
set omin [$w axis cget $axis -min]
set omax [$w axis cget $axis -max]
# don't scroll if not zoomed
if { "$omin" eq "" || "$omax" eq "" } break
# move limits according to step
set nmin [$w axis invtransform $axis $min]
set nmax [$w axis invtransform $axis $max]
if {$nmax < $nmin} {
foreach {nmin nmax} [list $nmax $nmin] break
}
$w axis configure $axis -min $nmin -max $nmax
}
}
}
proc graph_yview { w scroll n units } {
foreach slimit {min max} limit [$w yaxis limits] {
set $slimit [$w yaxis transform $limit]
}
if {$max < $min} {
foreach {min max} [list $max $min] break
}
set step [expr {$n*4}]
foreach limit {min max} value [list $min $max] {
set $limit [expr {int($value + $step)}]
}
foreach side { yaxis y2axis } {
foreach axis [$w $side use] {
# find current limits
set omin [$w axis cget $axis -min]
set omax [$w axis cget $axis -max]
# don't scroll if not zoomed
if { "$omin" eq "" || "$omax" eq "" } break
# move limits according to step
set nmin [$w axis invtransform $axis $min]
set nmax [$w axis invtransform $axis $max]
if {$nmax < $nmin} {
foreach {nmin nmax} [list $nmax $nmin] break
}
$w axis configure $axis -min $nmin -max $nmax
}
}
}
# internal: convert a direction to a cursor code
proc dir { value } {
if { $value > 0 } {
return +
} elseif { $value < 0 } {
return -
} else {
return =
}
}
# pan actions
proc pan { action { w {} } { x {} } { y {} } } {
variable timeout
variable rate
variable accel
variable cursor
variable pan
switch $action {
init { # initialize the pan icon (only called once)
# Create pan icon
toplevel .pan -class Pan
wm overrideredirect .pan 1
wm withdraw .pan
.pan configure -cursor $cursor(==)
option add *Pan.Label.Background yellow widgetDefault
option add *Pan.Label.Relief raised widgetDefault
pack [label .pan.label -text Pan]
# Get resources
foreach {var val} { rate 200 accel 20 timeout 10000 } {
if {![info exists $var]} {
set tvar [string totitle $var]
option add *Pan.$tvar $val widgetDefault
set $var [option get .pan $var $tvar]
}
}
# Make sure future graphs use a small increment
option add *Axis.ScrollIncrement 1 widgetDefault
}
bind { # bind panning to a widget
bindtags $w [concat pan_widget [bindtags $w]]
}
start { # start panning
if { [info exists pan($w,x)] } { return }
# if no x-position, start from current cursor --- this
# can happen if panning is triggered by something other
# than the mouse bindings, such as a context sensitive
# menu.
if { [llength $x] == 0 } {
foreach { x y } [winfo pointerxy .] break
}
# remember the initial state
set pan($w,x) $x
set pan($w,y) $y
set pan($w,v) 0
set pan($w,h) 0
set pan($w,cursor) [$w cget -cursor]
set pan($w,focus) [focus]
# set the cursor
$w configure -cursor $cursor(==)
.pan configure -cursor $cursor(==)
# display the pan icon
set xpos [expr {$x-[winfo width .pan]/2}]
set ypos [expr {$y-[winfo height .pan]/2}]
wm geometry .pan +$xpos+$ypos
wm deiconify .pan
raise .pan
# associate panning actions with the current widget
bind .pan <Motion> [namespace code [list pan move $w %X %Y]]
bind .pan <ButtonPress> [list array set [namespace which -variable pan] [list $w,motion 1]]
bind .pan <ButtonRelease> [namespace code [list pan stop $w]]
grab set .pan
# start panning --- don't really need to start until
# after the mouse moves, but it doesn't seem to hurt
# anything starting immediately
after 0 [namespace code [list pan step $w]]
# set timeout
after $timeout [namespace code [list pan cancel $w]]
}
move { # mouse motion
if { ![info exists pan($w,x)] } { return }
# compute new step size
set v [expr {$y - $pan($w,y)}]
set h [expr {$x - $pan($w,x)}]
set pan($w,v) [expr {$v/$accel}]
set pan($w,h) [expr {$h/$accel}]
if {$v < 0} {incr pan($w,v)}
if {$h < 0} {incr pan($w,h)}
# puts "$v $vstep $vsign $h $hstep $hsign"
# set new cursor
$w configure -cursor $cursor([dir $pan($w,v)][dir $pan($w,h)])
.pan configure -cursor $cursor([dir $pan($w,v)][dir $pan($w,h)])
# remember that there is motion --- if there is no motion
# between press and release, then it is a click action and
# the pan icon stays until the next click.
set pan($w,motion) 1
# reset timeout
after cancel [namespace code [list pan cancel $w]]
after $timeout [namespace code [list pan cancel $w]]
}
step { # do the panning
if { ![info exists pan($w,x)] } { return }
# handle blt::graph specially --- perhaps want to generalize
# so that we can add functions for all widgets that do not
# support xview/yview.
if { [winfo class $w] == "Graph" } {
graph_xview $w scroll $pan($w,h) units
graph_yview $w scroll $pan($w,v) units
} else {
$w xview scroll $pan($w,h) units
$w yview scroll $pan($w,v) units
}
# program the next step
after $rate [namespace code [list pan step $w]]
}
stop { # button release
# if the mouse hasn't moved yet, don't cancel panning
if { [info exists pan($w,motion)] } { pan cancel $w }
}
cancel { # cancel panning for whatever reason
if { ![info exists pan($w,x)] } { return }
# restore state
grab release .pan
wm withdraw .pan
$w configure -cursor $pan($w,cursor)
focus $pan($w,focus)
# clear variables
foreach el [array names pan "$w,*"] { unset pan($el) }
# stop panning update
after cancel [namespace code [list pan step $w]]
# stop timeout
after cancel [namespace code [list pan cancel $w]]
}
}
}
# initialize pan widget
# use catch so that the file can be sourced multiple times
catch { pan init }
}
namespace eval :: {namespace import -force ::Pan::pan}
# Test code
if {[info exists argv0] && [file tail [info script]]==[file tail $argv0]} {
catch {
# add a blt graph if blt is available
package require BLT
blt::graph .g
.g elem create x -xdata { 1 1.2 1.4 1.6 1.8 1.9 2 3 4 5 } \
-ydata { 2 1.8 1.7 1.5 1.3 1.1 1 3 1 2 }
Blt_ZoomStack .g
pan bind .g
grid .g - -sticky news
}
# add a text widget
text .t -width 10 -height 5 -wrap no \
-xscrollcommand { .h set } -yscrollcommand { .v set }
scrollbar .h -orient h -command { .t xview }
scrollbar .v -orient v -command { .t yview }
.t insert end "1 This is a bunch of text which I am using to test the panning capabilities\n2 of the text widget.\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n20\n21\n22 end of text ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- really!"
pan bind .t
grid .t x -sticky news
grid .h x -sticky ew
grid .v -row 1 -column 1 -sticky ns
grid columnconfigure . 0 -weight 1
}