Implement tree package

Similar to tcllib ::struct::tree

------------------------------------------------------------------------

1 files changed, 332 insertions, 0 deletions

diff --git a/tree.tcl b/tree.tcl
new file mode 100644
index 0000000..c534f85
--- /dev/null
+++ b/tree.tcl
@@ -0,0 +1,332 @@
+package provide tree
+
+# Broadly compatible with tcllib ::struct::tree
+
+# tree create procname
+#
+#   Create a tree named $procname
+#   This automatically creates a node named "root"
+#
+# tree destroy procname
+#
+#   Destroy the tree and all it's nodes
+#
+# $pt set <nodename> <key> <value>
+#
+#   Set the value for the given key
+#
+# $pt lappend <nodename> <key> <value>
+#
+#   Append to the (list) value for the given key, or set if not yet set
+#
+# $pt keyexists <nodename> <key>
+#
+#   Returns 1 if the given key exists
+#
+# $pt get <nodename> <key>
+#
+#   Returns the value associated with the given key
+# 
+# $pt depth <nodename>
+#
+#   Returns the depth of the given node. The depth of "root" is 0.
+#
+# $pt parent <nodename>
+#
+#   Returns the name of the parent node, or "" for the root node.
+# 
+# $pt numchildren <nodename>
+#
+#   Returns the number of child nodes.
+# 
+# $pt children <nodename>
+#
+#   Returns a list of the child nodes.
+# 
+# $pt next <nodename>
+#
+#   Returns the next sibling node, or "" if none.
+# 
+# $pt insert <nodename> <index>
+#
+#   Add a new child node to the given node.
+#   Currently the node is always added at the end (index=end)
+#   Returns the name of the newly added node
+#
+# $pt walk <nodename> dfs|bfs {actionvar nodevar} <code>
+#
+#   Walks the tree starting from the given node, either breadth first (bfs)
+#   depth first (dfs).
+#   The value "enter" or "exit" is stored in variable $actionvar
+#   The name of each node is stored in $nodevar.
+#   The script $code is evaluated twice for each node, on entry and exit.
+
+# tree create handle
+# tree destroy handle
+#
+proc tree {action handle} {
+	# A tree is a dictionary of (name, noderef)
+	# The name for the root node is always "root",
+	# and other nodes are automatically named "node1", "node2", etc.
+
+	if {$action eq "destroy"} {
+		$handle destroy
+		rename $handle ""
+		return
+	} elseif {$action eq "create"} {
+		# Create the root node
+		foreach {dummy rootref} [_tree_makenode ""] {}
+
+		# Create the tree containing one node
+		set tree [dict create root $rootref]
+
+		# And create a reference to a tree dictionary
+		set treeref [ref $tree tree]
+
+		proc $handle {command args} {treeref} {
+			#puts "You invoked [list treehandle $command $args]"
+			uplevel 1 [list tree_$command $treeref {expand}$args]
+		}
+	} else {
+		error "Usage: tree destroy|create handle"
+	}
+}
+
+# treehandle destroy
+#
+# Discards all the nodes
+#
+proc tree_destroy {treeref} {
+	set tree [getref $treeref]
+	foreach {nodename noderef} $tree {
+		set node [getref $noderef]
+		unset node
+	}
+	unset tree
+}
+
+# treehandle insert node ?index?
+#
+proc tree_insert {treeref node {index end}} {
+	# Get the parent node
+	set parentref [_tree_getnoderef $treeref $node]
+
+	# Make a new node
+	foreach {childname childref} [_tree_makenode $parentref] {}
+
+	# Add it to the list of children in the parent node
+	_tree_update_node $treeref $node parent {
+		lappend parent(.children) $childref
+	}
+
+	# Add it to the tree
+	_tree_update_tree $treeref tree {
+		set tree($childname) $childref
+	}
+
+	return $childname
+}
+
+# treehandle set node key value
+#
+proc tree_set {treeref node key value} {
+	_tree_update_node $treeref $node n {
+		set n($key) $value
+	}
+	return $value
+}
+
+# treehandle lappend node key value
+#
+proc tree_lappend {treeref node key value} {
+	_tree_update_node $treeref $node n {
+		lappend n($key) $value
+		set result $n($key)
+	}
+	return $result
+}
+
+# treehandle get node key
+#
+proc tree_get {treeref node key} {
+	set n [_tree_getnode $treeref $node]
+
+	return $n($key)
+}
+
+# treehandle keyexists node key
+#
+proc tree_keyexists {treeref node key} {
+	set n [_tree_getnode $treeref $node]
+	info exists n($key)
+}
+
+# treehandle depth node
+#
+proc tree_depth {treeref node} {
+	set n [_tree_getnode $treeref $node]
+	return $n(.depth)
+}
+
+# treehandle parent node
+#
+proc tree_parent {treeref node} {
+	set n [_tree_getnode $treeref $node]
+	return $n(.parent)
+}
+
+# treehandle numchildren node
+#
+proc tree_numchildren {treeref node} {
+	set n [_tree_getnode $treeref $node]
+	llength $n(.children)
+}
+
+# treehandle children node
+#
+proc tree_children {treeref node} {
+	set n [_tree_getnode $treeref $node]
+	set result {}
+	foreach child $n(.children) {
+		set c [getref $child]
+		lappend result $c(.name)
+	}
+	return $result
+}
+
+# treehandle next node
+#
+proc tree_next {treeref node} {
+	set parent [tree_parent $treeref $node]
+	set siblings [tree_children $treeref $parent] 
+	set i [lsearch $siblings $node]
+	incr i
+	return [lindex $siblings $i]
+}
+
+# treehandle walk node bfs|dfs {action loopvar} <code>
+#
+proc tree_walk {treeref node type vars code} {
+	set n [_tree_getnode $treeref $node]
+
+	# set up vars
+	foreach {actionvar namevar} $vars {}
+
+	if {$type ne "child"} {
+		upvar $namevar name
+		upvar $actionvar action
+
+		# Enter this node
+		set name $node
+		set action enter
+
+		uplevel 1 $code
+	}
+
+	if {$type eq "dfs"} {
+		# Depth-first so do the children
+		foreach childref $n(.children) {
+			set child [getref $childref]
+			uplevel 1 [list tree_walk $treeref $child(.name) $type $vars $code]
+		}
+	} elseif {$type ne "none"} {
+		# Breadth-first so do the children to one level only
+		foreach childref $n(.children) {
+			set child [getref $childref]
+			uplevel 1 [list tree_walk $treeref $child(.name) none $vars $code]
+		}
+
+		# Now our grandchildren
+		foreach childref $n(.children) {
+			set child [getref $childref]
+			uplevel 1 [list tree_walk $treeref $child(.name) child $vars $code]
+		}
+	}
+
+	if {$type ne "child"} {
+		# Exit this node
+		set name $node
+		set action exit
+
+		uplevel 1 $code
+	}
+}
+
+#
+# INTERNAL procedures below this point
+#
+
+# Make a new child node of the parent
+#
+# Note that this does *not* add the node
+# to the parent or to the tree
+#
+# Returns a list of {nodename noderef}
+#
+proc _tree_makenode {parent} {{nodeid 1}} {
+	if {$parent eq ""} {
+		# The root node
+		set name root
+		set depth 0
+		set parentname ""
+	} else {
+		set parentnode [getref $parent]
+
+		set name node$nodeid
+		incr nodeid
+		set depth $parentnode(.depth)
+		incr depth
+		set parentname $parentnode(.name)
+	}
+
+	# Return a list of name, reference
+	list $name [ref [list .name $name .depth $depth .parent $parentname .children {}] node]
+}
+
+# Return the node (dictionary value) with the given name
+#
+proc _tree_getnode {treeref node} {
+	getref [dict get [getref $treeref] $node]
+}
+
+# Return the noderef with the given name
+#
+proc _tree_getnoderef {treeref node} {
+	dict get [getref $treeref] $node
+}
+
+# Set a dictionary value named $varname in the parent context,
+# evaluate $code, and then store any changes to
+# the node (via $varname) back to the node
+#
+proc _tree_update_node {treeref node varname code} {
+	upvar $varname n
+
+	# Get a reference to the node
+	set ref [_tree_getnoderef $treeref $node]
+
+	# Get the node itself
+	set n [getref $ref]
+
+	uplevel 1 $code
+
+	# And update the reference
+	setref $ref $n
+}
+
+# Set a dictionary value named $varname in the parent context,
+# evaluate $code, and then store any changes to
+# the tree (via $varname) back to the tree
+#
+proc _tree_update_tree {treeref varname code} {
+	upvar $varname t
+
+	# Get the tree value
+	set t [getref $treeref]
+
+	# Possibly modify it
+	uplevel 1 $code
+
+	# And update the reference
+	setref $treeref $t
+}