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 proc debug {w m} {
  18     puts "PANNER $w $m"
  19 }
  20
  21 pannerproc-export create {canvas maxwidth maxheight} {
  22     debug $w "create $canvas $maxwidth,$maxheight"
  23     set d(maxwidth) $maxwidth
  24     set d(maxheight) $maxheight
  25     canvas $w
  26     $w create rectangle -5 -5 -5 -5 -tags base -outline {} -fill black
  27     $w create rectangle -5 -5 -5 -5 -tags core -outline blue
  28     bind $w <Configure> [list panner::resize $w]
  29     panner-setcanvas $w $canvas
  30 }
  31 pannerproc-export setcolor-background {c} { $w configure -background $c }
  32 pannerproc-export setcolor-base {c} { $w itemconfigure base -fill $c }
  33 pannerproc-export setcolor-core {c} { $w itemconfigure core -outline $c }
  34
  35 proc canvas-scroll-bbox {canvas} {
  36     $canvas configure -scrollregion [$canvas bbox all]
  37 }
  38 namespace export canvas-scroll-bbox
  39
  40 pannerproc-export destroy {w} {
  41     debug $w "destroy"
  42     panner-disable $w
  43     bind $d(canvas) <Configure> {}
  44     destroy $w
  45     unset d
  46     debug $w "destroyed"
  47 }
  48
  49 pannerproc-export disable {} {
  50     debug $w "disable"
  51     if {[info exists d(canvas)]} {
  52         debug $w "disable unbind"
  53         bind $d(canvas) <Configure> [list panner::resize $w]
  54         unset d(canvas)
  55     }
  56     set d(enabled) 0
  57     noshow $w
  58 }
  59
  60 pannerproc noshow {} {
  61     debug $w " noshow"
  62     $w coords base -5 -5 -5 -5
  63     $w coords core -5 -5 -5 -5
  64 }
  65
  66 pannerproc-export setcanvas {canvas} {
  67     debug $w "setcanvas $canvas"
  68     panner-disable $w
  69     set d(canvas) $canvas
  70     panner-updatecanvas $w
  71 }
  72
  73 proc manyset {list args} {
  74     foreach val $list var $args {
  75         upvar 1 $var my
  76         set my $val
  77     }
  78 }
  79
  80 pannerproc-export updatecanvas-bbox {} {
  81     canvas-scroll-bbox $d(canvas)
  82     panner-updatecanvas $w
  83 }
  84
  85 pannerproc-export updatecanvas {} {
  86     set d(bbox) [$d(canvas) cget -scrollregion]
  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
 112 }
 113
 114 pannerproc resize {} {
 115     noshow $w
 116
 117     #set d(vwidth) [winfo width $d(canvas)]
 118     #set d(vheight) [winfo height $d(canvas)]
 119
 120     set d(wwidth) [winfo width $w]
 121     set d(wheight) [winfo height $w]
 122     debug $w "resize w=$d(wwidth),$d(wheight)"
 123     if {!$d(enabled) || $d(wwidth)<2 || $d(wheight)<2} return
 124
 125     set hscale [expr {$d(wwidth) * 1.0 / $d(cwidth)}]
 126     set vscale [expr {$d(wheight) * 1.0 / $d(cheight)}]
 127     set scale [expr {$hscale < $vscale ? $hscale : $vscale}]
 128     set d(mul_xview) [expr {$d(cwidth) * $scale}]
 129     set d(mul_yview) [expr {$d(cheight) * $scale}]
 130
 131     set corewidth [expr {$scale * $d(cwidth)}]
 132     set coreheight [expr {$scale * $d(cheight)}]
 133
 134     set d(add_xview) [expr {0.5 * ($d(wwidth) - $corewidth)}]
 135     set d(add_yview) [expr {0.5 * ($d(wheight) - $coreheight)}]
 136
 137     $w coords base \
 138         $d(add_xview) \
 139         $d(add_yview) \
 140         [expr {$corewidth + $d(add_xview)}] \
 141         [expr {$coreheight + $d(add_yview)}]
 142
 143     debug $w "resize     scales=$hscale,$vscale scale=$scale\
 144         mul=$d(mul_xview),$d(mul_yview)\
 145         add=$d(add_xview),$d(add_yview)\
 146         coresz=$corewidth,$coreheight"
 147
 148     redisplay $w
 149 }
 150
 151 pannerproc mapc {view which} {
 152     set viewpos [lindex [$d(canvas) $view] $which]
 153     set r [expr {$viewpos * $d(mul_$view) + $d(add_$view)}]
 154     debug $w "  mapc $view wh=$which viewpos=$viewpos => $r"
 155     return $r
 156 }
 157
 158 pannerproc redisplay {} {
 159     debug $w "redisplay"
 160     $w coords core \
 161         [mapc $w xview 0] \
 162         [mapc $w yview 0] \
 163         [mapc $w xview 1] \
 164         [mapc $w yview 1]
 165 }
 166
 167 }