From: Ian Jackson <ijackson@chiark.greenend.org.uk>
Date: Thu, 10 Dec 2009 18:42:56 +0000 (+0000)
Subject: WIP Tk panner widget - mostly works
X-Git-Tag: 6.3.0~16
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-test.git;a=commitdiff_plain;h=a886cd415dfc89ea1f563b1517b6a0ddebdcc4c3

WIP Tk panner widget - mostly works
---

diff --git a/yarrg/panner.tcl b/yarrg/panner.tcl
index d879443..9f181a7 100644
--- a/yarrg/panner.tcl
+++ b/yarrg/panner.tcl
@@ -14,18 +14,23 @@ proc pannerproc-export {name argl body} {
     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 }
@@ -40,17 +45,16 @@ namespace export canvas-scroll-bbox
 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
@@ -67,6 +71,7 @@ pannerproc-export setcanvas {canvas} {
     debug $w "setcanvas $canvas"
     panner-disable $w
     set d(canvas) $canvas
+    bind $d(canvas) <Configure> [list panner::resize $w c-event]
     panner-updatecanvas $w
 }
 
@@ -108,28 +113,26 @@ pannerproc-export updatecanvas {} {
     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)}]
@@ -140,7 +143,7 @@ pannerproc resize {} {
 	[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"
@@ -164,4 +167,33 @@ pannerproc redisplay {} {
 	[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) }
+}
+
 }
diff --git a/yarrg/pantest.tcl b/yarrg/pantest.tcl
index 53d80f1..b13326e 100755
--- a/yarrg/pantest.tcl
+++ b/yarrg/pantest.tcl
@@ -13,7 +13,7 @@ for {set x -$scale} {$x < 500} {incr x $scale} {
 }
 
 canvas-scroll-bbox .c
-panner-create .p .c 200 200
+panner-create .p .c 200 200 1
 
-pack .c -expand y -fill both -side left
 pack .p -side right
+pack .c -expand y -fill both -side left