I wrote the following package (Tree) because I needed to make some
enhancements to [tcllib]'s '''struct::tree''' [http://tcllib.sourceforge.net/doc/struct_tree.html] for a project I'm working
on. This package contains two classes (Node,Tree) that are implemented using [TclOO]. One of the
advantages of this implementation is that at Tcl 8.6 and later you can use this code directly instead of
trying to figure out how to load tcllib or the pieces needed for the struct::tree command.

[AK]: What where the enhancements you needed ?

[tjk]: The primary enhancement I needed was to the serialize/deserialize commands. The new
command pair allows you to serialize a subtree and then deserialize the stream on an
arbitrary leaf node. I was also looking for a good excuse to learn TclOO and I felt that an
implementation of a Tree using TclOO makes a lot more sense than its current implementation
using namespaces. The documentation below provides more details on other changes I made to
the API.

----

**DOCUMENTATION**

======
Documentation for the Tree class is very similar to that for
::struct::tree since it is a reimplementation. However, the API to
the Tree class is some what different because of API differences
between TclOO and the namespace command. The API is also
different because some enhance were added to the Tree class
implementation.

The following section itemizes each of the ::struct::tree
commands and describes any changes in the equivalent Tree class
method.

The following information documents the mapping from Tree class
methods to the ::struct::tree  commands. In the text below
::struct::tree command is preceded by '>>'.

The Tree class
==================================

set treeName [Tree new]

   >> ::struct::tree ?treeName? ?=|:=|as|deserialize source?
   >> treeName option ?arg arg ...?
   >> treeName = sourcetree
   >> treeName --> desttree

   The returned value from 'Tree new' is an instance of the Tree
   class. The instance does not have a name and the new method
   doesn't accept any initialization options. The short hands for
   tree initialization for a serialization are not available. Use
   the serialize/deserialize methods directly to achieve the same
   result.

Tree class and methods
==================================

NOTE: The ::struct::tree implementation does not allow node names
   that contained whitespace or colons (":"), the Tree class
   implementation doesn't have this restriction.

${treeName} ancestors node

   >> treeName ancestors node

${treeName} children node

   >> treeName children ?-all? node ?filter cmdprefix?

   The '-all' option and 'filter' have been deprecated  in the
   current implementation of ::struct::tree and are available
   through the descendants command.

${treeName} cut node

   >> treeName cut node

${treeName} delete node ?node ...?

   >> treeName delete node ?node ...?

${treeName} depth node

   >> treeName depth node

${treeName} descendants node ?-filter cmdprefix?

   >> treeName descendants node ?filter cmdprefix?

   The command interface to the descendants method is the
   same as its ::struct::tree counterpart but the interface
   to the 'cmdprefix' is different. When the cmdprefix is
   called by the Tree class method it is passed the following
   arguments on its command line.

   1) the Tree instance that generated the call
   2) the name of a descendant node
   3) the Node instance associated with (2)

   These arguments can then be used in the filter procedure to
   perform introspection on the node being filtered or the tree
   that generated the filter call. See the description of the
   Node class (below) for a list of methods available for node
   introspection.

${treeName} deserialize node serialization ?-force?

  >> treeName deserialize serialization

   The deserialize command was changed to support leaf extension
   as well as tree replacement. The form of the serialization
   isn't compatible with the ::struct::tree (see serialize below).
   The node argument is the leaf node that will be extended by
   the serialization. An error will be thrown if node isn't a leaf
   node. The -force option causes node to be truncated to a leaf
   prior to the deserialize processing.

   To duplicate the old deserialize behavior, use the following
   command.

   ${treeName} deserialize [${treeName} rootname] ${serialization} -force

   The name of the root node in the serialization stream is
   replaced by the name of the leaf node in the deserialization
   command.

${treeName} destroy

   >> treeName destroy

${treeName} exists ?node ...node?

   >> treeName exists node

   The new form accepts more than one node and return the first
   node it finds that doesn't exist, else a blank string.

${treeName} index node

   >> treeName index node

${treeName} insert parent index ?child ?child ...??

   >> treeName insert parent index ?child ?child ...??

${treeName} isleaf node

   >> treeName isleaf node

${treeName} keys ?node? ?pattern?

   >> treeName keys node ?pattern?

   The new form will return all keys in the tree if but the node
   and pattern are missing. To filter the list of all keys, set
   the node to a blank string and define a pattern.

${treeName} key.append node key value

   >> treeName append node key value

${treeName} key.exists node key

   >> treeName keyexists node key

${treeName} key.get node key

   >> treeName get node key

${treeName} key.getall node ?pattern?

   >> treeName getall node ?pattern?

${treeName} key.lappend node key value

   >> treeName lappend node key value

${treeName} key.lappend node key value

   >> treeName leaves

${treeName} key.nodes
${treeName} key.nodes key -nodes list
${treeName} key.nodes key -glob globpattern
${treeName} key.nodes key -regexp repattern

   >> treeName attr key
   >> treeName attr key -nodes list
   >> treeName attr key -glob globpattern
   >> treeName attr key -regexp repattern

${treeName} key.set node key ?value?

   >> treeName set node key ?value?

${treeName} key.unset node key

   >> treeName unset node key

${treeName} move parent index node ?node ...?

   >> treeName move parent index node ?node ...?

${treeName} next node

   >> treeName next node

${treeName} numchildren node

   >> treeName numchildren node

${treeName} nodes

   >> treeName nodes

${treeName} parent node

   >> treeName parent node

${treeName} previous node

   >> treeName previous node

${treeName} rename node newname

   >> treeName rename node newname

${treeName} rootname

   >> treeName rootname

${treeName} serialize ?node?

   >> treeName serialize ?node?

   The serialize method doesn't produce a serialization that is
   compatible with the ::struct::tree serialize command. The
   result returned from the method is a three element list. The
   elements in the list are (1) a node name (2) an attribute
   dictionary for the node (3) a multiple of additional 3 element
   lists that recursively serialize the children of the node.

   The serialization directly encodes the tree structure so the
   first node name is the root of the tree. Since node names are
   only used once name referencing isn't required.

${treeName} size ?node?

   >> treeName size ?node?

${treeName} splice parent from ?to? ?child?

   >> treeName splice parent from ?to? ?child?

${treeName} swap node1 node2

   >> treeName swap node1 node2

${treeName} walkproc node cmdprefix ?-order order? ?-type type?

  >> treeName walkproc node ?-order order? ?-type type? cmdprefix

  Only the walkproc method has been implimented since it is functionally
  equivelent to the walk method. Note that the command line options
  have been moved after the  cmdprefix.

* NOT YET IMPLEMENTED

   >> ::struct::tree::prune
   >> treeName walk node ?-order order? ?-type type? loopvar script
 
Tree debugging methods
==================================

The following methods were added to help with debug the Tree class.
The node name/node instance relationship is kept in an index. This
commands allow you to see what Node class instance is associated with
a node name.

${treeName} ptree ?name?

   Pretty print the name structure of a tree. If a node name is
   provided then just the subtree starting at node is printed.

${treeName} pnodes

   Pretty print the instances of the Node class in a tree.

${treeName} pkeys ?name ..name?

   Pretty print the attribute key information for one or more
   node names. If no names are given then all nodes are printed.

${treeName} pstream stream

   Pretty print the contents of a stream produced by the
   serialize method.

The Node class and methods
==================================

The Node class is a simple class that contains a parent, a list
of children and a set of attributes. This class supports the
following methods.

${node} parent ?pnode?

  If 'pnode' isn't blank, set the node's parent to its value;
  return the current parent.

${node} children ?clist? ?-force?

  If 'clist' isn't blank, set the node's children to its value;
  return the current children list. Use the -force option to set
  the children to a blank list.

${node} insert index ?node ...node?

  Insert a list of node instances ('args') into the list of
  children at location 'index'.

${node} attrs ?kdict? ?-force?

  If 'kdict' isn't blank set the node attributes to its value;
  return the current value of attributes. Use the -force option
  to set the attribute list to blank.

${node} attrs.filter ?globpat?

  Return the node's attributes as a dict of key/value pairs. If
  globpat exists, only keys that match the glob pattern will be
  returned.

${node} attr.keys ?globpat?

  Return the node's attribute keys as a list. If globpat exists,
  only return keys that match the glob pattern.

${node} attr.set key value

  Set the value of the attribute 'key' to 'value'. If 'key
  doesn't exist add it to the node.

${node} attr.unset key

  Unset the attribute 'key' of node.

${node} attr.exists key

  Return true of attribute 'key' exists for node else return false.

${node} attr.get key

  Return the value of the attribute 'key' for node.

${node} attr.append key value

  Do a string append of 'value' to the value of attribute 'key' for
  node. Return the resulting string value.

${node} attr.lappend key value

  Do a list append of 'value' to the value of attribute 'key' for
  node. Return the resulting list value.


======


----

**IMPLEMENTATION**

======
package provide Tree 0.1

package require Tcl 8.6

package require TclOO

# --
# Debugging method for TclOO object instance.
oo::define oo::object method debug {{pat *}} {
    set res [list class [info object class [self]]]
    foreach i [info object vars [self] $pat] {
        my variable $i
        lappend res $i [set $i]
    }
    set res
}

##### NODE ##############################################################

# --
# parent   - contains the parent node instance
# children - contains list of child node instances
# attrs    - a dictionary of attribute/value pairs
oo::class create Node {

    # --
    # create a named node
    constructor { pnode } {
        my variable parent
        my variable children
        my variable attrs

        set parent ${pnode}
        set children {}
        set attrs [dict create]
    }

    # --
    # If 'inst' isn't blank, set the node's parent to its
    # value; return the current parent.
    method parent { {inst ""} } {
        my variable parent
        if { ${inst} ne "" } {
            set parent ${inst}
        }
        return ${parent}
    }

    # --
    # If 'new' isn't blank, set the node's children to its
    # value; return the current childern list.
    method children { {new ""} {force ""} } {
        my variable children
        if { [llength ${new}] != 0 || ${force} eq "-force" } {
            set children ${new}
        }
        return ${children}
    }

    # --
    # Insert a list of node instances ('args') into the
    # child list at location 'index'.
    method insert { index args } {
        my variable children
        set children [linsert ${children} ${index} {*}${args}]
        return
    }

    # --
    # If 'new' isn't blank set the node attributes to its
    # value; return the current value of attributes.
    method attrs { {new ""} {force ""} } {
        my variable attrs
        if { ${new} ne "" || ${force} eq "-force" } {
            set attrs ${new}
        }
        return ${attrs}
    }

    method attrs.filter { {globpat ""} } {
        my variable attrs
        if { ${globpat} eq "" } {
            return ${attrs}
        } else {
            return [dict filter ${attrs} key ${globpat}]
        }
    }

    method attr.keys { {globpat ""} } {
        my variable attrs
        if { ${globpat} eq "" } {
            return [dict keys ${attrs}]
        } else {
            return [dict keys ${attrs} ${globpat}]
        }
    }

    method attr.set { attr value } {
        my variable attrs
        dict set attrs ${attr} ${value}
        return ${value}
    }

    method attr.unset { attr } {
        my variable attrs
        dict unset attrs ${attr}
        return
    }

    method attr.exists { attr } {
        my variable attrs
        return [dict exist ${attrs} ${attr}]
    }

    method attr.get { attr } {
        my variable attrs
        if { [dict exist ${attrs} ${attr}] } {
            return [dict get ${attrs} ${attr}]
        }
        error "attribute '${attr}' - not found"
    }

    method attr.append { attr value } {
        my variable attrs
        dict append attrs ${attr} ${value}
        return
    }

    method attr.lappend { attr value } {
        my variable attrs
        dict lappend attrs ${attr} ${value}
        return
    }
}


##### TREE ##############################################################

# --
#
# nid   - integer value used to create unique node names
# root  - name of tree's root node
# nodes - index of node names and node instances
#
oo::class create Tree {

   self export varname

    constructor { } {
        my variable root
        my variable nodes

        my eval upvar [[self class] varname nid] nid
        set nid 0
        set root "root"
        set nodes [dict create "root" [Node new ""]]
    }

    destructor {
        variable nodes
        dict for {name node} ${nodes} {
            ${node} destroy
        }
    }

    ##### PRIVITE ##############################

    # --
    # used by debugging utility
    method DumpSubtree { parent {indent 0} } {
        set pnode [my Name2Node ${parent}]
        puts "[format "%-12s" ${pnode}]- [string repeat {  } ${indent}]${parent}"
        incr indent
        foreach child [${pnode} children] {
            my DumpSubtree [my Node2Name ${child}] ${indent}
        }
    }

    # --
    # check args for a node that exists and return its name
    # else return ""
    method NotUsed { args } {
        my variable nodes
        foreach name ${args} {
            if { [dict exists ${nodes} ${name}] } {
                return ${name}
            }
        }
        return ""
    }

    # --
    # return a node instance given a node name
    method Name2Node { name } {
        my variable nodes
        return [dict get ${nodes} ${name}]
    }

    # --
    # return a node name given a node instance
    method Node2Name { node } {
        my variable nodes
        dict for {name node} [dict filter ${nodes} value ${node}] {
            return ${name}
        }
        error "node (${node}) - not found"
    }

    # --
    # return a list of node instances given a list of node names
    method Names2NodeList { args } {
        set nlist {}
        foreach name ${args} {
            lappend nlist [my Name2Node ${name}]
        }
        return ${nlist}
    }

    # --
    # return a list of node names given a list of node instances
    method Nodes2NameList { args } {
        set nlist {}
        foreach node ${args} {
            lappend nlist [my Node2Name ${node}]
        }
        return ${nlist}
    }

    # --
    # return the list of all nodes below parent node
    # optionaly filter nodes useing procedure 'filter'
    method GetSubtree { parent {filter ""} } {
        my variable nodes
        set pnode [my Name2Node ${parent}]
        set children [my Nodes2NameList {*}[${pnode} children]]
        set subtree ""
        foreach child ${children}  {
            if { ${filter} eq "" || [eval [list ${filter} [self object] ${child} [dict get ${nodes} ${child}]]] == 0 } {
                lappend subtree ${child}
                lappend subtree {*}[my GetSubtree ${child} ${filter}]
            }
        }
        return ${subtree}
    }

    # --
    # completely delete one node
    method DeleteNode { name } {
        my variable root
        my variable nodes
        set node [my Name2Node ${name}]
        # delete node from index
        set nodes [dict remove ${nodes} ${name}]
        # create a new root node if it was deleted
        if { ${name} eq ${root} } {
            dict set nodes ${name} [Node new ""]
        }
        ${node} destroy
    }

    # --
    # replace the child entry for 'name' in its parent
    # with 0 or more new children
    method ReplaceParentLink { name args } {
        set cnode [my Name2Node ${name}]
        set pnode [${cnode} parent]
        if { ${pnode} eq "" } { return }
        set children [${pnode} children]
        set idx [lsearch -exact ${children} ${cnode}]
        if { ${idx} < 0 } {
            error "node (${name}) - not found"
        }
        if { [llength ${args}] == 0 } {
            set children [lreplace ${children} ${idx} ${idx}]
        } else {
            set nlist [my Names2NodeList {*}${args}]
            set children [lreplace ${children} ${idx} ${idx} {*}${nlist}]
        }
        ${pnode} children ${children} -force
    }

    # --
    # Serialize a node and add it to stream.
    #
    # The result is a 3 element list haveing the following entries.
    #
    # 1) node name
    # 2) the node's attributes in dictionary form
    # 3) a recursive serialization of all children of the node
    #
    method SerializeNode { stream name {isroot 0}} {
        my variable root
        my variable nodes
        # serialize the children
        set children {}
        foreach child [my children ${name}] {
            lappend children {*}[my SerializeNode ${stream} ${child}]
        }
        set node [my Name2Node ${name}]
        lappend stream ${name} [${node} attrs.filter] ${children}
        return ${stream}
    }

    # --
    # Unlink a list of nodes from their parents. Note that a node
    # may be in the subtree of a node that is being unlinked.
    method UnlinkNodes { args } {
        set notfound [my exists {*}${args}]
        if { ${notfound} ne ""  } {
            error "node (${notfound}) - not found"
        }
        # Break the links to the parents
        foreach name ${args} {
            my ReplaceParentLink ${name}
            set pnode [my Name2Node ${name}]
            ${pnode} parent ""
        }
    }

    # -- Pstream
    # Pretty print a node from a serialization stream.
    method Pstream { name attrs children indent } {
        set pad [string repeat "  " ${indent}]
        puts "${pad}${name}"
        puts "${pad}  ${attrs}"
        incr indent
        foreach {n a c} ${children} {
            my Pstream ${n} ${a} ${c} ${indent}
        }
    }

    # --
    #
    method DeserializeNode { name pnode attrs children } {
        my variable nodes
        # create the a node and set it's parent
        set node [Node new ${pnode}]
        # add the node to the index
        dict set nodes ${name} ${node}
        # set the node's attributes
        ${node} attrs ${attrs}
        # create all the children for the node
        set cnodes {}
        foreach {n a c} ${children} {
            lappend cnodes [my DeserializeNode ${n} ${node} ${a} ${c}]
        }
        ${node} children ${cnodes} -force
        return ${node}
    }

    ##### PUBLIC ##############################

    # -- ptree
    # debugging utility
    method ptree { {name ""} } {
        my variable root
        if { ${name} eq "" } {
            my DumpSubtree ${root}
        } else {
            if { [my exists ${name}] ne ""  } {
                error "node (${name}) - not found"
            }
            my DumpSubtree ${name}
        }
    }

    # -- pnodes
    # debugging utility
    method pnodes { } {
        my variable nodes
        foreach name [lsort -dictionary [dict keys ${nodes}]] {
            set node [dict get ${nodes} ${name}]
            set pnode [${node} parent]
            set children [my children ${name}]
            puts [format "(%-12s) %-12s %s -> %s" ${pnode} ${node} ${name} [join ${children} {, }]]
        }
    }

    # -- pkeys
    # debugging utility
    method pkeys { args } {
        if { [llength ${args}] == 0 } {
            set args [my nodes]
        } else {
            set notfound [my exists {*}${args}]
            if { ${notfound} ne ""  } {
                error "node (${notfound}) - not found"
            }
        }
        foreach name ${args} {
            set node [my Name2Node ${name}]
            puts "node(${name})"
            set width 0
            foreach key  [${node} attr.keys] {
                set len [string length ${key}]
                if { ${len} > ${width} } { set width ${len} }
            }
            foreach {key val} [${node} attrs.filter] {
                puts "  [format "%-${width}s" ${key}]: '${val}'"
            }
        }
    }

    # -- pstream
    # debugging utility
    method pstream { stream } {
        lassign ${stream} name attrs children
        my Pstream ${name} ${attrs} ${children} 0
    }

    # --
    #
    method ancestors { child } {
        if { [my exists ${child}] ne ""  } {
            error "node (${child}) - not found"
        }
        set ancestors {}
        while { true } {
            set ancestor [my parent ${child}]
            if { ${ancestor} eq ""  } {
                break
            } else {
                lappend ancestors ${ancestor}
                set child ${ancestor}
            }
        }
        return ${ancestors}
    }

    # --
    #
    method children { parent } {
        my variable nodes
        if { [my exists ${parent}] ne ""  } {
            error "node (${parent}) - not found"
        }
        set pnode [my Name2Node ${parent}]
        set children [${pnode} children]
        return [my Nodes2NameList {*}${children}]
    }

    # --
    # Remove a node from the tree and move its
    # children into the parent. Ignore cut on
    # the root node.
    method cut { name {opt ""} } {
        my variable nodes
        if { ${name} eq [my rootname] } { return }
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        # get the children for the node
        set children [my children ${name}]
        # replace the node with its childer in the parent
        my ReplaceParentLink ${name} {*}${children}
        if { ${opt} eq "-delete" } {
            # delete the node
            set node [my Name2Node ${name}]
            dict unset nodes ${name}
            ${node} destroy
        }
        return
    }

    # --
    #
    method delete { args } {
        set notfound [my exists {*}${args}]
        if { ${notfound} ne ""  } {
            error "node (${notfound}) - not found"
        }
        # Remove all the subtree nodes.
        # This code accounts for the possibility that
        # one of the args is in the subtree of another arg.
        set names {}
        foreach name ${args} {
            lappend names {*}[my descendants ${name}]
        }
        foreach name [lsort -unique ${names}] {
            my DeleteNode ${name}
        }
        # Now remove the nodes themselves and their child
        # entry in their parent
        foreach name ${args} {
            my ReplaceParentLink ${name}
            my DeleteNode ${name}
        }
        return
    }

    # --
    #
    method depth { name } {
        return [llength [my ancestors ${name}]]
    }

    # --
    #
    method descendants { parent {opt ""} {arg ""} } {
        my variable nodes
        if { [my exists ${parent}] ne ""  } {
            error "node (${parent}) - not found"
        }
        if { ${opt} eq "-filter" } {
            set filter ${arg}
            return [my GetSubtree ${parent} ${filter}]
        } else {
            return [my GetSubtree ${parent}]
        }
    }

    # --
    # Replace the attribute and subtree definitions of node
    # 'lname' with the definitions found in 'stream'. The 'lname'
    # node must be a leaf node unless the '-force' option is is
    # used.
    method deserialize { lname stream {opt ""}} {
        my variable root
        my variable nodes
        if { [my exists ${lname}] ne "" } {
            error "node (${lname}) - not found"
        }
        if { opt eq "-force" } {
            # force lname to be a leaf
            set parent [my parent ${lname}
            my delete ${lname}
            set node [Node new [my Name2Node ${parent}]]
            dict set nodes ${lname} ${node}
        }
        if { ![my isleaf ${lname}] } {
            error "node (${lname}) - is not a leaf node"
        }
        # get the leaf node
        set lnode [my Name2Node ${lname}]
        # get the root of the serialization
        lassign ${stream} rname attrs children
        # put attributes in the leaf node
        ${lnode} attrs ${attrs}
        # deserialize all the children into the leaf node
        set cnodes {}
        foreach {n a c} ${children} {
            lappend cnodes [my DeserializeNode ${n} ${lnode} ${a} ${c}]
        }
        ${lnode} children ${cnodes} -force
        return
    }

    # --
    # return "" if all exist else return name that isn't found
    method exists { args } {
        my variable nodes
        foreach name ${args} {
            if { ![dict exists ${nodes} ${name}] } {
                return ${name}
            }
        }
        return ""
    }

    # --
    #
    method index { name } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set cnode [my Name2Node ${name}]
        set pnode [${cnode} parent]
        set children [${pnode} children]
        return [lsearch -exact ${children} ${cnode}]
    }

    # --
    #
    method insert { parent index args } {
        my variable nid
        my variable nodes
        if { [llength ${args}] == 0 } {
            incr nid
            set args "node${nid}"
        } else {
            if { ${parent} in ${args} } {
                error "parent (${parent}) - found in insert list"
            }
        }
        set pnode [my Name2Node ${parent}]
        set nlist ""
        foreach name ${args} {
            if { [my exists ${name}] ne ""  } {
                # create a new child that references the parent
                set node [Node new ${pnode}]
                # add the node to the index
                dict set nodes ${name} ${node}
            } else {
                # child already exists so it must be cut from its
                # current location
                my UnlinkNodes ${name}
                set node [my Name2Node ${name}]
                ${node} parent ${pnode}
            }
            lappend nlist ${node}
        }
        # insert the list of child nodes into the
        # parent's list of children
        if { [llength ${nlist}] > 0 } {
            ${pnode} insert ${index} {*}${nlist}
        }
        return ${args}
    }

    # --
    #
    method isleaf { name } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set node [my Name2Node ${name}]
        return [expr ( [llength [${node} children]] > 0 ) ? 0 : 1]
    }

    # --
    #
    method keys { {name ""} {gpat ""} } {
        if { ${name} eq "" } {
            set nlist [my nodes]
        } else {
            set nlist ${name}
        }
        set result {}
        foreach name ${nlist} {
            set node [my Name2Node ${name}]
            if { ${gpat} eq "" } {
                lappend result {*}[${node} attr.keys]
            } else {
                set d [dict create {*}[${node} attrs.filter ${gpat}]]
                lappend result {*}[dict keys ${d}]
            }
        }
        return [lsort -unique ${result}]
    }

    # --
    #
    method key.append { name key value } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set node [my Name2Node ${name}]
        ${node} attr.append ${key} ${value}
        return
    }

    # --
    #
    method key.exists { name key } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set node [my Name2Node ${name}]
        return [${node} attr.exists ${key}]
    }

    # --
    #
    method key.get { name key } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set node [my Name2Node ${name}]
        return [${node} attr.get ${key}]
    }

    # --
    #
    method key.getall { name {globpat ""} } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set node [my Name2Node ${name}]
        return [${node} attrs.filter ${globpat}]
    }

    # --
    #
    method key.lappend { name key value } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set node [my Name2Node ${name}]
        ${node} attr.lappend ${key} ${value}
        return [${node} attr.get ${key}]
    }

    # --
    #
    method key.nodes { key {flag ""} {arg ""} } {
        set result {}
        set names [my nodes]
        switch -exact ${flag} {
        "-nodes" {
            set names ${arg}
        }
        "-glob" {
            set nlist {}
            set gpat ${arg}
            foreach name ${names} {
                if { [string match ${gpat} ${name}] == 1 } {
                    lappend nlist ${name}
                }
            }
            set names ${nlist}
        }
        "-regexp" {
            set nlist {}
            set rpat ${arg}
            foreach name ${names} {
                if { [regexp ${rpat} ${name}] == 1 } {
                    lappend nlist ${name}
                }
            }
            set names ${nlist}
        }
        default {
        }}
        foreach name ${names} {
            if { [my key.exists ${name} ${key}] } {
                lappend result ${name} [my key.get ${name} ${key}]
            }
        }
        return ${result}
    }

    # --
    #
    method key.set { name key args } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set node [my Name2Node ${name}]
        if { [llength ${args}] == 1 } {
            ${node} attr.set ${key} [lindex ${args} 0]
        }
        return [${node} attr.get ${key}]
    }


    # --
    #
    method key.unset { name key } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set node [my Name2Node ${name}]
        ${node} attr.unset ${key}
    }
    # --
    #
    method leaves { } {
        set leaves {}
        foreach name [my nodes] {
            if { [my isleaf ${name}] == 1 } {
                lappend leaves ${name}
            }
        }
        return ${leaves}
    }

    # --
    #
    method move { parent index args } {
        set pnode [my Name2Node ${parent}]
        # Make sure the list of nodes doesn't contain an
        # ancestor of the parent. If this were allowed the
        # subtree would become disconnected.
        set alist [my ancestors ${parent}]
        foreach name ${args} {
            if { [my exists ${name}] ne ""  } {
                error "node (${name}) - not found"
            }
            if { ${name} in ${alist} } {
                error "node (${name}) is an ancestor of node (${parent})"
            }
        }
        # unlink the nodes
        set nlist {}
        foreach name ${args} {
            my UnlinkNodes ${name}
            set node [my Name2Node ${name}]
            ${node} parent ${pnode}
            lappend nlist ${node}
        }
        # link the nodes into the parent at location 'index'
        set children [${pnode} children]
        ${pnode} children [linsert ${children} ${index} {*}${nlist}]
        return
    }

    # --
    #
    method next { name } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set cnode [my Name2Node ${name}]
        set pnode [${cnode} parent]
        set children [${pnode} children]
        set idx [lsearch -exact ${children} ${cnode}]
        incr idx
        if { ${idx} < [llength ${children}] } {
            return [my Node2Name [lindex ${children} ${idx}]]
        } else {
            return ""
        }
    }

    # --
    #
    method numchildren { name } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set node [my Name2Node ${name}]
        return [llength [${node} children]]
    }

    # --
    #
    method nodes { } {
        my variable nodes
        return [dict keys ${nodes}]
    }

    # --
    #
    method parent { child } {
        my variable nodes
        if { [my exists ${child}] ne ""  } {
            error "node (${child}) - not found"
        }
        set cnode [my Name2Node ${child}]
        set pnode [${cnode} parent]
        if { ${pnode} eq "" } {
            return ""
        } else {
            return [my Node2Name ${pnode}]
        }
    }

    # --
    #
    method previous { name } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set cnode [my Name2Node ${name}]
        set pnode [${cnode} parent]
        set children [${pnode} children]
        set idx [lsearch -exact ${children} ${cnode}]
        incr idx -1
        if { ${idx} >= 0 } {
            return [my Node2Name [lindex ${children} ${idx}]]
        } else {
            return ""
        }
    }

    # --
    #
    method rename { from to } {
        my variable root
        my variable nodes
        if { ![dict exists ${nodes} ${from}] } {
            error "node (${to}) - not found"
        }
        if { [dict exists ${nodes} ${to}] } {
            error "node (${to}) - already exists"
        }
        set node [dict get ${nodes} ${from}]
        set nodes [dict remove ${nodes} ${from}]
        dict set nodes ${to} ${node}
        if { ${from} eq ${root} } {
            set root ${to}
        }
        return
    }

    # --
    #
    method rootname { } {
        my variable root
        return ${root}
    }

    # --
    # Return a serialization of the subtree starting at 'name'.
    #
    # The result is a list containing three element. The elements
    # are (1) a node name (2) the node's attributes in dictionary
    # form (3) zero or more additional three element lists that
    # recursivly serialize the children of the node.
    #
    method serialize { name } {
        my variable root
        my variable nodes
        if { ${name} ne "root" && [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        # create the null node
        set stream {}
        set stream [my SerializeNode ${stream} ${name} 1]
        return ${stream}
    }

    # --
    #
    method size { {name ""} } {
        if { ${name} eq "" } {
            set name [my rootname]
        } else {
            if { [my exists ${name}] ne ""  } {
                error "node (${name}) - not found"
            }
        }
        return [llength [my descendants ${name}]]

    }

    # --
    #
    method splice { parent from {to ""} {child ""} } {
        my variable nid
        my variable nodes
        if { ${parent} eq "root" } {
            set parent [my rootname]
        } else {
            if { [my exists ${parent}] ne ""  } {
                error "node (${parent}) - not found"
            }
        }
        if { ${to} eq "" } {
            set to "end"
        }
        if { ${child} eq "" } {
            incr nid
            set child "node${nid}"
        } else {
            if { [my NotUsed ${child}] ne ""  } {
                error "node (${child}) - already exists"
            }
        }
        # get the parent information
        set pnode [my Name2Node ${parent}]
        # create the new child
        set node [Node new ${pnode}]
        # add the node to the index
        dict set nodes ${child} ${node}
        # get the parents children
        set children [${pnode} children]
        # put the range of childern in the new node
        ${node} children [lrange ${children} ${from} ${to}] -force
        # remove the range of children from the parent and insert the new node
        ${pnode} children [lreplace ${children} ${from} ${to} ${node}] -force
        return ${child}
    }

    # --
    #
    method swap { name1 name2 } {
        if { ${name1} eq ${name2} } { return }
        # make sure the nodes exist
        if { [my exists ${name1}] ne ""  } {
            error "node (${name1}) - not found"
        }
        if { [my exists ${name2}] ne ""  } {
            error "node (${name2}) - not found"
        }
        # make sure one node isn't in the the other node's subtree
        # (this also precludes a swap with 'root')
        set node1 [my Name2Node ${name1}]
        set node2 [my Name2Node ${name2}]
        if { [lsearch -exact [my descendants ${name1}] ${name2}] != -1 } {
            error "node (${name2}) in subtree of node (${name1})"
        }
        if { [lsearch -exact [my descendants ${name2}] ${name1}] != -1 } {
            error "node (${name1}) in subtree of node (${name2})"
        }
        # check to see if the nodes have a common parent
        set pnode1 [${node1} parent]
        set pnode2 [${node2} parent]
        if { ${pnode1} eq ${pnode2} } {
            # nodes have a common parent node
            set children [${pnode1} children]
            set idx1 [lsearch -exact ${children} ${node1}]
            set idx2 [lsearch -exact ${children} ${node2}]
            set children [lreplace ${children} ${idx1} ${idx1} ${node2}]
            set children [lreplace ${children} ${idx2} ${idx2} ${node1}]
            ${pnode1} children ${children} -force
        } else {
            # nodes have different parent nodes
            set children1 [${pnode1} children]
            set children2 [${pnode2} children]
            set idx1 [lsearch -exact ${children1} ${node1}]
            set idx2 [lsearch -exact ${children2} ${node2}]
            set children1 [lreplace ${children1} ${idx1} ${idx1} ${node2}]
            set children2 [lreplace ${children2} ${idx2} ${idx2} ${node1}]
            ${pnode1} children ${children1} -force
            ${pnode2} children ${children2} -force
            ${node1} parent ${pnode2}
            ${node2} parent ${pnode1}
        }
        return
    }

    ##### WALKPROC CODE (DEPTH FIRST) ############################

    # --
    #
    method DfsPreOrderWalk { name cmdprefix } {
        my variable nodes
        if { [catch {${cmdprefix} [self object] ${name} "enter"} bool] || ${bool} != 0 } {
            #puts "bool: $bool"
            # shutdown the walk
            return 1
        }
        set node [my Name2Node ${name}]
        for {set idx 0} { true } {incr idx} {
            set children [my children ${name}]
            if { ${idx} >= [llength ${children}] } {
                break
            }
            set child [lindex [my children ${name}] ${idx}]
            if { [my PreOrderWalk ${child} ${cmdprefix}] != 0 } {
                return 1
            }
        }
        return 0
    }

    # --
    #
    method DfsPostOrderWalk { name cmdprefix } {
        my variable nodes
        my variable nodes
        set node [my Name2Node ${name}]
        for {set idx 0} { true } {incr idx} {
            set children [my children ${name}]
            if { ${idx} >= [llength ${children}] } {
                break
            }
            set child [lindex [my children ${name}] ${idx}]
            if { [my PostOrderWalk ${child} ${cmdprefix}] != 0 } {
                return 1
            }
        }
        if { [catch {${cmdprefix} [self object] ${name} "leave"} bool] || ${bool} != 0 } {
            #puts "bool: $bool"
            # shutdown the walk
            return 1
        }
        return 0
    }

    # --
    #
    method DfsBothOrderWalk { name cmdprefix } {
        my variable nodes
        if { [catch {${cmdprefix} [self object] ${name} "enter"} bool] || ${bool} != 0 } {
            #puts "bool: $bool"
            # shutdown the walk
            return 1
        }
        set node [my Name2Node ${name}]
        for {set idx 0} { true } {incr idx} {
            set children [my children ${name}]
            if { ${idx} >= [llength ${children}] } {
                break
            }
            set child [lindex [my children ${name}] ${idx}]
            if { [my BothOrderWalk ${child} ${cmdprefix}] != 0 } {
                return 1
            }
        }
        if { [catch {${cmdprefix} [self object] ${name} "leave"} bool] || ${bool} != 0 } {
            #puts "bool: $bool"
            # shutdown the walk
            return 1
        }
        return 0
    }

    # --
    #
    method DfsInOrderWalk { name cmdprefix } {
        my variable nodes
        set node [my Name2Node ${name}]
        for {set idx 0} { true } {incr idx} {
            if { ${idx} == 1 } {
                if { [catch {${cmdprefix} [self object] ${name} "visit"} bool] || ${bool} != 0 } {
                    #puts "bool: $bool"
                    # shutdown the walk
                    return 1
                }
            }
            set children [my children ${name}]
            if { ${idx} >= [llength ${children}] } {
                break
            }
            set child [lindex [my children ${name}] ${idx}]
            if { [my InOrderWalk ${child} ${cmdprefix}] != 0 } {
                return 1
            }
        }
        if { ${idx} == 0 } {
            if { [catch {${cmdprefix} [self object] ${name} "visit"} bool] || ${bool} != 0 } {
                #puts "bool: $bool"
                # shutdown the walk
                return 1
            }
        }
        return 0
    }

    ##### WALKPROC CODE (BREADTH FIRST) ############################

    # --
    # This method takes as input a list of nodes (nlist) and returns
    # a new list that is the list of all children for the input list.
    method DecendOneLevelForward { nlist } {
        set result {}
        foreach node ${nlist} {
            lappend result {*}[${node} children]
        }
        return ${result}
    }
    # --
    # This method takes as input a list of nodes (nlist) and returns
    # a new list that is the list of all children for the input list.
    method DecendOneLevelBackward { nlist } {
        set result {}
        foreach node ${nlist} {
            lappend result {*}[lreverse [${node} children]]
        }
        return ${result}
    }


    # --
    #
    method BfsPreOrderWalk { nlist cmdprefix } {
        if { [llength ${nlist}] == 0 } { return 0 }
        foreach node ${nlist} {
            if { [catch {${cmdprefix} [self object] [my Node2Name ${node}] "enter"} bool] || ${bool} != 0 } {
                #puts "bool: $bool"
                # shutdown the walk
                return 1
            }
        }
        if { [my BfsPreOrderWalk [my DecendOneLevelForward ${nlist}] ${cmdprefix}] != 0 } {
            return 1
        }
        return 0
    }

    # --
    #
    method BfsPostOrderWalk { nlist cmdprefix } {
        if { [llength ${nlist}] == 0 } { return 0 }
        if { [my BfsPostOrderWalk [my DecendOneLevelBackward ${nlist}] ${cmdprefix}] != 0 } {
            return 1
        }
        foreach node ${nlist} {
            if { [catch {${cmdprefix} [self object] [my Node2Name ${node}] "leave"} bool] || ${bool} != 0 } {
                #puts "bool: $bool"
                # shutdown the walk
                return 1
            }
        }
        return 0
    }

    # --
    #
    method BfsBothOrderWalk { nlist cmdprefix } {
        if { [llength ${nlist}] == 0 } { return 0 }
        foreach node ${nlist} {
            if { [catch {${cmdprefix} [self object] [my Node2Name ${node}] "enter"} bool] || ${bool} != 0 } {
                #puts "bool: $bool"
                # shutdown the walk
                return 1
            }
        }
        my BfsBothOrderWalk [my DecendOneLevelForward ${nlist}] ${cmdprefix}
        foreach node [lreverse ${nlist}] {
            if { [catch {${cmdprefix} [self object] [my Node2Name ${node}] "leave"} bool] || ${bool} != 0 } {
                #puts "bool: $bool"
                # shutdown the walk
                return 1
            }
        }
        return 0
    }

    # --
    #
    method BfsInOrderWalk { } {
        error "unable to do a in-order breadth first walk"
    }


    # --
    #
    method walkproc { name cmdprefix args } {
        set types {bfs dfs}
        set orders {pre post both in}
        set type "dfs"
        set order "pre"
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        foreach {opt val} ${args} {
            switch -exact -- ${opt} {
            "-order" {
                if { ${val} ni ${orders} } {
                   error "-order ${val} - must be oneof: [join ${orders} {, }]"
                }
                set order ${val}
            }
            "-type" {
                if { ${val} ni ${types} } {
                   error "-type ${val} - must be oneof: [join ${types} {, }]"
                }
                set type ${val}
            }
            default {
            }}
        }

        if { ${type} eq "dfs"  } {
            switch -exact -- ${order}  {
            "post" {
                my DfsPostOrderWalk ${name} ${cmdprefix}
            }
            "both" {
                my DfsBothOrderWalk ${name} ${cmdprefix}
            }
            "in" {
                my DfsInOrderWalk ${name} ${cmdprefix}
            }
            "pre" -
            default {
                my DfsPreOrderWalk ${name} ${cmdprefix}
            }}
        } else  {
            switch -exact -- ${order}  {
            "post" {
                my BfsPostOrderWalk [my Name2Node ${name}] ${cmdprefix}
            }
            "both" {
                my BfsBothOrderWalk [my Name2Node ${name}] ${cmdprefix}
            }
            "in" {
                my BfsInOrderWalk
            }
            "pre" -
            default {
                my BfsPreOrderWalk [my Name2Node ${name}] ${cmdprefix}
            }}
        }
        return
    }
}

======



<<categories>> Category Data Structure | Category Command | Category Object Orientation