# -*- 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 { proc pannerproc {name argl body} { proc $name [concat w $argl] " upvar panner::i/\$w d $body " } pannerproc _debug {m {minlevel 1}} { if {$d(debug) < $minlevel} return puts "PANNER $w $m" } 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 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 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 destroy {w} { _debug $w "destroy" disable $w destroy $w _debug $w "destroyed" unset d } pannerproc disable {} { _debug $w "disable" if {[info exists d(canvas)]} { _debug $w "disable unbind" bind $d(canvas) {} unset d(canvas) } set d(enabled) 0 _noshow $w } pannerproc _noshow {} { _debug $w " _noshow" $w coords base -5 -5 -5 -5 $w coords core -5 -5 -5 -5 } pannerproc setcanvas {canvas} { _debug $w "setcanvas $canvas" disable $w set d(canvas) $canvas bind $d(canvas) [list panner::_resize $w c-event] updatecanvas $w } proc manyset {list args} { foreach val $list var $args { upvar 1 $var my set my $val } } pannerproc updatecanvas-bbox {} { canvas-scroll-bbox $d(canvas) updatecanvas $w } 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)" set d(enabled) [expr {$d(cwidth) && $d(cheight)}] if {!$d(enabled)} { _noshow $w; return } # here we only set the pager's _requested_ height set caspect [expr {($x2-$x1) * 1.0 / ($y2-$y1)}] set waspect [expr {($d(maxwidth) - 1.0) / ($d(maxwidth) - 1.0)}] if {$caspect >= $waspect} { set too wide set reqh $d(maxheight) set reqw [expr {$d(maxheight) / $caspect}] } else { set too tall set reqw $d(maxwidth) set reqh [expr {$d(maxwidth) * $caspect}] } _debug $w "updatecanvas aspects=$caspect,$waspect too=$too req=$reqw,$reqh" $w configure -width $reqw -height $reqh _resize $w c-update } pannerproc _resize {why} { _noshow $w set d(wwidth) [winfo width $w] set d(wheight) [winfo height $w] _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 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 {$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)}] $w coords base \ $d(add_xview) \ $d(add_yview) \ [expr {$corewidth + $d(add_xview)}] \ [expr {$coreheight + $d(add_yview)}] _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 } 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" 2 return $r } 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] } 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) } } }