diff options
author | Steve Bennett <steveb@workware.net.au> | 2010-01-24 10:47:03 +1000 |
---|---|---|
committer | Steve Bennett <steveb@workware.net.au> | 2010-10-15 11:02:39 +1000 |
commit | e68eadfbfe66d350b9656e3a4a91f7520e2bfba4 (patch) | |
tree | 3406571bc3589966658bda6909b2515b71c7ed98 /tree.tcl | |
parent | fe81bfe03290dac465c71cd6854d3acc93b4518c (diff) | |
download | jimtcl-e68eadfbfe66d350b9656e3a4a91f7520e2bfba4.zip jimtcl-e68eadfbfe66d350b9656e3a4a91f7520e2bfba4.tar.gz jimtcl-e68eadfbfe66d350b9656e3a4a91f7520e2bfba4.tar.bz2 |
Implement tree package
Similar to tcllib ::struct::tree
------------------------------------------------------------------------
Diffstat (limited to 'tree.tcl')
-rw-r--r-- | tree.tcl | 332 |
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 +} |