yarrg/panner.tcl

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