chiark / gitweb /
9f181a7c05f79af28200753c812c71c58f3c9e7c
[ypp-sc-tools.db-live.git] / yarrg / panner.tcl
1 package provide panner 0.1;
2 namespace eval panner {
3
4 namespace export -clear
5
6 proc pannerproc {name argl body} {
7     proc $name [concat w $argl] "
8     upvar panner::i/\$w d
9 $body
10 "
11 }
12 proc pannerproc-export {name argl body} {
13     pannerproc panner-$name $argl $body
14     namespace export panner-$name
15 }
16
17 pannerproc debug {m} {
18     if {!$d(debug)} return
19     puts "PANNER $w $m"
20 }
21
22 pannerproc-export create {canvas maxwidth maxheight {debug 0}} {
23     set d(debug) $debug
24     debug $w "create $canvas $maxwidth,$maxheight"
25     set d(maxwidth) $maxwidth
26     set d(maxheight) $maxheight
27     canvas $w
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
35 }
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 }
39
40 proc canvas-scroll-bbox {canvas} {
41     $canvas configure -scrollregion [$canvas bbox all]
42 }
43 namespace export canvas-scroll-bbox
44
45 pannerproc-export destroy {w} {
46     debug $w "destroy"
47     panner-disable $w
48     destroy $w
49     debug $w "destroyed"
50     unset d
51 }
52
53 pannerproc-export disable {} {
54     debug $w "disable"
55     if {[info exists d(canvas)]} {
56         debug $w "disable unbind"
57         bind $d(canvas) <Configure> {}
58         unset d(canvas)
59     }
60     set d(enabled) 0
61     noshow $w
62 }
63
64 pannerproc noshow {} {
65     debug $w " noshow"
66     $w coords base -5 -5 -5 -5
67     $w coords core -5 -5 -5 -5
68 }
69
70 pannerproc-export setcanvas {canvas} {
71     debug $w "setcanvas $canvas"
72     panner-disable $w
73     set d(canvas) $canvas
74     bind $d(canvas) <Configure> [list panner::resize $w c-event]
75     panner-updatecanvas $w
76 }
77
78 proc manyset {list args} {
79     foreach val $list var $args {
80         upvar 1 $var my
81         set my $val
82     }
83 }
84
85 pannerproc-export updatecanvas-bbox {} {
86     canvas-scroll-bbox $d(canvas)
87     panner-updatecanvas $w
88 }
89
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)"
96
97     set d(enabled) [expr {$d(cwidth) && $d(cheight)}]
98     if {!$d(enabled)} { noshow $w; return }
99
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)}]
103
104     if {$caspect >= $waspect} {
105         set too wide
106         set reqh $d(maxheight)
107         set reqw [expr {$d(maxheight) / $caspect}]
108     } else {
109         set too tall
110         set reqw $d(maxwidth)
111         set reqh [expr {$d(maxwidth) * $caspect}]
112     }
113     debug $w "updatecanvas  aspects=$caspect,$waspect too=$too req=$reqw,$reqh"
114     $w configure -width $reqw -height $reqh
115
116     resize $w c-update
117 }
118
119 pannerproc resize {why} {
120     noshow $w
121
122     set d(wwidth) [winfo width $w]
123     set d(wheight) [winfo height $w]
124
125     debug $w "resize $why w=$d(wwidth),$d(wheight)"
126     if {!$d(enabled) || $d(wwidth)<2 || $d(wheight)<2} return
127
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)}]
133
134     set corewidth [expr {$d(scale) * $d(cwidth)}]
135     set coreheight [expr {$d(scale) * $d(cheight)}]
136
137     set d(add_xview) [expr {0.5 * ($d(wwidth) - $corewidth)}]
138     set d(add_yview) [expr {0.5 * ($d(wheight) - $coreheight)}]
139     
140     $w coords base \
141         $d(add_xview) \
142         $d(add_yview) \
143         [expr {$corewidth + $d(add_xview)}] \
144         [expr {$coreheight + $d(add_yview)}]
145
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"
150
151     redisplay $w
152 }
153
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"
158     return $r
159 }
160
161 pannerproc redisplay {} {
162     debug $w "redisplay"
163     $w coords core \
164         [mapc $w xview 0] \
165         [mapc $w yview 0] \
166         [mapc $w xview 1] \
167         [mapc $w yview 1]
168 }
169
170 pannerproc press {b x y} {
171     if {$b != 1} return
172     set d(down_x) $x
173     set d(down_y) $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)"
177 }
178
179 pannerproc motion {x y} {
180     if {![info exists d(down_x)]} return
181     foreach xy {x y} wh {width height} {
182         set newpos [expr {
183               ([set $xy] - $d(down_$xy)) / $d(scale) / $d(c$wh)
184               + $d(down_${xy}view)
185           }]
186         $d(canvas) ${xy}view moveto $newpos
187         lappend dl $newpos
188     }
189     debug $w "motion $x,$y [join $dl ,]"
190     redisplay $w
191 }
192
193 pannerproc release {x y} {
194     debug $w "release $x,$y"
195     motion $w $x $y
196     catch { unset d(down_x) }
197 }
198
199 }