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 {minlevel 1}} {
  11     if {$d(debug) < $minlevel} 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     if {[llength $d(bbox)] < 4} { set d(enabled) 0; _noshow $w; return }
  86
  87     manyset $d(bbox) x1 y1 x2 y2
  88     set d(cwidth) [expr {$x2-$x1}]
  89     set d(cheight) [expr {$y2-$y1}]
  90     _debug $w "updatecanvas bbox=[join $d(bbox) ,] c=$d(cwidth),$d(cheight)"
  91
  92     set d(enabled) [expr {$d(cwidth) && $d(cheight)}]
  93     if {!$d(enabled)} { _noshow $w; return }
  94
  95     # here we only set the pager's _requested_ height
  96     set caspect [expr {($x2-$x1) * 1.0 / ($y2-$y1)}]
  97     set waspect [expr {($d(maxwidth) - 1.0) / ($d(maxwidth) - 1.0)}]
  98
  99     if {$caspect >= $waspect} {
 100         set too wide
 101         set reqh $d(maxheight)
 102         set reqw [expr {$d(maxheight) / $caspect}]
 103     } else {
 104         set too tall
 105         set reqw $d(maxwidth)
 106         set reqh [expr {$d(maxwidth) * $caspect}]
 107     }
 108     _debug $w "updatecanvas  aspects=$caspect,$waspect too=$too req=$reqw,$reqh"
 109     $w configure -width $reqw -height $reqh
 110
 111     _resize $w c-update
 112 }
 113
 114 pannerproc _resize {why} {
 115     _noshow $w
 116
 117     set d(wwidth) [winfo width $w]
 118     set d(wheight) [winfo height $w]
 119
 120     _debug $w "_resize $why w=$d(wwidth),$d(wheight)"
 121     if {!$d(enabled) || $d(wwidth)<2 || $d(wheight)<2} return
 122
 123     set hscale [expr {$d(wwidth) * 1.0 / $d(cwidth)}]
 124     set vscale [expr {$d(wheight) * 1.0 / $d(cheight)}]
 125     set d(scale) [expr {$hscale < $vscale ? $hscale : $vscale}]
 126     set d(mul_xview) [expr {$d(cwidth) * $d(scale)}]
 127     set d(mul_yview) [expr {$d(cheight) * $d(scale)}]
 128
 129     set corewidth [expr {$d(scale) * $d(cwidth)}]
 130     set coreheight [expr {$d(scale) * $d(cheight)}]
 131
 132     set d(add_xview) [expr {0.5 * ($d(wwidth) - $corewidth)}]
 133     set d(add_yview) [expr {0.5 * ($d(wheight) - $coreheight)}]
 134
 135     $w coords base \
 136         $d(add_xview) \
 137         $d(add_yview) \
 138         [expr {$corewidth + $d(add_xview)}] \
 139         [expr {$coreheight + $d(add_yview)}]
 140
 141     _debug $w "_resize     scales=$hscale,$vscale scale=$d(scale)\
 142         mul=$d(mul_xview),$d(mul_yview)\
 143         add=$d(add_xview),$d(add_yview)\
 144         coresz=$corewidth,$coreheight"
 145
 146     _redisplay $w
 147 }
 148
 149 pannerproc _mapc {view which} {
 150     set viewpos [lindex [$d(canvas) $view] $which]
 151     set r [expr {$viewpos * $d(mul_$view) + $d(add_$view)}]
 152     _debug $w "  _mapc $view wh=$which viewpos=$viewpos => $r" 2
 153     return $r
 154 }
 155
 156 pannerproc _redisplay {} {
 157     _debug $w "_redisplay" 2
 158     $w coords core \
 159         [_mapc $w xview 0] \
 160         [_mapc $w yview 0] \
 161         [_mapc $w xview 1] \
 162         [_mapc $w yview 1]
 163 }
 164
 165 pannerproc _press {b x y} {
 166     if {$b != 1} return
 167     set d(down_x) $x
 168     set d(down_y) $y
 169     set d(down_xview) [lindex [$d(canvas) xview] 0]
 170     set d(down_yview) [lindex [$d(canvas) yview] 0]
 171     _debug $w "_press down=$x,$y view=$d(down_xview),$d(down_yview)"
 172 }
 173
 174 pannerproc _motion {x y} {
 175     if {![info exists d(down_x)]} return
 176     foreach xy {x y} wh {width height} {
 177         set newpos [expr {
 178               ([set $xy] - $d(down_$xy)) / $d(scale) / $d(c$wh)
 179               + $d(down_${xy}view)
 180           }]
 181         $d(canvas) ${xy}view moveto $newpos
 182         lappend dl $newpos
 183     }
 184     _debug $w "_motion $x,$y [join $dl ,]" 2
 185     _redisplay $w
 186 }
 187
 188 pannerproc _release {x y} {
 189     _debug $w "_release $x,$y"
 190     _motion $w $x $y
 191     catch { unset d(down_x) }
 192 }
 193
 194 }