Posted to tcl by jenglish at Wed Nov 17 22:13:45 GMT 2010view pretty
### scrollview metawidget. # # Usage: # scrollview $sv # $sv manage $sv.child # $sv see $sv.$descendant... # package provide scrollview 1.1 namespace eval scrollview { # State variables: # win -- renamed original widget command # slave -- managed slave. # [xy].constrain -- 1 => constrain; 0 => scroll # [xy].command -- scroll command # [xy].first -- current scroll position # [xy].requested -- requested size from slave # [xy].available -- available size # [xy].increment -- default increment for [$sv scroll $n units] # variable defaults { win "" slave "" x.constrain 1 y.constrain 1 x.command scrollview::nop y.command scrollview::nop x.first 0 y.first 0 x.requested 0 y.requested 0 x.increment 10 y.increment 10 } proc min {a b} { expr {$a < $b ? $a : $b} } proc max {a b} { expr {$a > $b ? $a : $b} } proc nop {args} {} } ### Defaults. # # Default -width 10c and -height 7c are the BWidget ScrollableFrame defaults, # which in turn are taken from the core Canvas widget. # option add *Scrollview.width 10c option add *Scrollview.height 7c ### Bindings. # bind Scrollview <Destroy> { scrollview::Destroy %W } bind Scrollview <Configure> { scrollview::Resize %W } proc scrollview::Destroy {w} { upvar #0 $w W unset -nocomplain W rename $w {} } proc scrollview::Resize {w} { upvar #0 $w W Refresh $w set W(x.first) [First $w x $W(x.first)] set W(y.first) [First $w y $W(y.first)] PlaceSlave $w Notify $w {x y} } ### Internal utilities. # ## PlaceSlave -- adjust position of slave window. # proc scrollview::PlaceSlave {w} { upvar #0 $w W if {$W(slave) eq ""} { return } place $W(slave) -in $w \ -x [expr {-$W(x.first)}] \ -y [expr {-$W(y.first)}] \ -width [SlaveSize $w x] \ -height [SlaveSize $w y] \ ; } ## SlaveSize -- # proc scrollview::SlaveSize {w axis} { upvar #0 $w W if {$W($axis.constrain)} { return $W($axis.available) } else { return $W($axis.requested) } # Other possibilities: # stretch -- [max $W($axis.available) $W($axis.requested)] # shrink -- [min $W($axis.available) $W($axis.requested)] (not useful) } ## Refresh -- update sizes # proc scrollview::Refresh {w} { upvar #0 $w W set W(x.available) [winfo width $w] set W(y.available) [winfo height $w] if {$W(slave) ne ""} { set W(x.requested) [winfo reqwidth $W(slave)] set W(y.requested) [winfo reqheight $W(slave)] } } ## Notify $w ?$axes? -- invoke -[xy]scrollcommands # proc scrollview::Notify {w {axes "x y"}} { upvar #0 $w W foreach axis $axes { set total [max 1.0 [expr { double($W($axis.requested)) }]] set first [expr { double($W($axis.first))/$total } ] set last [expr { double($W($axis.first)+$W($axis.available))/$total }] uplevel #0 [linsert $W($axis.command) end $first $last] } } ## First -- # proc scrollview::First {w axis pos} { upvar #0 $w W set lim [expr {$W($axis.requested) - $W($axis.available)}] return [max 0 [min $lim $pos]] } proc scrollview::SetFirst {w axis pos} { upvar #0 $w W set W($axis.first) [First $w $axis $pos] PlaceSlave $w Notify $w $axis } ## Widget constructor. # interp alias {} ::scrollview {} ::scrollview::Constructor proc scrollview::Constructor {w args} { upvar #0 $w W variable defaults array set W $defaults frame $w -class Scrollview rename $w [set W(win) ::scrollview::_$w] interp alias {} $w {} ::scrollview::Dispatch $w uplevel 1 [linsert $args 0 $w configure] return $w } proc scrollview::Dispatch {w command args} { uplevel 1 [linsert $args 0 [namespace which -command $command] $w] } ### Widget methods: # ## $sv configure option value... # proc scrollview::configure {w args} { upvar #0 $w W set frameopts [list] foreach {option value} $args { switch -- $option { -xscrollcommand { set W(x.command) $value;set W(x.constrain) 0 } -yscrollcommand { set W(y.command) $value;set W(y.constrain) 0 } -xscrollincrement { set W(x.increment) $value } -yscrollincrement { set W(y.increment) $value } -width - -height { lappend frameopts $option $value } default { error "Unrecognized option $option" } } } if {[llength $frameopts]} { eval [linsert $frameopts 0 $W(win) configure] } } ## $sv manage $child # proc scrollview::manage {w slave} { upvar #0 $w W if {$W(slave) ne ""} { place forget $W(slave) } set W(slave) $slave Resize $w } ## $sv xview, $sv yview -- standard scrolling methods. # proc scrollview::xview {w method amount {units ""}} { XYview $w x $method $amount $units } proc scrollview::yview {w method amount {units ""}} { XYview $w y $method $amount $units } proc scrollview::XYview {w axis method amount units} { switch -- $method { moveto { MoveTo $w $axis $amount } scroll { Scroll-$units $w $axis $amount } default { error "Unknown scroll directive $method" } } } proc scrollview::MoveTo {w axis fraction} { upvar #0 $w W SetFirst $w $axis [expr {int($fraction * $W($axis.requested))}] } proc scrollview::Scroll-units {w axis count} { upvar #0 $w W SetFirst $w $axis [expr {$W($axis.first) + $W($axis.increment)*$count}] } proc scrollview::Scroll-pages {w axis count} { upvar #0 $w W SetFirst $w $axis [expr {$W($axis.first) + $count*$W($axis.available)}] } ## $sv see $descendant -- # Ensure that $descendant is visible. # proc scrollview::see {w descendant} { upvar #0 $w W set xpos [set ypos 0] set d $descendant while {$d ne $W(slave)} { incr xpos [winfo x $d] incr ypos [winfo y $d] set d [winfo parent $d] if {$d eq "."} { return -code error "$descendant not a descendant of $w" } } See $w x $xpos [winfo width $descendant] See $w y $ypos [winfo height $descendant] } proc scrollview::See {w axis pos len} { upvar #0 $w W # ENSURE: first <= pos <= pos + len <= first + available # If both can't be satisfied, ensure first <= pos. set min [expr {$pos + $len - $W($axis.available)}] if {$W($axis.first) < $min} { SetFirst $w $axis $min } if {$pos < $W($axis.first)} { SetFirst $w $axis $pos } } #*EOF*