1 package provide panner 0.1;
2 namespace eval panner {
4 namespace export -clear
6 proc pannerproc {name argl body} {
7 proc $name [concat w $argl] "
12 proc pannerproc-export {name argl body} {
13 pannerproc panner-$name $argl $body
14 namespace export panner-$name
17 pannerproc debug {m} {
18 if {!$d(debug)} return
22 pannerproc-export create {canvas maxwidth maxheight {debug 0}} {
24 debug $w "create $canvas $maxwidth,$maxheight"
25 set d(maxwidth) $maxwidth
26 set d(maxheight) $maxheight
28 $w create rectangle -5 -5 -5 -5 -tags base -outline {} -fill black
29 $w create rectangle -5 -5 -5 -5 -tags core -outline blue
30 bind $w <Configure> [list panner::resize $w w-event]
31 bind $w <ButtonPress> [list panner::press $w %b %x %y]
32 bind $w <B1-Motion> [list panner::motion $w %x %y]
33 bind $w <B1-ButtonRelease> [list panner::release $w %x %y]
34 panner-setcanvas $w $canvas
36 pannerproc-export setcolor-background {c} { $w configure -background $c }
37 pannerproc-export setcolor-base {c} { $w itemconfigure base -fill $c }
38 pannerproc-export setcolor-core {c} { $w itemconfigure core -outline $c }
40 proc canvas-scroll-bbox {canvas} {
41 $canvas configure -scrollregion [$canvas bbox all]
43 namespace export canvas-scroll-bbox
45 pannerproc-export destroy {w} {
53 pannerproc-export disable {} {
55 if {[info exists d(canvas)]} {
56 debug $w "disable unbind"
57 bind $d(canvas) <Configure> {}
64 pannerproc noshow {} {
66 $w coords base -5 -5 -5 -5
67 $w coords core -5 -5 -5 -5
70 pannerproc-export setcanvas {canvas} {
71 debug $w "setcanvas $canvas"
74 bind $d(canvas) <Configure> [list panner::resize $w c-event]
75 panner-updatecanvas $w
78 proc manyset {list args} {
79 foreach val $list var $args {
85 pannerproc-export updatecanvas-bbox {} {
86 canvas-scroll-bbox $d(canvas)
87 panner-updatecanvas $w
90 pannerproc-export updatecanvas {} {
91 set d(bbox) [$d(canvas) cget -scrollregion]
92 manyset $d(bbox) x1 y1 x2 y2
93 set d(cwidth) [expr {$x2-$x1}]
94 set d(cheight) [expr {$y2-$y1}]
95 debug $w "updatecanvas bbox=[join $d(bbox) ,] c=$d(cwidth),$d(cheight)"
97 set d(enabled) [expr {$d(cwidth) && $d(cheight)}]
98 if {!$d(enabled)} { noshow $w; return }
100 # here we only set the pager's _requested_ height
101 set caspect [expr {($x2-$x1) * 1.0 / ($y2-$y1)}]
102 set waspect [expr {($d(maxwidth) - 1.0) / ($d(maxwidth) - 1.0)}]
104 if {$caspect >= $waspect} {
106 set reqh $d(maxheight)
107 set reqw [expr {$d(maxheight) / $caspect}]
110 set reqw $d(maxwidth)
111 set reqh [expr {$d(maxwidth) * $caspect}]
113 debug $w "updatecanvas aspects=$caspect,$waspect too=$too req=$reqw,$reqh"
114 $w configure -width $reqw -height $reqh
119 pannerproc resize {why} {
122 set d(wwidth) [winfo width $w]
123 set d(wheight) [winfo height $w]
125 debug $w "resize $why w=$d(wwidth),$d(wheight)"
126 if {!$d(enabled) || $d(wwidth)<2 || $d(wheight)<2} return
128 set hscale [expr {$d(wwidth) * 1.0 / $d(cwidth)}]
129 set vscale [expr {$d(wheight) * 1.0 / $d(cheight)}]
130 set d(scale) [expr {$hscale < $vscale ? $hscale : $vscale}]
131 set d(mul_xview) [expr {$d(cwidth) * $d(scale)}]
132 set d(mul_yview) [expr {$d(cheight) * $d(scale)}]
134 set corewidth [expr {$d(scale) * $d(cwidth)}]
135 set coreheight [expr {$d(scale) * $d(cheight)}]
137 set d(add_xview) [expr {0.5 * ($d(wwidth) - $corewidth)}]
138 set d(add_yview) [expr {0.5 * ($d(wheight) - $coreheight)}]
143 [expr {$corewidth + $d(add_xview)}] \
144 [expr {$coreheight + $d(add_yview)}]
146 debug $w "resize scales=$hscale,$vscale scale=$d(scale)\
147 mul=$d(mul_xview),$d(mul_yview)\
148 add=$d(add_xview),$d(add_yview)\
149 coresz=$corewidth,$coreheight"
154 pannerproc mapc {view which} {
155 set viewpos [lindex [$d(canvas) $view] $which]
156 set r [expr {$viewpos * $d(mul_$view) + $d(add_$view)}]
157 debug $w " mapc $view wh=$which viewpos=$viewpos => $r"
161 pannerproc redisplay {} {
170 pannerproc press {b x y} {
174 set d(down_xview) [lindex [$d(canvas) xview] 0]
175 set d(down_yview) [lindex [$d(canvas) yview] 0]
176 debug $w "press down=$x,$y view=$d(down_xview),$d(down_yview)"
179 pannerproc motion {x y} {
180 if {![info exists d(down_x)]} return
181 foreach xy {x y} wh {width height} {
183 ([set $xy] - $d(down_$xy)) / $d(scale) / $d(c$wh)
186 $d(canvas) ${xy}view moveto $newpos
189 debug $w "motion $x,$y [join $dl ,]"
193 pannerproc release {x y} {
194 debug $w "release $x,$y"
196 catch { unset d(down_x) }