scrollview metawidget

### 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*