X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~yarrgweb/git?p=ypp-sc-tools.db-live.git;a=blobdiff_plain;f=yarrg%2Fpanner.tcl;h=77729b19b1bf37a72b038910e616d507ae934504;hp=d879443d2115c71442cd3344163c8910f05335f0;hb=515910e46919673912ec15b00e060353d14ad1d5;hpb=e20b856b909c253231f872b95a339567e6757d57 diff --git a/yarrg/panner.tcl b/yarrg/panner.tcl index d879443..77729b1 100644 --- a/yarrg/panner.tcl +++ b/yarrg/panner.tcl @@ -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 +# +# 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 . +# +# 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 [list panner::resize $w] - panner-setcanvas $w $canvas + bind $w [list panner::_resize $w w-event] + bind $w [list panner::_press $w %b %x %y] + bind $w [list panner::_motion $w %x %y] + bind $w [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) {} +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) [list panner::resize $w] + _debug $w "disable unbind" + bind $d(canvas) {} 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) [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) } } }