WIP Tk panner widget

diff --git a/yarrg/panner.tcl b/yarrg/panner.tcl
new file mode 100644 (file)
index 0000000..d879443
--- /dev/null
+++ b/yarrg/panner.tcl
@@ -0,0 +1,167 @@
+package provide panner 0.1;
+namespace eval panner {
+
+namespace export -clear
+
+proc pannerproc {name argl body} {
+    proc $name [concat w $argl] "
+    upvar panner::i/\$w d
+$body
+"
+}
+proc pannerproc-export {name argl body} {
+    pannerproc panner-$name $argl $body
+    namespace export panner-$name
+}
+
+proc debug {w m} {
+    puts "PANNER $w $m"
+}
+
+pannerproc-export create {canvas maxwidth maxheight} {
+    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]
+    panner-setcanvas $w $canvas
+}
+pannerproc-export setcolor-background {c} { $w configure -background $c }
+pannerproc-export setcolor-base {c} { $w itemconfigure base -fill $c }
+pannerproc-export setcolor-core {c} { $w itemconfigure core -outline $c }
+
+proc canvas-scroll-bbox {canvas} {
+    $canvas configure -scrollregion [$canvas bbox all]
+}
+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"
+}
+
+pannerproc-export disable {} {
+    debug $w "disable"
+    if {[info exists d(canvas)]} {
+       debug $w "disable unbind"
+       bind $d(canvas) <Configure> [list panner::resize $w]
+       unset d(canvas)
+    }
+    set d(enabled) 0
+    noshow $w
+}
+
+pannerproc noshow {} {
+    debug $w " noshow"
+    $w coords base -5 -5 -5 -5
+    $w coords core -5 -5 -5 -5
+}
+
+pannerproc-export setcanvas {canvas} {
+    debug $w "setcanvas $canvas"
+    panner-disable $w
+    set d(canvas) $canvas
+    panner-updatecanvas $w
+}
+
+proc manyset {list args} {
+    foreach val $list var $args {
+        upvar 1 $var my
+        set my $val
+    }
+}
+
+pannerproc-export updatecanvas-bbox {} {
+    canvas-scroll-bbox $d(canvas)
+    panner-updatecanvas $w
+}
+
+pannerproc-export updatecanvas {} {
+    set d(bbox) [$d(canvas) cget -scrollregion]
+    manyset $d(bbox) x1 y1 x2 y2
+    set d(cwidth) [expr {$x2-$x1}]
+    set d(cheight) [expr {$y2-$y1}]
+    debug $w "updatecanvas bbox=[join $d(bbox) ,] c=$d(cwidth),$d(cheight)"
+
+    set d(enabled) [expr {$d(cwidth) && $d(cheight)}]
+    if {!$d(enabled)} { noshow $w; return }
+
+    # here we only set the pager's _requested_ height
+    set caspect [expr {($x2-$x1) * 1.0 / ($y2-$y1)}]
+    set waspect [expr {($d(maxwidth) - 1.0) / ($d(maxwidth) - 1.0)}]
+
+    if {$caspect >= $waspect} {
+       set too wide
+       set reqh $d(maxheight)
+       set reqw [expr {$d(maxheight) / $caspect}]
+    } else {
+       set too tall
+       set reqw $d(maxwidth)
+       set reqh [expr {$d(maxwidth) * $caspect}]
+    }
+    debug $w "updatecanvas  aspects=$caspect,$waspect too=$too req=$reqw,$reqh"
+    $w configure -width $reqw -height $reqh
+
+    resize $w
+}
+
+pannerproc resize {} {
+    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)"
+    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 corewidth [expr {$scale * $d(cwidth)}]
+    set coreheight [expr {$scale * $d(cheight)}]
+
+    set d(add_xview) [expr {0.5 * ($d(wwidth) - $corewidth)}]
+    set d(add_yview) [expr {0.5 * ($d(wheight) - $coreheight)}]
+    
+    $w coords base \
+       $d(add_xview) \
+       $d(add_yview) \
+       [expr {$corewidth + $d(add_xview)}] \
+       [expr {$coreheight + $d(add_yview)}]
+
+    debug $w "resize     scales=$hscale,$vscale scale=$scale\
+        mul=$d(mul_xview),$d(mul_yview)\
+        add=$d(add_xview),$d(add_yview)\
+        coresz=$corewidth,$coreheight"
+
+    redisplay $w
+}
+
+pannerproc mapc {view which} {
+    set viewpos [lindex [$d(canvas) $view] $which]
+    set r [expr {$viewpos * $d(mul_$view) + $d(add_$view)}]
+    debug $w "  mapc $view wh=$which viewpos=$viewpos => $r"
+    return $r
+}
+
+pannerproc redisplay {} {
+    debug $w "redisplay"
+    $w coords core \
+       [mapc $w xview 0] \
+       [mapc $w yview 0] \
+       [mapc $w xview 1] \
+       [mapc $w yview 1]
+}
+
+}

diff --git a/yarrg/pantest.tcl b/yarrg/pantest.tcl
new file mode 100755 (executable)
index 0000000..53d80f1
--- /dev/null
+++ b/yarrg/pantest.tcl
@@ -0,0 +1,19 @@
+#!/usr/bin/wish
+
+source panner.tcl
+namespace import panner::*
+
+set scale 50
+
+canvas .c
+for {set x -$scale} {$x < 500} {incr x $scale} {
+    for {set y -$scale} {$y < 500} {incr y $scale} {
+       .c create text $x $y -text "${x}x${y}" -anchor sw
+    }
+}
+
+canvas-scroll-bbox .c
+panner-create .p .c 200 200
+
+pack .c -expand y -fill both -side left
+pack .p -side right