namespace export panner-$name
}
-proc debug {w m} {
+pannerproc debug {m} {
+ if {!$d(debug)} return
puts "PANNER $w $m"
}
-pannerproc-export create {canvas maxwidth maxheight} {
+pannerproc-export create {canvas maxwidth maxheight {debug 0}} {
+ set d(debug) $debug
debug $w "create $canvas $maxwidth,$maxheight"
set d(maxwidth) $maxwidth
set d(maxheight) $maxheight
canvas $w
$w create rectangle -5 -5 -5 -5 -tags base -outline {} -fill black
$w create rectangle -5 -5 -5 -5 -tags core -outline blue
- bind $w <Configure> [list panner::resize $w]
+ bind $w <Configure> [list panner::resize $w w-event]
+ bind $w <ButtonPress> [list panner::press $w %b %x %y]
+ bind $w <B1-Motion> [list panner::motion $w %x %y]
+ bind $w <B1-ButtonRelease> [list panner::release $w %x %y]
panner-setcanvas $w $canvas
}
pannerproc-export setcolor-background {c} { $w configure -background $c }
pannerproc-export destroy {w} {
debug $w "destroy"
panner-disable $w
- bind $d(canvas) <Configure> {}
destroy $w
- unset d
debug $w "destroyed"
+ unset d
}
pannerproc-export disable {} {
debug $w "disable"
if {[info exists d(canvas)]} {
debug $w "disable unbind"
- bind $d(canvas) <Configure> [list panner::resize $w]
+ bind $d(canvas) <Configure> {}
unset d(canvas)
}
set d(enabled) 0
debug $w "setcanvas $canvas"
panner-disable $w
set d(canvas) $canvas
+ bind $d(canvas) <Configure> [list panner::resize $w c-event]
panner-updatecanvas $w
}
debug $w "updatecanvas aspects=$caspect,$waspect too=$too req=$reqw,$reqh"
$w configure -width $reqw -height $reqh
- resize $w
+ resize $w c-update
}
-pannerproc resize {} {
+pannerproc resize {why} {
noshow $w
- #set d(vwidth) [winfo width $d(canvas)]
- #set d(vheight) [winfo height $d(canvas)]
-
set d(wwidth) [winfo width $w]
set d(wheight) [winfo height $w]
- debug $w "resize w=$d(wwidth),$d(wheight)"
+
+ debug $w "resize $why w=$d(wwidth),$d(wheight)"
if {!$d(enabled) || $d(wwidth)<2 || $d(wheight)<2} return
set hscale [expr {$d(wwidth) * 1.0 / $d(cwidth)}]
set vscale [expr {$d(wheight) * 1.0 / $d(cheight)}]
- set scale [expr {$hscale < $vscale ? $hscale : $vscale}]
- set d(mul_xview) [expr {$d(cwidth) * $scale}]
- set d(mul_yview) [expr {$d(cheight) * $scale}]
+ set d(scale) [expr {$hscale < $vscale ? $hscale : $vscale}]
+ set d(mul_xview) [expr {$d(cwidth) * $d(scale)}]
+ set d(mul_yview) [expr {$d(cheight) * $d(scale)}]
- set corewidth [expr {$scale * $d(cwidth)}]
- set coreheight [expr {$scale * $d(cheight)}]
+ set corewidth [expr {$d(scale) * $d(cwidth)}]
+ set coreheight [expr {$d(scale) * $d(cheight)}]
set d(add_xview) [expr {0.5 * ($d(wwidth) - $corewidth)}]
set d(add_yview) [expr {0.5 * ($d(wheight) - $coreheight)}]
[expr {$corewidth + $d(add_xview)}] \
[expr {$coreheight + $d(add_yview)}]
- debug $w "resize scales=$hscale,$vscale scale=$scale\
+ debug $w "resize scales=$hscale,$vscale scale=$d(scale)\
mul=$d(mul_xview),$d(mul_yview)\
add=$d(add_xview),$d(add_yview)\
coresz=$corewidth,$coreheight"
[mapc $w yview 1]
}
+pannerproc press {b x y} {
+ if {$b != 1} return
+ set d(down_x) $x
+ set d(down_y) $y
+ set d(down_xview) [lindex [$d(canvas) xview] 0]
+ set d(down_yview) [lindex [$d(canvas) yview] 0]
+ debug $w "press down=$x,$y view=$d(down_xview),$d(down_yview)"
+}
+
+pannerproc motion {x y} {
+ if {![info exists d(down_x)]} return
+ foreach xy {x y} wh {width height} {
+ set newpos [expr {
+ ([set $xy] - $d(down_$xy)) / $d(scale) / $d(c$wh)
+ + $d(down_${xy}view)
+ }]
+ $d(canvas) ${xy}view moveto $newpos
+ lappend dl $newpos
+ }
+ debug $w "motion $x,$y [join $dl ,]"
+ redisplay $w
+}
+
+pannerproc release {x y} {
+ debug $w "release $x,$y"
+ motion $w $x $y
+ catch { unset d(down_x) }
+}
+
}