src/library/tcltk/exec/hierarchy.tcl

##
## Layout routines taken from oooold code, author unkown.
## Copyright 1995-1998 Jeffrey Hobbs, jeff.hobbs@acm.org
##
## Last Update: 28 June 1997
##
package require Widget 2.0
package provide Hierarchy 2.0

##-----------------------------------------------------------------------
## PROCEDURE(S)
##	hierarchy, hierarchy_dir, hierarchy_widget
##
## ARGUMENTS && DESCRIPTION
##
## hierarchy <window pathname> <options>
##	Implements a hierarchical listbox
## hierarchy_dir <window pathname> <options>
##	Implements a hierarchical listbox using a directory view structure
##	for the default methods
## hierarchy_widget <window pathname> <options>
##	Implements a hierarchical listbox using a widget view structure
##	for the default methods
##
## OPTIONS
##	(Any canvas option may be used with a hierarchy)
##
## -autoscrollbar TCL_BOOLEAN			DEFAULT: 1
##	Determines whether scrollbars automagically pop-up or
##	are permanently there.
##
## -browsecmd procedure				DEFAULT: noop
##	A command which the widget will execute when the node is expanded
##	to retrieve the children of a node.  The widget and node path are
##	appended to the command as a list of node names which
##	form a path to the node from the root.  Thus the first
##	element of this list will always be the root node.
##
## -command procedure				DEFAULT: noop
##	A command which the widget will execute when the node is toggled.
##	The name of the widget, the node path, and whether the children of
##	the node are showing (0/1) is appended to the procedure args.
##
## -decoration TCL_BOOLEAN			DEFAULT: 1
##	If this is true, the "tree" lines are drawn.
##
## -expand #					DEFAULT: 1
##	an integer value for an initial depth to expand to.
##
## -font fontname				DEFAULT: fixed
##	The default font used for the text.
##
## -foreground color				DEFAULT: black
##	The default foreground color used for text of unselected nodes.
##
## -ipad #					DEFAULT: 3
##	The internal space added between the image and the text for a
##	given node.
##
## -nodelook procedure				DEFAULT: noop
##	A command the widget will execute to get the look of a node.
##	The node is appended to the command as a list of
##	node-names which form a path to the node from the root.
##	Thus the first element of this list will always be the
##	root node.  Also appended is a 
##	boolean value which indicates whether the node's children
##	are currently displayed.  This allows the node's
##	look to change if it is "opened" or "closed".
##
##	This command must return a 4-tuple list containing:
##		0. the text to display at the node
##		1. the font to use for the text
##		2. an image to display
##		3. the foreground color to use for the node
##	If no font (ie. {}) is specified then
##	the value from -font is used.  If no image is specified
##	then no image is displayed.
##	The default is a command to which produces a nice look
##	for a file manager.  
##
## -paddepth #					DEFAULT: 12
##	The indent space added for child branches.
##
## -padstack #					DEFAULT: 2
##	The space added between two rows
##
## -root rootname				DEFAULT: {}
##  	The name of the root node of the tree.  Each node
##	name must be unique amongst the children of each node.
##
## -selectbackground color			DEFAULT: red
##	The default background color used for the text of selected nodes.
##
## -selectmode (single|browse|multiple)		DEFAULT: browse
##	Like listbox modes, "multiple" is a mix of multiple && extended.
##
## -showall TCL_BOOLEAN				DEFAULT: 0
##	For directory nodelook, also show Unix '.' (hidden) files/dirs.
##
## -showfiles TCL_BOOLEAN			DEFAULT: 0
##	Show files as well as directories.
##
## -showparent string				DEFAULT: {}
##	For hierarchy_dir nodelook, if string != {}, then it will show that
##	string which will reset the root node to its parent.
##
## METHODS
##	These are the methods that the hierachical listbox object recognizes.
##	(ie - hierachy .h ; .h <method> <args>)
##	Any unique substring is acceptable
##
## configure ?option? ?value option value ...?
## cget option
##	Standard tk widget routines.
##
## close index
##	Closes the specified index (will trigger -command).
##
## curselection
##	Returns the indices of the selected items.  This differs from the
##	listbox method because indices here have no implied order.
##
## get index ?index ...?
##	Returns the node paths of the items referenced.  Ranges are not
##	allowed.  Index specification is like that allowed by the index
##	method.
##
## qget index ?index ...?
##	As above, but the indices must be that of the item (as returned
##	by the index or curselection method).
##
## index index
##	Returns the hierarchy numerical index of the item (the numerical
##	index has no implied order relative to the list items).  index
##	may be of the form:
##
##	number - Specifies the element as a numerical index.
##	root   - specifies the root item.
##	string - Specifis an item that has that text in it's node.
##	@x,y   - Indicates the element that covers the point in
##		the listbox window specified by x and y (in pixel
##		coordinates).  If no element covers that point,
##		then the closest element to that point is used.
##
## open index
##	Opens the specified index (will trigger -command).
##
## see index
##	Ensures that the item specified by the index is viewable.
##
## refresh
##	Refreshes all open nodes
##
## selection option arg
##	This works like the listbox selection method with the following
##	exceptions:
##
##	The selection clear option can take multiple indices, but not a range.
##	No arguments to clear means clear all the selected elements.
##
##	The selection set option can take multiple indices, but not a range.
##	The key word 'all' sets the selection for all elements.
##
## size
##	Returns the number of items in the hierarchical listbox.
##
## toggle index
##	Toggles (open or closed) the item specified by index
##	(triggers -command).
##
## BINDINGS
##	Most Button-1 bindings on the hierarchy work in the same manner
##	as those for the listbox widget, as defined by the selectmode.
##	Those that vary are listed below:
##
## <Double-Button-1>
##	Toggles a node in the hierarchy
##
## NAMESPACE & STATE
##	The megawidget creates a global array with the classname, and a
## global array which is the name of each megawidget is created.  The latter
## array is deleted when the megawidget is destroyed.
##	Public procs of $CLASSNAME and [string tolower $CLASSNAME] are used.
## Other procs that begin with $CLASSNAME are private.  For each widget,
## commands named .$widgetname and $CLASSNAME$widgetname are created.
##
##-----------------------------------------------------------------------

# Create this to make sure there are registered in auto_mkindex
# these must come before the [widget create ...]
proc Hierarchy args {}
proc hierarchy args {}

## In general, we cannot use $data(basecmd) in the construction, but the
## scrollbar commands won't be called until after it really exists as a
## proper command
widget create Hierarchy -type frame -base canvas -components {
    {base canvas canvas {-relief sunken -bd 1 -highlightthickness 1 \
	    -yscrollcommand [list $data(yscrollbar) set] \
	    -xscrollcommand [list $data(xscrollbar) set]}}
    {scrollbar xscrollbar sx {-orient h -bd 1 -highlightthickness 1\
	    -command [list $data(basecmd) xview]}}
    {scrollbar yscrollbar sy {-orient v -bd 1 -highlightthickness 1\
	    -command [list $data(basecmd) yview]}}
} -options {
    {-autoscrollbar	autoScrollbar	AutoScrollbar	1}
    {-browsecmd		browseCmd	BrowseCmd	{}}
    {-command		command		Command		{}}
    {-decoration	decoration	Decoration	1}
    {-expand		expand		Expand		1}
    {-font		font		Font		fixed}
    {-foreground	foreground	Foreground	black}
    {-ipad		ipad		Ipad		3}
    {-nodelook		nodeLook	NodeLook	{}}
    {-paddepth		padDepth	PadDepth	12}
    {-padstack		padStack	PadStack	2}
    {-root		root		Root		{}}
    {-selectmode	selectMode	SelectMode	browse}
    {-selectbackground	selectBackground SelectBackground red}
    {-state		state		State		normal}

    {-showall		showAll		ShowAll		0}
    {-showparent	showParent	ShowParent	{}}
    {-showfiles		showFiles	ShowFiles	0}
}

proc hierarchy_dir {w args} {
    uplevel [list hierarchy $w -root [pwd] \
	    -nodelook  {namespace inscope ::Widget::Hierarchy FileLook} \
	    -command   {namespace inscope ::Widget::Hierarchy FileActivate} \
	    -browsecmd {namespace inscope ::Widget::Hierarchy FileList}] \
	    $args
}

proc hierarchy_widget {w args} {
    uplevel [list hierarchy $w -root . \
	    -nodelook  {namespace inscope ::Widget::Hierarchy WidgetLook} \
	    -command   {namespace inscope ::Widget::Hierarchy WidgetActivate} \
	    -browsecmd {namespace inscope ::Widget::Hierarchy WidgetList}] \
	    $args
}

namespace eval ::Widget::Hierarchy {;

;proc construct w {
    upvar \#0 [namespace current]::$w data

    ## Private variables
    array set data [list \
	    hasnodelook	0 \
	    halfpstk	[expr $data(-padstack)/2] \
	    width	400 \
	    ]

    grid $data(canvas) $data(yscrollbar) -sticky news
    grid $data(xscrollbar) -sticky ew
    grid columnconfig $w 0 -weight 1
    grid rowconfig $w 0 -weight 1
    bind $data(canvas) <Configure> [namespace code [list Resize $w %w %h]]
}

;proc init w {
    upvar \#0 [namespace current]::$w data

    set data(:$data(-root),showkids) 0
    ExpandNodeN $w $data(-root) $data(-expand)
    if {[catch {$w see $data(-root)}]} {
	$data(basecmd) configure -scrollregion {0 0 1 1}
    }
}

;proc configure {w args} {
    upvar \#0 [namespace current]::$w data

    set truth {^(1|yes|true|on)$}
    array set config { resize 0 root 0 showall 0 }
    foreach {key val} $args {
	switch -- $key {
	    -autoscrollbar {
		set val [regexp -nocase $truth $val]
		if {$val} {
		    set config(resize) 1
		} else {
		    grid $data(xscrollbar)
		    grid $data(yscrollbar)
		}
	    }
	    -decoration	{ set val [regexp -nocase $truth $val] }
	    -padstack	{ set data(halfpstk) [expr {$val/2}] }
	    -nodelook	{
		## We set this special bool val because it saves some
		## computation in ExpandNode, a deeply nested proc
		set data(hasnodelook) [string compare $val {}]
	    }
	    -root		{
		if {[info exists data(:$data(-root),showkids)]} {
		    ## All data about items and selection should be
		    ## cleared and the items deleted
		    foreach name [concat [array names data :*] \
			    [array names data S,*]] {unset data($name)}
		    $data(basecmd) delete all
		    set data(-root) $val
		    set config(root) 1
		    ## Avoid setting data($key) below
		    continue
		}
	    }
	    -selectbackground {
		foreach i [array names data S,*] {
		    $data(basecmd) itemconfigure [string range $i 2 end] \
			    -fill $val
		}
	    }
	    -state	{
		if {![regexp {^(normal|disabled)$} $val junk val]} {
		    return -code error "bad state value \"$val\":\
			    must be normal or disabled"
		}
	    }
	    -showall	-
	    -showfiles	{
		set val [regexp -nocase $truth $val]
		if {$val == $data($key)} continue
		set config(showall) 1
	    }
	}
	set data($key) $val
    }
    if {$config(root)} {
	set data(:$val,showkids) 0
	ExpandNodeN $w $val $data(-expand)
    } elseif {$config(showall) && [info exists data(:$data(-root),showkids)]} {
	_refresh $w
    } elseif {$config(resize)} {
	Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
    }
}

## Cryptic source code arguments explained:
## (these, or a similar form, might appear as variables later)
## np   == node path
## cnp  == changed np
## knp  == kids np
## xcnp == extra cnp

;proc _index { w idx } {
    upvar \#0 [namespace current]::$w data
    set c $data(basecmd)
    if {[string match all $idx]} {
	return [$c find withtag box]
    } elseif {[regexp {^(root|anchor)$} $idx]} {
	return [$c find withtag box:$data(-root)]
    }
    foreach i [$c find withtag $idx] {
	if {[string match rec* [$c type $i]]} { return $i }
    }
    if {[regexp {@(-?[0-9]+),(-?[0-9]+)} $idx z x y]} {
	return [$c find closest [$w canvasx $x] [$w canvasy $y] 1 text]
    }
    foreach i [$c find withtag box:[lindex $idx 0]] { return $i }
    return -code error "bad hierarchy index \"$idx\":\
	    must be current, @x,y, a number, or a node name"
}

;proc _selection { w args } {
    if {[string match {} $args]} {
	return -code error \
		"wrong \# args: should be \"$w selection option args\""
    }
    upvar \#0 [namespace current]::$w data
    set err [catch {_index $w [lindex $args 1]} idx]
    switch -glob -- [lindex $args 0] {
	an* {
	    ## anchor
	    ## stubbed out - too complicated to support
	}
	cl* {
	    ## clear
	    set c $data(basecmd)
	    if {$err} {
		foreach arg [array names data S,*] { unset data($arg) }
		$c itemconfig box -fill {}
	    } else {
		catch {unset data(S,$idx)}
		$c itemconfig $idx -fill {}
		foreach idx [lrange $args 2 end] {
		    if {[catch {_index $w $idx} idx]} {
			catch {unset data(S,$idx)}
			$c itemconfig $idx -fill {}
		    }
		}
	    }
	}
	in* {
	    ## includes
	    if {$err} {
		if {[llength $args]==2} {
		    return -code error $idx
		} else {
		    return -code error "wrong \# args:\
			    should be \"$w selection includes index\""
		}
	    }
	    return [info exists data(S,$idx)]
	}
	se* {
	    ## set
	    if {$err} {
		if {[string compare {} $args]} return
		return -code error "wrong \# args:\
			should be \"$w selection set index ?index ...?\""
	    } else {
		set c $data(basecmd); set col $data(-selectbackground)
		if {[string match all [lindex $args 1]]} {
		    foreach i $idx { set data(S,$i) 1 }
		    $c itemconfig box -fill $col
		} else {
		    set data(S,$idx) 1
		    $c itemconfig $idx -fill $col
		    foreach idx [lrange $args 2 end] {
			if {![catch {_index $w $idx} idx]} {
			    set data(S,$idx) 1
			    $c itemconfig $idx -fill $col
			}
		    }
		}
	    }
	}
	default {
	    return -code error "bad selection option \"[lindex $args 0]\":\
		    must be clear, includes, set"
	}
    }
}

;proc _curselection {w} {
    upvar \#0 [namespace current]::$w data

    set res {}
    foreach i [array names data S,*] { lappend res [string range $i 2 end] }
    return $res
}

;proc _get {w args} {
    upvar \#0 [namespace current]::$w data

    set nps {}
    foreach arg $args {
	if {![catch {_index $w $arg} idx] && \
		[string compare {} $idx]} {
	    set tags [$data(basecmd) gettags $idx]
	    if {[set i [lsearch -glob $tags box:*]]>-1} {
		lappend nps [string range [lindex $tags $i] 4 end]
	    }
	}
    }
    return $nps
}

;proc _qget {w args} {
    upvar \#0 [namespace current]::$w data

    ## Quick get.  Avoids expensive _index call
    set nps {}
    foreach arg $args {
	set tags [$data(basecmd) itemcget $arg -tags]
	if {[set i [lsearch -glob $tags box:*]]>-1} {
	    lappend nps [string range [lindex $tags $i] 4 end]
	}
    }
    return $nps
}

;proc _see {w args} {
    upvar \#0 [namespace current]::$w data

    if {[catch {_index $w $args} idx]} {
	return -code error $idx
    } elseif {[string compare {} $idx]} {
	set c $data(basecmd)
	foreach {x y x1 y1} [$c bbox $idx] {top btm} [$c yview] {
	    set stk [lindex [$c cget -scrollregion] 3]
	    set pos [expr (($y1+$y)/2.0)/$stk - ($btm-$top)/2.0]
	}
	$c yview moveto $pos
    }
}

;proc _refresh {w} {
    upvar \#0 [namespace current]::$w data

    array set expanded [array get data ":*,showkids"]
    foreach i [concat [array names data :*] \
	    [array names data S,*]] {unset data($i)}
    $data(basecmd) delete all
    ## -dec makes it sort in root-first order
    foreach i [lsort -ascii -decreasing [array names expanded]] {
	if {$expanded($i)} {
	    regexp {^:(.*),showkids$} $i junk np
	    ## Quick way to remove the last element of a list
	    set prnt [lreplace $np end end]
	    ## checks to get rid of dead, previously opened nodes
	    if {[string match {} $prnt] || ([info exists data(:$prnt,kids)] \
		    && [lsearch -exact $data(:$prnt,kids) \
		    [lindex $np end]] != -1)} {
		set data($i) 0
		ExpandNode $w $np
	    }
	}
    }
    Redraw $w $data(-root)
    Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
}

;proc _size {w} {
    upvar \#0 [namespace current]::$w data
    return [llength [$data(basecmd) find withtag box]]
}

## This will be the one called by <Double-Button-1> on the canvas,
## if -state is normal, so we have to make sure that $w is correct.
##
;proc _toggle { w index } {
    toggle $w $index toggle
}

;proc _close { w index } {
    toggle $w $index close
}

;proc _open { w index } {
    toggle $w $index open
}

;proc toggle { w index which } {
    if {[string compare Hierarchy [winfo class $w]]} {
	set w [winfo parent $w]
    }
    upvar \#0 [namespace current]::$w data

    if {[string match {} [set np [_get $w $index]]]} return
    set np [lindex $np 0]

    set old [$data(basecmd) cget -cursor]
    $data(basecmd) config -cursor watch
    update
    switch $which {
	close	{ CollapseNodeAll $w $np }
	open	{ ExpandNodeN $w $np 1 }
	toggle	{
	    if {$data(:$np,showkids)} {
		CollapseNodeAll $w $np
	    } else {
		ExpandNodeN $w $np 1
	    }
	}
    }
    if {[string compare {} $data(-command)]} {
	uplevel \#0 $data(-command) [list $w $np $data(:$np,showkids)]
    }
    $data(basecmd) config -cursor $old
    return
}

;proc Resize { w wid hgt } {
    upvar \#0 [namespace current]::$w data
    set c $data(basecmd)
    if {[string compare {} [set box [$c bbox image text]]]} {
	set X [lindex $box 2]
	if {$data(-autoscrollbar)} {
	    set Y [lindex $box 3]
	    if {$wid>$X} {
		set X $wid
		grid remove $data(xscrollbar)
	    } else {
		grid $data(xscrollbar)
	    }
	    if {$hgt>$Y} {
		set Y $hgt
		grid remove $data(yscrollbar)
	    } else {
		grid $data(yscrollbar)
	    }
	    $c config -scrollregion "0 0 $X $Y"
	}
	## This makes full width highlight boxes
	## data(width) is the default width of boxes
	if {$X>$data(width)} {
	    set data(width) $X
	    foreach b [$c find withtag box] {
		foreach {x y x1 y1} [$c coords $b] { $c coords $b 0 $y $X $y1 }
	    }
	}
    } elseif {$data(-autoscrollbar)} {
	grid remove $data(xscrollbar) $data(yscrollbar)
    }
}

;proc CollapseNodeAll { w np } {
    if {[CollapseNode $w $np]} {
	upvar \#0 [namespace current]::$w data
	Redraw $w $np
	DiscardChildren $w $np
	Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
    }
}

;proc ExpandNodeN { w np n } {
    upvar \#0 [namespace current]::$w data
    if {[ExpandNodeN_aux $w $np $n] || \
	    ([string compare $data(-root) {}] && \
	    ![string compare $data(-root) $np])} {
	Redraw $w $np
	Resize $w [winfo width $data(canvas)] [winfo height $data(canvas)]
    }
}

;proc ExpandNodeN_aux { w np n } {
    if {![ExpandNode $w $np]} { return 0 }
    if {$n==1} { return 1 }
    incr n -1
    upvar \#0 [namespace current]::$w data
    foreach k $data(:$np,kids) {
	ExpandNodeN_aux $w "$np [list $k]" $n
    }
    return 1
}

########################################################################
##
## Private routines to collapse and expand a single node w/o redrawing
## Most routines return 0/1 to indicate if any change has occurred
##
########################################################################

;proc ExpandNode { w np } {
    upvar \#0 [namespace current]::$w data

    if {$data(:$np,showkids)} { return 0 }
    set data(:$np,showkids) 1
    if {![info exists data(:$np,kids)]} {
	if {[string compare $data(-browsecmd) {}]} {
	    set data(:$np,kids) [uplevel \#0 $data(-browsecmd) [list $w $np]]
	} else {
	    set data(:$np,kids) {}
	}
    }
    if $data(hasnodelook) {
	set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 1]]
    } else {
	set data(:$np,look) {}
    }
    if {[string match {} $data(:$np,kids)]} {
	## This is needed when there are no kids to make sure the
	## look of the node will be updated appropriately
	foreach {txt font img fg} $data(:$np,look) {
	    lappend tags box:$np box $np
	    set c $data(basecmd)
	    if {[string compare $img {}]} {
		## Catch just in case the image doesn't exist
		catch {
		    $c itemconfigure img:$np -image $img
		    lappend tags $img
		}
	    }
	    if {[string compare $txt {}]} {
		if {[string match {} $font]} { set font $data(-font) }
		if {[string match {} $fg]}   { set fg $data(-foreground) }
		$c itemconfigure txt:$np -fill $fg -text $txt -font $font
		if {[string compare $np $txt]} { lappend tags $txt }
	    }
	    $c itemconfigure box:$np -tags $tags
	    ## We only want to go through once
	    break
	}
	return 0
    }
    foreach k $data(:$np,kids) {
	set knp "$np [list $k]"
	## Check to make sure it doesn't already exist,
	## in case we are refreshing the node or something
	if {![info exists data(:$knp,showkids)]} { set data(:$knp,showkids) 0 }
	if $data(hasnodelook) {
	    set data(:$knp,look) [uplevel \#0 $data(-nodelook) [list $w $knp 0]]
	} else {
	    set data(:$knp,look) {}
	}
    }
    return 1
}

;proc CollapseNode { w np } {
    upvar \#0 [namespace current]::$w data
    if {!$data(:$np,showkids)} { return 0 }
    set data(:$np,showkids) 0
    if {[string match {} $data(:$np,kids)]} { return 0 }
    if {[string compare $data(-nodelook) {}]} {
	set data(:$np,look) [uplevel \#0 $data(-nodelook) [list $w $np 0]]
    } else {
	set data(:$np,look) {}
    }
    foreach k $data(:$np,kids) { CollapseNode $w "$np [list $k]" }
    return 1
}

;proc DiscardChildren { w np } {
    upvar \#0 [namespace current]::$w data
    if {[info exists data(:$np,kids)]} {
	foreach k $data(:$np,kids) {
	    set knp "$np [list $k]"
	    $data(basecmd) delete img:$knp txt:$knp box:$knp
	    foreach i {showkids look stkusg stack iwidth offset} {
		catch {unset data(:$knp,$i)}
	    }
	    DiscardChildren $w $knp
	}
	unset data(:$np,kids)
    }
}

## REDRAW mechanism
## 2 parts:	recompute offsets of all children from changed node path
##		then redraw children based on their offsets and look
##
;proc Redraw { w cnp } {
    upvar \#0 [namespace current]::$w data

    set c $data(basecmd)
    # When a node changes, the positions of a whole lot of things
    # change.  The size of the scroll region also changes.
    $c delete decor

    # Calculate the new offset locations of everything
    Recompute $w $data(-root) [lrange $cnp 1 end]

    # Next recursively move all the bits around to their correct positions.
    # We choose an initial point (4,4) to begin at.
    Redraw_aux $w $data(-root) 4 4

    # Necessary to make sure find closest gets the right item
    # ordering: image > text > box
    after idle "catch { [list $c] raise image text; [list $c] lower box text }"
}

## RECOMPUTE recurses through the tree working out the relative offsets
## of children from their parents in terms of stack values.  
##
## "cnp" is either empty or a node name which indicates where the only
## changes have occured in the hierarchy since the last call to Recompute.
## This is used because when a node is toggled on/off deep in the
## hierarchy then not all the positions of items need to be recomputed.
## The only ones that do are everything below the changed node (of
## course), and also everything which might depend on the stack usage of
## that node (i.e. everything above it).  Specifically the usages of the
## changed node's siblings do *not* need to be recomputed.
##
;proc Recompute { w np cnp } {
    upvar \#0 [namespace current]::$w data
    # If the cnp now has only one element then
    # it must be one of the children of the current node.
    # We do not need to Recompute the usages of its siblings if it is.
    set cnode_is_child [expr {[llength $cnp]==1}]
    if {$cnode_is_child} {
	set cnode [lindex $cnp 0]
    } else {
	set xcnp [lrange $cnp 1 end]
    }
    
    # Run through the children, recursively calculating their usage of
    # stack real-estate, and allocating an intial placement for each child
    #
    # Values do not need to be recomputed for siblings of the changed
    # node and their descendants.  For the cnode itself, in the
    # recursive call we set the value of cnode to {} to prevent
    # any further cnode checks.

    set children_stack 0
    if {$data(:$np,showkids)} { 
	foreach k $data(:$np,kids) {
	    set knp "$np [list $k]"
	    set data(:$knp,offset) $children_stack
	    if {$cnode_is_child && [string match $cnode $k]} {
		set data(:$knp,stkusg) [Recompute $w $knp {}]
	    } elseif {!$cnode_is_child} {
		set data(:$knp,stkusg) [Recompute $w $knp $xcnp]
	    }
	    incr children_stack $data(:$knp,stkusg)
	    incr children_stack $data(-padstack)
	}
    }

    ## Make the image/text if they don't exist.
    ## Positioning occurs in Redraw_aux.
    ## And calculate the stack usage of our little piece of the world.
    set img_height 0; set img_width 0; set txt_width 0; set txt_height 0

    foreach {txt font img fg} $data(:$np,look) {
	lappend tags box:$np box $np
	set c $data(basecmd)
	if {[string compare $img {}]} {
	    if {[string match {} [$c find withtag img:$np]]} {
		$c create image 0 0 -anchor nw -tags [list img:$np image]
	    }
	    ## Catch just in case the image doesn't exist
	    catch {
		$c itemconfigure img:$np -image $img
		lappend tags $img
		foreach {x y img_width img_height} [$c bbox img:$np] {
		    incr img_width -$x; incr img_height -$y
		}
	    }
	}
	if {[string compare $txt {}]} {
	    if {[string match {} [$c find withtag txt:$np]]} {
		$c create text 0 0 -anchor nw -tags [list txt:$np text]
	    }
	    if {[string match {} $font]} { set font $data(-font) }
	    if {[string match {} $fg]}   { set fg $data(-foreground) }
	    $c itemconfigure txt:$np -fill $fg -text $txt -font $font
	    if {[string compare $np $txt]} { lappend tags $txt }
	    foreach {x y txt_width txt_height} [$c bbox txt:$np] {
		incr txt_width -$x; incr txt_height -$y
	    }
	}
	if {[string match {} [$c find withtag box:$np]]} {
	    $c create rect 0 0 1 1 -tags [list box:$np box] -outline {}
	}
	$c itemconfigure box:$np -tags $tags
	## We only want to go through this once
	break
    }

    set stack [expr {$txt_height>$img_height?$txt_height:$img_height}]

    # Now reposition the children downward by "stack"
    set overall_stack [expr {$children_stack+$stack}]

    if {$data(:$np,showkids)} { 
	set off [expr {$stack+$data(-padstack)}]
	foreach k $data(:$np,kids) {
	    set knp "$np [list $k]"
	    incr data(:$knp,offset) $off
	}
    }
    # remember some facts for locating the image and drawing decor
    array set data [list :$np,stack $stack :$np,iwidth $img_width]

    return $overall_stack
}

;proc Redraw_aux {w np deppos stkpos} {
    upvar \#0 [namespace current]::$w data

    set c $data(basecmd)
    $c coords img:$np $deppos $stkpos
    $c coords txt:$np [expr {$deppos+$data(:$np,iwidth)+$data(-ipad)}] $stkpos
    $c coords box:$np 0 [expr {$stkpos-$data(halfpstk)}] \
	    $data(width) [expr {$stkpos+$data(:$np,stack)+$data(halfpstk)}]

    if {!$data(:$np,showkids) || [string match {} $data(:$np,kids)]} return

    set minkid_stkpos 100000
    set maxkid_stkpos 0
    set bar_deppos [expr {$deppos+$data(-paddepth)/2}]
    set kid_deppos [expr {$deppos+$data(-paddepth)}]

    foreach k $data(:$np,kids) {
	set knp "$np [list $k]"
	set kid_stkpos [expr {$stkpos+$data(:$knp,offset)}]
	Redraw_aux $w $knp $kid_deppos $kid_stkpos
	
	if {$data(-decoration)} {
	    if {$kid_stkpos<$minkid_stkpos} {set minkid_stkpos $kid_stkpos}
	    set kid_stkpos [expr {$kid_stkpos+$data(:$knp,stack)/2}]
	    if {$kid_stkpos>$maxkid_stkpos} {set maxkid_stkpos $kid_stkpos}
	    
	    $c create line $bar_deppos $kid_stkpos $kid_deppos $kid_stkpos \
		    -width 1 -tags decor
	}
    }
    if {$data(-decoration)} {
	$c create line $bar_deppos $minkid_stkpos $bar_deppos $maxkid_stkpos \
		-width 1 -tags decor
    }
}


##
## DEFAULT BINDINGS FOR HIERARCHY
##
## Since we give no border to the frame, all Hierarchy bindings
## will always register on the canvas widget
##
bind Hierarchy <Double-Button-1> {
    set w [winfo parent %W]
    if {[string match normal [$w cget -state]]} {
	$w toggle @%x,%y
    }
}
bind Hierarchy <ButtonPress-1> {
    if {[winfo exists %W]} {
	namespace eval ::Widget::Hierarchy \
		[list BeginSelect [winfo parent %W] @%x,%y]
    }
}
bind Hierarchy <B1-Motion> {
    set tkPriv(x) %x
    set tkPriv(y) %y
    namespace eval ::Widget::Hierarchy [list Motion [winfo parent %W] @%x,%y]
}
bind Hierarchy <ButtonRelease-1> { tkCancelRepeat }
bind Hierarchy <Shift-1>   [namespace code \
	{ BeginExtend [winfo parent %W] @%x,%y }]
bind Hierarchy <Control-1> [namespace code \
	{ BeginToggle [winfo parent %W] @%x,%y }]
bind Hierarchy <B1-Leave> {
    set tkPriv(x) %x
    set tkPriv(y) %y
    namespace eval ::Widget::Hierarchy [list AutoScan [winfo parent %W]]
}
bind Hierarchy <B1-Enter>	{ tkCancelRepeat }

## Should reserve L/R U/D for traversing nodes
bind Hierarchy <Up>		{ %W yview scroll -1 units }
bind Hierarchy <Down>		{ %W yview scroll  1 units }
bind Hierarchy <Left>		{ %W xview scroll -1 units }
bind Hierarchy <Right>		{ %W xview scroll  1 units }

bind Hierarchy <Control-Up>	{ %W yview scroll -1 pages }
bind Hierarchy <Control-Down>	{ %W yview scroll  1 pages }
bind Hierarchy <Control-Left>	{ %W xview scroll -1 pages }
bind Hierarchy <Control-Right>	{ %W xview scroll  1 pages }
bind Hierarchy <Prior>		{ %W yview scroll -1 pages }
bind Hierarchy <Next>		{ %W yview scroll  1 pages }
bind Hierarchy <Control-Prior>	{ %W xview scroll -1 pages }
bind Hierarchy <Control-Next>	{ %W xview scroll  1 pages }
bind Hierarchy <Home>		{ %W xview moveto 0 }
bind Hierarchy <End>		{ %W xview moveto 1 }
bind Hierarchy <Control-slash>	[namespace code \
	{ SelectAll [winfo parent %W] }]
bind Hierarchy <Control-backslash> [namespace code \
	{ [winfo parent %W] selection clear }]

bind Hierarchy <2> {
    set tkPriv(x) %x
    set tkPriv(y) %y
    %W scan mark %x %y
}
bind Hierarchy <B2-Motion> {
    %W scan dragto $tkPriv(x) %y
}

## BINDING HELPER PROCEDURES
##
## These are mostly mirrored from the Listbox class bindings.
##
## Some of these are hacked up to be more efficient by making calls
## that require forknowledge of the megawidget structure.
##

# BeginSelect --
#
# This procedure is typically invoked on button-1 presses.  It begins
# the process of making a selection in the hierarchy.  Its exact behavior
# depends on the selection mode currently in effect for the hierarchy;
# see the Motif documentation for details.
#
# Arguments:
# w -		The hierarchy widget.
# el -		The element for the selection operation (typically the
#		one under the pointer).  Must be in numerical form.

;proc BeginSelect {w el} {
    global tkPriv
    if {[catch {_index $w $el} el]} return
    _selection $w clear
    _selection $w set $el
    set tkPriv(hierarchyPrev) $el
}

# Motion --
#
# This procedure is called to process mouse motion events while
# button 1 is down.  It may move or extend the selection, depending
# on the hierarchy's selection mode.
#
# Arguments:
# w -		The hierarchy widget.
# el -		The element under the pointer (must be a number).

;proc Motion {w el} {
    global tkPriv
    if {[catch {_index $w $el} el] || \
	    [string match $el $tkPriv(hierarchyPrev)]} return
    switch [_cget $w -selectmode] {
	browse {
	    _selection $w clear 0 end
	    if {![catch {_selection $w set $el}]} {
		set tkPriv(hierarchyPrev) $el
	    }
	}
	multiple {
	    ## This happens when a double-1 occurs and all the index boxes
	    ## have changed
	    if {[catch {_selection $w includes \
		    $tkPriv(hierarchyPrev)} inc]} {
		set tkPriv(hierarchyPrev) [_index $w $el]
		return
	    }
	    if {$inc} {
		_selection $w set $el
	    } else {
		_selection $w clear $el
	    }
	    set tkPriv(hierarchyPrev) $el
	}
    }
}

# BeginExtend --
#
# This procedure is typically invoked on shift-button-1 presses.  It
# begins the process of extending a selection in the hierarchy.  Its
# exact behavior depends on the selection mode currently in effect
# for the hierarchy;
#
# Arguments:
# w -		The hierarchy widget.
# el -		The element for the selection operation (typically the
#		one under the pointer).  Must be in numerical form.

;proc BeginExtend {w el} {
    if {[catch {_index $w $el} el]} return
    if {[string match multiple [_cget $w -selectmode]]} {
	Motion $w $el
    }
}

# BeginToggle --
#
# This procedure is typically invoked on control-button-1 presses.  It
# begins the process of toggling a selection in the hierarchy.  Its
# exact behavior depends on the selection mode currently in effect
# for the hierarchy;  see the Motif documentation for details.
#
# Arguments:
# w -		The hierarchy widget.
# el -		The element for the selection operation (typically the
#		one under the pointer).  Must be in numerical form.

;proc BeginToggle {w el} {
    global tkPriv
    if {[catch {_index $w $el} el]} return
    if {[string match multiple [_cget $w -selectmode]]} {
	_selection $w anchor $el
	if {[_selection $w includes $el]} {
	    _selection $w clear $el
	} else {
	    _selection $w set $el
	}
	set tkPriv(hierarchyPrev) $el
    }
}

# AutoScan --
# This procedure is invoked when the mouse leaves an entry window
# with button 1 down.  It scrolls the window up, down, left, or
# right, depending on where the mouse left the window, and reschedules
# itself as an "after" command so that the window continues to scroll until
# the mouse moves back into the window or the mouse button is released.
#
# Arguments:
# w -		The hierarchy widget.

;proc AutoScan {w} {
    global tkPriv
    if {![winfo exists $w]} return
    set x $tkPriv(x)
    set y $tkPriv(y)
    if {$y>=[winfo height $w]} {
	$w yview scroll 1 units
    } elseif {$y<0} {
	$w yview scroll -1 units
    } elseif {$x>=[winfo width $w]} {
	$w xview scroll 2 units
    } elseif {$x<0} {
	$w xview scroll -2 units
    } else {
	return
    }
    #Motion $w [$w index @$x,$y]
    set tkPriv(afterId) [after 50 [namespace current]::AutoScan $w]
}

# SelectAll
#
# This procedure is invoked to handle the "select all" operation.
# For single and browse mode, it just selects the root element.
# Otherwise it selects everything in the widget.
#
# Arguments:
# w -		The hierarchy widget.

;proc SelectAll w {
    if {[regexp (browse|single) [_cget $w -selectmode]]} {
	_selection $w clear
	_selection $w set root
    } else {
	_selection $w set all
    }
}

#------------------------------------------------------------
# Default nodelook methods
#------------------------------------------------------------

;proc FileLook { w np isopen } {
    upvar \#0 [namespace current]::$w data
    set path [eval file join $np]
    set file [lindex $np end]
    set bmp  {}
    if {[file readable $path]} {
	if {[file isdirectory $path]} {
	    if {$isopen} {
		## We know that kids will always be set by the time
		## the isopen is set to 1
		if {[string compare $data(:$np,kids) {}]} {
		    set bmp ::Widget::Hierarchy::bmp:dir_minus
		} else {
		    set bmp ::Widget::Hierarchy::bmp:dir
		}
	    } else {
		set bmp ::Widget::Hierarchy::bmp:dir_plus
	    }
	    if 0 {
		## NOTE: accurate, but very expensive
		if {[string compare [FileList $w $np] {}]} {
		    set bmp [expr {$isopen ?\
			    {::Widget::Hierarchy::bmp:dir_minus} :\
			    {::Widget::Hierarchy::bmp:dir_plus}}]
		} else {
		    set bmp ::Widget::Hierarchy::bmp:dir
		}
	    }
	}
	set fg \#000000
    } elseif {[string compare $data(-showparent) {}] && \
	    [string match $data(-showparent) $file]} {
	set fg \#0000FF
	set bmp ::Widget::Hierarchy::bmp:up
    } else {
	set fg \#a9a9a9
	if {[file isdirectory $path]} {set bmp ::Widget::Hierarchy::bmp:dir}
    }
    return [list $file $data(-font) $bmp $fg] 
}

## FileList
# ARGS:	w	hierarchy widget
#	np	node path	
# Returns:	directory listing
##
;proc FileList { w np } {
    set pwd [pwd]
    if {[catch "cd \[file join $np\]"]} {
	set list {}
    } else {
	global tcl_platform
	upvar \#0 [namespace current]::$w data
	set str *
	if {!$data(-showfiles)} { append str / }
	if {$data(-showall) && [string match unix $tcl_platform(platform)]} {
	    ## NOTE: Use of non-core lremove
	    if {[catch {lsort [concat [glob -nocomplain $str] \
		    [lremove [glob -nocomplain .$str] {. ..}]]} list]} {
		return {}
	    }
	} else {
	    ## The extra catch is necessary for unusual error conditions
	    if {[catch {lsort [glob -nocomplain $str]} list]} {
		return {}
	    }
	}
	set root $data(-root)
	if {[string compare {} $data(-showparent)] && \
		[string match $root $np]} {
	    if {![regexp {^(.:)?/+$} $root] && \
		    [string compare [file dir $root] $root]} {
		set list [linsert $list 0 $data(-showparent)]
	    }
	}
    }
    cd $pwd
    return $list
}

;proc FileActivate { w np isopen } {
    upvar \#0 [namespace current]::$w data
    set path [eval file join $np]
    if {[file isdirectory $path]} return
    if {[string compare $data(-showparent) {}] && \
	    [string match $data(-showparent) [lindex $np end]]} {
	$w configure -root [file dir $data(-root)]
    }
}

;proc WidgetLook { W np isopen } {
    upvar \#0 [namespace current]::$W data
    if {$data(-showall)} {
	set w [lindex $np end]
    } else {
	set w [join $np {}]
	regsub {\.\.} $w {.} w
    }
    if {[string compare [winfo children $w] {}]} {set fg blue} {set fg black}
    return [list "\[[winfo class $w]\] [lindex $np end]" {} {} $fg]
}

;proc WidgetList { W np } {
    upvar \#0 [namespace current]::$W data
    if {$data(-showall)} {
	set w [lindex $np end]
    } else {
	set w [join $np {}]
	regsub {\.\.} $w {.} w
    }
    set kids {}
    foreach i [lsort [winfo children $w]] {
	if {$data(-showall)} {
	    lappend kids $i
	} else {
	    lappend kids [file extension $i]
	}
    }
    return $kids
}

;proc WidgetActivate { w np isopen } {}


## BITMAPS
##
image create bitmap ::Widget::Hierarchy::bmp:dir -data {#define folder_width 16
#define folder_height 12
static char folder_bits[] = {
  0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
  0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
image create bitmap ::Widget::Hierarchy::bmp:dir_plus -data {#define folder_plus_width 16
  #define folder_plus_height 12
static char folder_plus_bits[] = {
  0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x82, 0x40,
  0x82, 0x40, 0xe2, 0x43, 0x82, 0x40, 0x82, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
image create bitmap ::Widget::Hierarchy::bmp:dir_minus -data {#define folder_minus_width 16
#define folder_minus_height 12
static char folder_minus_bits[] = {
  0x00, 0x1f, 0x80, 0x20, 0x40, 0x20, 0xfc, 0x7f, 0x02, 0x40, 0x02, 0x40,
  0x02, 0x40, 0xe2, 0x43, 0x02, 0x40, 0x02, 0x40, 0x02, 0x40, 0xfe, 0x7f};}
image create bitmap ::Widget::Hierarchy::bmp:up -data {#define up.xbm_width 16
#define up.xbm_height 12
static unsigned char up.xbm_bits[] = {
  0x00, 0x00, 0x10, 0x00, 0x38, 0x00, 0x7c, 0x00, 0xfe, 0x00, 0x38, 0x00,
  0x38, 0x00, 0x38, 0x00, 0xf8, 0x7f, 0xf0, 0x7f, 0xe0, 0x7f, 0x00, 0x00};}
image create bitmap ::Widget::Hierarchy::bmp:text -data {#define text_width 15
#define text_height 14
static char text_bits[] = {
  0xff,0x07,0x01,0x0c,0x01,0x04,0x01,0x24,0xf9,0x7d,0x01,0x78,0x01,0x40,0xf1,
  0x41,0x01,0x40,0x01,0x40,0xf1,0x41,0x01,0x40,0x01,0x40,0xff,0x7f};}

}; # end namespace ::Widget::Hierarchy

return