chiark / gitweb /
Obsidian: Add islands where chart scraper is confused
[ypp-sc-tools.db-test.git] / yarrg / panner.tcl
1 # -*- Tcl -*-
2 # Tcl panner widget
3
4 # This is part of ypp-sc-tools, a set of third-party tools for assisting
5 # players of Yohoho Puzzle Pirates.
6 #
7 # Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
8 #
9 # This program is free software: you can redistribute it and/or modify
10 # it under the terms of the GNU General Public License as published by
11 # the Free Software Foundation, either version 3 of the License, or
12 # (at your option) any later version.
13 #
14 # This program is distributed in the hope that it will be useful,
15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 # GNU General Public License for more details.
18 #
19 # You should have received a copy of the GNU General Public License
20 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
21 #
22 # Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
23 # are used without permission.  This program is not endorsed or
24 # sponsored by Three Rings.
25
26
27 package provide panner 0.1;
28 namespace eval panner {
29
30 proc pannerproc {name argl body} {
31     proc $name [concat w $argl] "
32     upvar panner::i/\$w d
33 $body
34 "
35 }
36 pannerproc _debug {m {minlevel 1}} {
37     if {$d(debug) < $minlevel} return
38     puts "PANNER $w $m"
39 }
40
41 pannerproc create {canvas maxwidth maxheight {debug 0}} {
42     set d(debug) $debug
43     _debug $w "create $canvas $maxwidth,$maxheight"
44     set d(maxwidth) $maxwidth
45     set d(maxheight) $maxheight
46     canvas $w
47     $w create rectangle -5 -5 -5 -5 -tags base -outline {} -fill black
48     $w create rectangle -5 -5 -5 -5 -tags core -outline blue
49     bind $w <Configure> [list panner::_resize $w w-event]
50     bind $w <ButtonPress> [list panner::_press $w %b %x %y]
51     bind $w <B1-Motion> [list panner::_motion $w %x %y]
52     bind $w <B1-ButtonRelease> [list panner::_release $w %x %y]
53     setcanvas $w $canvas
54 }
55 pannerproc setcolor-background {c} { $w configure -background $c }
56 pannerproc setcolor-base {c} { $w itemconfigure base -fill $c }
57 pannerproc setcolor-core {c} { $w itemconfigure core -outline $c }
58
59 proc canvas-scroll-bbox {canvas} {
60     $canvas configure -scrollregion [$canvas bbox all]
61 }
62 namespace export canvas-scroll-bbox
63
64 pannerproc destroy {w} {
65     _debug $w "destroy"
66     disable $w
67     destroy $w
68     _debug $w "destroyed"
69     unset d
70 }
71
72 pannerproc disable {} {
73     _debug $w "disable"
74     if {[info exists d(canvas)]} {
75         _debug $w "disable unbind"
76         bind $d(canvas) <Configure> {}
77         unset d(canvas)
78     }
79     set d(enabled) 0
80     _noshow $w
81 }
82
83 pannerproc _noshow {} {
84     _debug $w " _noshow"
85     $w coords base -5 -5 -5 -5
86     $w coords core -5 -5 -5 -5
87 }
88
89 pannerproc setcanvas {canvas} {
90     _debug $w "setcanvas $canvas"
91     disable $w
92     set d(canvas) $canvas
93     bind $d(canvas) <Configure> [list panner::_resize $w c-event]
94     updatecanvas $w
95 }
96
97 proc manyset {list args} {
98     foreach val $list var $args {
99         upvar 1 $var my
100         set my $val
101     }
102 }
103
104 pannerproc updatecanvas-bbox {} {
105     canvas-scroll-bbox $d(canvas)
106     updatecanvas $w
107 }
108
109 pannerproc updatecanvas {} {
110     set d(bbox) [$d(canvas) cget -scrollregion]
111     if {[llength $d(bbox)] < 4} { set d(enabled) 0; _noshow $w; return }
112     
113     manyset $d(bbox) x1 y1 x2 y2
114     set d(cwidth) [expr {$x2-$x1}]
115     set d(cheight) [expr {$y2-$y1}]
116     _debug $w "updatecanvas bbox=[join $d(bbox) ,] c=$d(cwidth),$d(cheight)"
117
118     set d(enabled) [expr {$d(cwidth) && $d(cheight)}]
119     if {!$d(enabled)} { _noshow $w; return }
120
121     # here we only set the pager's _requested_ height
122     set caspect [expr {($x2-$x1) * 1.0 / ($y2-$y1)}]
123     set waspect [expr {($d(maxwidth) - 1.0) / ($d(maxwidth) - 1.0)}]
124
125     if {$caspect >= $waspect} {
126         set too wide
127         set reqh $d(maxheight)
128         set reqw [expr {$d(maxheight) / $caspect}]
129     } else {
130         set too tall
131         set reqw $d(maxwidth)
132         set reqh [expr {$d(maxwidth) * $caspect}]
133     }
134     _debug $w "updatecanvas  aspects=$caspect,$waspect too=$too req=$reqw,$reqh"
135     $w configure -width $reqw -height $reqh
136
137     _resize $w c-update
138 }
139
140 pannerproc _resize {why} {
141     _noshow $w
142
143     set d(wwidth) [winfo width $w]
144     set d(wheight) [winfo height $w]
145
146     _debug $w "_resize $why w=$d(wwidth),$d(wheight)"
147     if {!$d(enabled) || $d(wwidth)<2 || $d(wheight)<2} return
148
149     set hscale [expr {$d(wwidth) * 1.0 / $d(cwidth)}]
150     set vscale [expr {$d(wheight) * 1.0 / $d(cheight)}]
151     set d(scale) [expr {$hscale < $vscale ? $hscale : $vscale}]
152     set d(mul_xview) [expr {$d(cwidth) * $d(scale)}]
153     set d(mul_yview) [expr {$d(cheight) * $d(scale)}]
154
155     set corewidth [expr {$d(scale) * $d(cwidth)}]
156     set coreheight [expr {$d(scale) * $d(cheight)}]
157
158     set d(add_xview) [expr {0.5 * ($d(wwidth) - $corewidth)}]
159     set d(add_yview) [expr {0.5 * ($d(wheight) - $coreheight)}]
160     
161     $w coords base \
162         $d(add_xview) \
163         $d(add_yview) \
164         [expr {$corewidth + $d(add_xview)}] \
165         [expr {$coreheight + $d(add_yview)}]
166
167     _debug $w "_resize     scales=$hscale,$vscale scale=$d(scale)\
168         mul=$d(mul_xview),$d(mul_yview)\
169         add=$d(add_xview),$d(add_yview)\
170         coresz=$corewidth,$coreheight"
171
172     _redisplay $w
173 }
174
175 pannerproc _mapc {view which} {
176     set viewpos [lindex [$d(canvas) $view] $which]
177     set r [expr {$viewpos * $d(mul_$view) + $d(add_$view)}]
178     _debug $w "  _mapc $view wh=$which viewpos=$viewpos => $r" 2
179     return $r
180 }
181
182 pannerproc _redisplay {} {
183     _debug $w "_redisplay" 2
184     $w coords core \
185         [_mapc $w xview 0] \
186         [_mapc $w yview 0] \
187         [_mapc $w xview 1] \
188         [_mapc $w yview 1]
189 }
190
191 pannerproc _press {b x y} {
192     if {$b != 1} return
193     set d(down_x) $x
194     set d(down_y) $y
195     set d(down_xview) [lindex [$d(canvas) xview] 0]
196     set d(down_yview) [lindex [$d(canvas) yview] 0]
197     _debug $w "_press down=$x,$y view=$d(down_xview),$d(down_yview)"
198 }
199
200 pannerproc _motion {x y} {
201     if {![info exists d(down_x)]} return
202     foreach xy {x y} wh {width height} {
203         set newpos [expr {
204               ([set $xy] - $d(down_$xy)) / $d(scale) / $d(c$wh)
205               + $d(down_${xy}view)
206           }]
207         $d(canvas) ${xy}view moveto $newpos
208         lappend dl $newpos
209     }
210     _debug $w "_motion $x,$y [join $dl ,]" 2
211     _redisplay $w
212 }
213
214 pannerproc _release {x y} {
215     _debug $w "_release $x,$y"
216     _motion $w $x $y
217     catch { unset d(down_x) }
218 }
219
220 }