+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]
+}
+
+}