yarrg/panner.tcl

   1 package provide panner 0.1;
   2 namespace eval panner {
   3
   4 namespace export -clear
   5
   6 proc pannerproc {name argl body} {
   7     proc $name [concat w $argl] "
   8     upvar panner::i/\$w d
   9 $body
  10 "
  11 }
  12 proc pannerproc-export {name argl body} {
  13     pannerproc panner-$name $argl $body
  14     namespace export panner-$name
  15 }
  16
  17 pannerproc debug {m} {
  18     if {!$d(debug)} return
  19     puts "PANNER $w $m"
  20 }
  21
  22 pannerproc-export create {canvas maxwidth maxheight {debug 0}} {
  23     set d(debug) $debug
  24     debug $w "create $canvas $maxwidth,$maxheight"
  25     set d(maxwidth) $maxwidth
  26     set d(maxheight) $maxheight
  27     canvas $w
  28     $w create rectangle -5 -5 -5 -5 -tags base -outline {} -fill black
  29     $w create rectangle -5 -5 -5 -5 -tags core -outline blue
  30     bind $w <Configure> [list panner::resize $w w-event]
  31     bind $w <ButtonPress> [list panner::press $w %b %x %y]
  32     bind $w <B1-Motion> [list panner::motion $w %x %y]
  33     bind $w <B1-ButtonRelease> [list panner::release $w %x %y]
  34     panner-setcanvas $w $canvas
  35 }
  36 pannerproc-export setcolor-background {c} { $w configure -background $c }
  37 pannerproc-export setcolor-base {c} { $w itemconfigure base -fill $c }
  38 pannerproc-export setcolor-core {c} { $w itemconfigure core -outline $c }
  39
  40 proc canvas-scroll-bbox {canvas} {
  41     $canvas configure -scrollregion [$canvas bbox all]
  42 }
  43 namespace export canvas-scroll-bbox
  44
  45 pannerproc-export destroy {w} {
  46     debug $w "destroy"
  47     panner-disable $w
  48     destroy $w
  49     debug $w "destroyed"
  50     unset d
  51 }
  52
  53 pannerproc-export disable {} {
  54     debug $w "disable"
  55     if {[info exists d(canvas)]} {
  56         debug $w "disable unbind"
  57         bind $d(canvas) <Configure> {}
  58         unset d(canvas)
  59     }
  60     set d(enabled) 0
  61     noshow $w
  62 }
  63
  64 pannerproc noshow {} {
  65     debug $w " noshow"
  66     $w coords base -5 -5 -5 -5
  67     $w coords core -5 -5 -5 -5
  68 }
  69
  70 pannerproc-export setcanvas {canvas} {
  71     debug $w "setcanvas $canvas"
  72     panner-disable $w
  73     set d(canvas) $canvas
  74     bind $d(canvas) <Configure> [list panner::resize $w c-event]
  75     panner-updatecanvas $w
  76 }
  77
  78 proc manyset {list args} {
  79     foreach val $list var $args {
  80         upvar 1 $var my
  81         set my $val
  82     }
  83 }
  84
  85 pannerproc-export updatecanvas-bbox {} {
  86     canvas-scroll-bbox $d(canvas)
  87     panner-updatecanvas $w
  88 }
  89
  90 pannerproc-export updatecanvas {} {
  91     set d(bbox) [$d(canvas) cget -scrollregion]
  92     manyset $d(bbox) x1 y1 x2 y2
  93     set d(cwidth) [expr {$x2-$x1}]
  94     set d(cheight) [expr {$y2-$y1}]
  95     debug $w "updatecanvas bbox=[join $d(bbox) ,] c=$d(cwidth),$d(cheight)"
  96
  97     set d(enabled) [expr {$d(cwidth) && $d(cheight)}]
  98     if {!$d(enabled)} { noshow $w; return }
  99
 100     # here we only set the pager's _requested_ height
 101     set caspect [expr {($x2-$x1) * 1.0 / ($y2-$y1)}]
 102     set waspect [expr {($d(maxwidth) - 1.0) / ($d(maxwidth) - 1.0)}]
 103
 104     if {$caspect >= $waspect} {
 105         set too wide
 106         set reqh $d(maxheight)
 107         set reqw [expr {$d(maxheight) / $caspect}]
 108     } else {
 109         set too tall
 110         set reqw $d(maxwidth)
 111         set reqh [expr {$d(maxwidth) * $caspect}]
 112     }
 113     debug $w "updatecanvas  aspects=$caspect,$waspect too=$too req=$reqw,$reqh"
 114     $w configure -width $reqw -height $reqh
 115
 116     resize $w c-update
 117 }
 118
 119 pannerproc resize {why} {
 120     noshow $w
 121
 122     set d(wwidth) [winfo width $w]
 123     set d(wheight) [winfo height $w]
 124
 125     debug $w "resize $why w=$d(wwidth),$d(wheight)"
 126     if {!$d(enabled) || $d(wwidth)<2 || $d(wheight)<2} return
 127
 128     set hscale [expr {$d(wwidth) * 1.0 / $d(cwidth)}]
 129     set vscale [expr {$d(wheight) * 1.0 / $d(cheight)}]
 130     set d(scale) [expr {$hscale < $vscale ? $hscale : $vscale}]
 131     set d(mul_xview) [expr {$d(cwidth) * $d(scale)}]
 132     set d(mul_yview) [expr {$d(cheight) * $d(scale)}]
 133
 134     set corewidth [expr {$d(scale) * $d(cwidth)}]
 135     set coreheight [expr {$d(scale) * $d(cheight)}]
 136
 137     set d(add_xview) [expr {0.5 * ($d(wwidth) - $corewidth)}]
 138     set d(add_yview) [expr {0.5 * ($d(wheight) - $coreheight)}]
 139
 140     $w coords base \
 141         $d(add_xview) \
 142         $d(add_yview) \
 143         [expr {$corewidth + $d(add_xview)}] \
 144         [expr {$coreheight + $d(add_yview)}]
 145
 146     debug $w "resize     scales=$hscale,$vscale scale=$d(scale)\
 147         mul=$d(mul_xview),$d(mul_yview)\
 148         add=$d(add_xview),$d(add_yview)\
 149         coresz=$corewidth,$coreheight"
 150
 151     redisplay $w
 152 }
 153
 154 pannerproc mapc {view which} {
 155     set viewpos [lindex [$d(canvas) $view] $which]
 156     set r [expr {$viewpos * $d(mul_$view) + $d(add_$view)}]
 157     debug $w "  mapc $view wh=$which viewpos=$viewpos => $r"
 158     return $r
 159 }
 160
 161 pannerproc redisplay {} {
 162     debug $w "redisplay"
 163     $w coords core \
 164         [mapc $w xview 0] \
 165         [mapc $w yview 0] \
 166         [mapc $w xview 1] \
 167         [mapc $w yview 1]
 168 }
 169
 170 pannerproc press {b x y} {
 171     if {$b != 1} return
 172     set d(down_x) $x
 173     set d(down_y) $y
 174     set d(down_xview) [lindex [$d(canvas) xview] 0]
 175     set d(down_yview) [lindex [$d(canvas) yview] 0]
 176     debug $w "press down=$x,$y view=$d(down_xview),$d(down_yview)"
 177 }
 178
 179 pannerproc motion {x y} {
 180     if {![info exists d(down_x)]} return
 181     foreach xy {x y} wh {width height} {
 182         set newpos [expr {
 183               ([set $xy] - $d(down_$xy)) / $d(scale) / $d(c$wh)
 184               + $d(down_${xy}view)
 185           }]
 186         $d(canvas) ${xy}view moveto $newpos
 187         lappend dl $newpos
 188     }
 189     debug $w "motion $x,$y [join $dl ,]"
 190     redisplay $w
 191 }
 192
 193 pannerproc release {x y} {
 194     debug $w "release $x,$y"
 195     motion $w $x $y
 196     catch { unset d(down_x) }
 197 }
 198
 199 }