1 package provide panner 0.1;
2 namespace eval panner {
4 proc pannerproc {name argl body} {
5 proc $name [concat w $argl] "
10 pannerproc _debug {m {minlevel 1}} {
11 if {$d(debug) < $minlevel} return
15 pannerproc create {canvas maxwidth maxheight {debug 0}} {
17 _debug $w "create $canvas $maxwidth,$maxheight"
18 set d(maxwidth) $maxwidth
19 set d(maxheight) $maxheight
21 $w create rectangle -5 -5 -5 -5 -tags base -outline {} -fill black
22 $w create rectangle -5 -5 -5 -5 -tags core -outline blue
23 bind $w <Configure> [list panner::_resize $w w-event]
24 bind $w <ButtonPress> [list panner::_press $w %b %x %y]
25 bind $w <B1-Motion> [list panner::_motion $w %x %y]
26 bind $w <B1-ButtonRelease> [list panner::_release $w %x %y]
29 pannerproc setcolor-background {c} { $w configure -background $c }
30 pannerproc setcolor-base {c} { $w itemconfigure base -fill $c }
31 pannerproc setcolor-core {c} { $w itemconfigure core -outline $c }
33 proc canvas-scroll-bbox {canvas} {
34 $canvas configure -scrollregion [$canvas bbox all]
36 namespace export canvas-scroll-bbox
38 pannerproc destroy {w} {
46 pannerproc disable {} {
48 if {[info exists d(canvas)]} {
49 _debug $w "disable unbind"
50 bind $d(canvas) <Configure> {}
57 pannerproc _noshow {} {
59 $w coords base -5 -5 -5 -5
60 $w coords core -5 -5 -5 -5
63 pannerproc setcanvas {canvas} {
64 _debug $w "setcanvas $canvas"
67 bind $d(canvas) <Configure> [list panner::_resize $w c-event]
71 proc manyset {list args} {
72 foreach val $list var $args {
78 pannerproc updatecanvas-bbox {} {
79 canvas-scroll-bbox $d(canvas)
83 pannerproc updatecanvas {} {
84 set d(bbox) [$d(canvas) cget -scrollregion]
85 if {[llength $d(bbox)] < 4} { set d(enabled) 0; _noshow $w; return }
87 manyset $d(bbox) x1 y1 x2 y2
88 set d(cwidth) [expr {$x2-$x1}]
89 set d(cheight) [expr {$y2-$y1}]
90 _debug $w "updatecanvas bbox=[join $d(bbox) ,] c=$d(cwidth),$d(cheight)"
92 set d(enabled) [expr {$d(cwidth) && $d(cheight)}]
93 if {!$d(enabled)} { _noshow $w; return }
95 # here we only set the pager's _requested_ height
96 set caspect [expr {($x2-$x1) * 1.0 / ($y2-$y1)}]
97 set waspect [expr {($d(maxwidth) - 1.0) / ($d(maxwidth) - 1.0)}]
99 if {$caspect >= $waspect} {
101 set reqh $d(maxheight)
102 set reqw [expr {$d(maxheight) / $caspect}]
105 set reqw $d(maxwidth)
106 set reqh [expr {$d(maxwidth) * $caspect}]
108 _debug $w "updatecanvas aspects=$caspect,$waspect too=$too req=$reqw,$reqh"
109 $w configure -width $reqw -height $reqh
114 pannerproc _resize {why} {
117 set d(wwidth) [winfo width $w]
118 set d(wheight) [winfo height $w]
120 _debug $w "_resize $why w=$d(wwidth),$d(wheight)"
121 if {!$d(enabled) || $d(wwidth)<2 || $d(wheight)<2} return
123 set hscale [expr {$d(wwidth) * 1.0 / $d(cwidth)}]
124 set vscale [expr {$d(wheight) * 1.0 / $d(cheight)}]
125 set d(scale) [expr {$hscale < $vscale ? $hscale : $vscale}]
126 set d(mul_xview) [expr {$d(cwidth) * $d(scale)}]
127 set d(mul_yview) [expr {$d(cheight) * $d(scale)}]
129 set corewidth [expr {$d(scale) * $d(cwidth)}]
130 set coreheight [expr {$d(scale) * $d(cheight)}]
132 set d(add_xview) [expr {0.5 * ($d(wwidth) - $corewidth)}]
133 set d(add_yview) [expr {0.5 * ($d(wheight) - $coreheight)}]
138 [expr {$corewidth + $d(add_xview)}] \
139 [expr {$coreheight + $d(add_yview)}]
141 _debug $w "_resize scales=$hscale,$vscale scale=$d(scale)\
142 mul=$d(mul_xview),$d(mul_yview)\
143 add=$d(add_xview),$d(add_yview)\
144 coresz=$corewidth,$coreheight"
149 pannerproc _mapc {view which} {
150 set viewpos [lindex [$d(canvas) $view] $which]
151 set r [expr {$viewpos * $d(mul_$view) + $d(add_$view)}]
152 _debug $w " _mapc $view wh=$which viewpos=$viewpos => $r" 2
156 pannerproc _redisplay {} {
157 _debug $w "_redisplay" 2
165 pannerproc _press {b x y} {
169 set d(down_xview) [lindex [$d(canvas) xview] 0]
170 set d(down_yview) [lindex [$d(canvas) yview] 0]
171 _debug $w "_press down=$x,$y view=$d(down_xview),$d(down_yview)"
174 pannerproc _motion {x y} {
175 if {![info exists d(down_x)]} return
176 foreach xy {x y} wh {width height} {
178 ([set $xy] - $d(down_$xy)) / $d(scale) / $d(c$wh)
181 $d(canvas) ${xy}view moveto $newpos
184 _debug $w "_motion $x,$y [join $dl ,]" 2
188 pannerproc _release {x y} {
189 _debug $w "_release $x,$y"
191 catch { unset d(down_x) }