From e20b856b909c253231f872b95a339567e6757d57 Mon Sep 17 00:00:00 2001 From: Ian Jackson Date: Thu, 10 Dec 2009 18:04:40 +0000 Subject: [PATCH] WIP Tk panner widget --- yarrg/panner.tcl | 167 ++++++++++++++++++++++++++++++++++++++++++++++ yarrg/pantest.tcl | 19 ++++++ 2 files changed, 186 insertions(+) create mode 100644 yarrg/panner.tcl create mode 100755 yarrg/pantest.tcl diff --git a/yarrg/panner.tcl b/yarrg/panner.tcl new file mode 100644 index 0000000..d879443 --- /dev/null +++ b/yarrg/panner.tcl @@ -0,0 +1,167 @@ +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} { + puts "PANNER $w $m" +} + +pannerproc-export create {canvas maxwidth maxheight} { + 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 +} +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 } + +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) {} + destroy $w + unset d + debug $w "destroyed" +} + +pannerproc-export disable {} { + debug $w "disable" + if {[info exists d(canvas)]} { + debug $w "disable unbind" + bind $d(canvas) [list panner::resize $w] + 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-export setcanvas {canvas} { + debug $w "setcanvas $canvas" + panner-disable $w + set d(canvas) $canvas + panner-updatecanvas $w +} + +proc manyset {list args} { + foreach val $list var $args { + upvar 1 $var my + set my $val + } +} + +pannerproc-export updatecanvas-bbox {} { + canvas-scroll-bbox $d(canvas) + panner-updatecanvas $w +} + +pannerproc-export updatecanvas {} { + set d(bbox) [$d(canvas) cget -scrollregion] + 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 +} + +pannerproc resize {} { + noshow $w + + #set d(vwidth) [winfo width $d(canvas)] + #set d(vheight) [winfo height $d(canvas)] + + set d(wwidth) [winfo width $w] + set d(wheight) [winfo height $w] + debug $w "resize 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 corewidth [expr {$scale * $d(cwidth)}] + set coreheight [expr {$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=$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" + return $r +} + +pannerproc redisplay {} { + debug $w "redisplay" + $w coords core \ + [mapc $w xview 0] \ + [mapc $w yview 0] \ + [mapc $w xview 1] \ + [mapc $w yview 1] +} + +} diff --git a/yarrg/pantest.tcl b/yarrg/pantest.tcl new file mode 100755 index 0000000..53d80f1 --- /dev/null +++ b/yarrg/pantest.tcl @@ -0,0 +1,19 @@ +#!/usr/bin/wish + +source panner.tcl +namespace import panner::* + +set scale 50 + +canvas .c +for {set x -$scale} {$x < 500} {incr x $scale} { + for {set y -$scale} {$y < 500} {incr y $scale} { + .c create text $x $y -text "${x}x${y}" -anchor sw + } +} + +canvas-scroll-bbox .c +panner-create .p .c 200 200 + +pack .c -expand y -fill both -side left +pack .p -side right -- 2.30.2