chiark / gitweb /
where-vessels: show errorInfo in acq error
[ypp-sc-tools.db-live.git] / yarrg / panner.tcl
index d879443..77729b1 100644 (file)
@@ -1,73 +1,97 @@
+# -*- Tcl -*-
+# Tcl panner widget
+
+# This is part of ypp-sc-tools, a set of third-party tools for assisting
+# players of Yohoho Puzzle Pirates.
+#
+# Copyright (C) 2009 Ian Jackson <ijackson@chiark.greenend.org.uk>
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program.  If not, see <http://www.gnu.org/licenses/>.
+#
+# Yohoho and Puzzle Pirates are probably trademarks of Three Rings and
+# are used without permission.  This program is not endorsed or
+# sponsored by Three Rings.
+
+
 package provide panner 0.1;
 namespace eval panner {
 
-namespace export -clear
-
 proc pannerproc {name argl body} {
     proc $name [concat w $argl] "
     upvar panner::i/\$w d
 $body
 "
 }
-proc pannerproc-export {name argl body} {
-    pannerproc panner-$name $argl $body
-    namespace export panner-$name
-}
-
-proc debug {w m} {
+pannerproc _debug {m {minlevel 1}} {
+    if {$d(debug) < $minlevel} return
     puts "PANNER $w $m"
 }
 
-pannerproc-export create {canvas maxwidth maxheight} {
-    debug $w "create $canvas $maxwidth,$maxheight"
+pannerproc create {canvas maxwidth maxheight {debug 0}} {
+    set d(debug) $debug
+    _debug $w "create $canvas $maxwidth,$maxheight"
     set d(maxwidth) $maxwidth
     set d(maxheight) $maxheight
     canvas $w
     $w create rectangle -5 -5 -5 -5 -tags base -outline {} -fill black
     $w create rectangle -5 -5 -5 -5 -tags core -outline blue
-    bind $w <Configure> [list panner::resize $w]
-    panner-setcanvas $w $canvas
+    bind $w <Configure> [list panner::_resize $w w-event]
+    bind $w <ButtonPress> [list panner::_press $w %b %x %y]
+    bind $w <B1-Motion> [list panner::_motion $w %x %y]
+    bind $w <B1-ButtonRelease> [list panner::_release $w %x %y]
+    setcanvas $w $canvas
 }
-pannerproc-export setcolor-background {c} { $w configure -background $c }
-pannerproc-export setcolor-base {c} { $w itemconfigure base -fill $c }
-pannerproc-export setcolor-core {c} { $w itemconfigure core -outline $c }
+pannerproc setcolor-background {c} { $w configure -background $c }
+pannerproc setcolor-base {c} { $w itemconfigure base -fill $c }
+pannerproc setcolor-core {c} { $w itemconfigure core -outline $c }
 
 proc canvas-scroll-bbox {canvas} {
     $canvas configure -scrollregion [$canvas bbox all]
 }
 namespace export canvas-scroll-bbox
 
-pannerproc-export destroy {w} {
-    debug $w "destroy"
-    panner-disable $w
-    bind $d(canvas) <Configure> {}
+pannerproc destroy {w} {
+    _debug $w "destroy"
+    disable $w
     destroy $w
+    _debug $w "destroyed"
     unset d
-    debug $w "destroyed"
 }
 
-pannerproc-export disable {} {
-    debug $w "disable"
+pannerproc disable {} {
+    _debug $w "disable"
     if {[info exists d(canvas)]} {
-       debug $w "disable unbind"
-       bind $d(canvas) <Configure> [list panner::resize $w]
+       _debug $w "disable unbind"
+       bind $d(canvas) <Configure> {}
        unset d(canvas)
     }
     set d(enabled) 0
-    noshow $w
+    _noshow $w
 }
 
-pannerproc noshow {} {
-    debug $w " noshow"
+pannerproc _noshow {} {
+    _debug $w " _noshow"
     $w coords base -5 -5 -5 -5
     $w coords core -5 -5 -5 -5
 }
 
-pannerproc-export setcanvas {canvas} {
-    debug $w "setcanvas $canvas"
-    panner-disable $w
+pannerproc setcanvas {canvas} {
+    _debug $w "setcanvas $canvas"
+    disable $w
     set d(canvas) $canvas
-    panner-updatecanvas $w
+    bind $d(canvas) <Configure> [list panner::_resize $w c-event]
+    updatecanvas $w
 }
 
 proc manyset {list args} {
@@ -77,20 +101,22 @@ proc manyset {list args} {
     }
 }
 
-pannerproc-export updatecanvas-bbox {} {
+pannerproc updatecanvas-bbox {} {
     canvas-scroll-bbox $d(canvas)
-    panner-updatecanvas $w
+    updatecanvas $w
 }
 
-pannerproc-export updatecanvas {} {
+pannerproc updatecanvas {} {
     set d(bbox) [$d(canvas) cget -scrollregion]
+    if {[llength $d(bbox)] < 4} { set d(enabled) 0; _noshow $w; return }
+    
     manyset $d(bbox) x1 y1 x2 y2
     set d(cwidth) [expr {$x2-$x1}]
     set d(cheight) [expr {$y2-$y1}]
-    debug $w "updatecanvas bbox=[join $d(bbox) ,] c=$d(cwidth),$d(cheight)"
+    _debug $w "updatecanvas bbox=[join $d(bbox) ,] c=$d(cwidth),$d(cheight)"
 
     set d(enabled) [expr {$d(cwidth) && $d(cheight)}]
-    if {!$d(enabled)} { noshow $w; return }
+    if {!$d(enabled)} { _noshow $w; return }
 
     # here we only set the pager's _requested_ height
     set caspect [expr {($x2-$x1) * 1.0 / ($y2-$y1)}]
@@ -105,31 +131,29 @@ pannerproc-export updatecanvas {} {
        set reqw $d(maxwidth)
        set reqh [expr {$d(maxwidth) * $caspect}]
     }
-    debug $w "updatecanvas  aspects=$caspect,$waspect too=$too req=$reqw,$reqh"
+    _debug $w "updatecanvas  aspects=$caspect,$waspect too=$too req=$reqw,$reqh"
     $w configure -width $reqw -height $reqh
 
-    resize $w
+    _resize $w c-update
 }
 
-pannerproc resize {} {
-    noshow $w
-
-    #set d(vwidth) [winfo width $d(canvas)]
-    #set d(vheight) [winfo height $d(canvas)]
+pannerproc _resize {why} {
+    _noshow $w
 
     set d(wwidth) [winfo width $w]
     set d(wheight) [winfo height $w]
-    debug $w "resize w=$d(wwidth),$d(wheight)"
+
+    _debug $w "_resize $why w=$d(wwidth),$d(wheight)"
     if {!$d(enabled) || $d(wwidth)<2 || $d(wheight)<2} return
 
     set hscale [expr {$d(wwidth) * 1.0 / $d(cwidth)}]
     set vscale [expr {$d(wheight) * 1.0 / $d(cheight)}]
-    set scale [expr {$hscale < $vscale ? $hscale : $vscale}]
-    set d(mul_xview) [expr {$d(cwidth) * $scale}]
-    set d(mul_yview) [expr {$d(cheight) * $scale}]
+    set d(scale) [expr {$hscale < $vscale ? $hscale : $vscale}]
+    set d(mul_xview) [expr {$d(cwidth) * $d(scale)}]
+    set d(mul_yview) [expr {$d(cheight) * $d(scale)}]
 
-    set corewidth [expr {$scale * $d(cwidth)}]
-    set coreheight [expr {$scale * $d(cheight)}]
+    set corewidth [expr {$d(scale) * $d(cwidth)}]
+    set coreheight [expr {$d(scale) * $d(cheight)}]
 
     set d(add_xview) [expr {0.5 * ($d(wwidth) - $corewidth)}]
     set d(add_yview) [expr {0.5 * ($d(wheight) - $coreheight)}]
@@ -140,28 +164,57 @@ pannerproc resize {} {
        [expr {$corewidth + $d(add_xview)}] \
        [expr {$coreheight + $d(add_yview)}]
 
-    debug $w "resize     scales=$hscale,$vscale scale=$scale\
+    _debug $w "_resize     scales=$hscale,$vscale scale=$d(scale)\
         mul=$d(mul_xview),$d(mul_yview)\
         add=$d(add_xview),$d(add_yview)\
         coresz=$corewidth,$coreheight"
 
-    redisplay $w
+    _redisplay $w
 }
 
-pannerproc mapc {view which} {
+pannerproc _mapc {view which} {
     set viewpos [lindex [$d(canvas) $view] $which]
     set r [expr {$viewpos * $d(mul_$view) + $d(add_$view)}]
-    debug $w "  mapc $view wh=$which viewpos=$viewpos => $r"
+    _debug $w "  _mapc $view wh=$which viewpos=$viewpos => $r" 2
     return $r
 }
 
-pannerproc redisplay {} {
-    debug $w "redisplay"
+pannerproc _redisplay {} {
+    _debug $w "_redisplay" 2
     $w coords core \
-       [mapc $w xview 0] \
-       [mapc $w yview 0] \
-       [mapc $w xview 1] \
-       [mapc $w yview 1]
+       [_mapc $w xview 0] \
+       [_mapc $w yview 0] \
+       [_mapc $w xview 1] \
+       [_mapc $w yview 1]
+}
+
+pannerproc _press {b x y} {
+    if {$b != 1} return
+    set d(down_x) $x
+    set d(down_y) $y
+    set d(down_xview) [lindex [$d(canvas) xview] 0]
+    set d(down_yview) [lindex [$d(canvas) yview] 0]
+    _debug $w "_press down=$x,$y view=$d(down_xview),$d(down_yview)"
+}
+
+pannerproc _motion {x y} {
+    if {![info exists d(down_x)]} return
+    foreach xy {x y} wh {width height} {
+       set newpos [expr {
+              ([set $xy] - $d(down_$xy)) / $d(scale) / $d(c$wh)
+             + $d(down_${xy}view)
+         }]
+       $d(canvas) ${xy}view moveto $newpos
+       lappend dl $newpos
+    }
+    _debug $w "_motion $x,$y [join $dl ,]" 2
+    _redisplay $w
+}
+
+pannerproc _release {x y} {
+    _debug $w "_release $x,$y"
+    _motion $w $x $y
+    catch { unset d(down_x) }
 }
 
 }