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 }