I wrote the following package because I needed to make some enhancements to tcllib's struct::tree for a project I'm working on. This package (Tree) creates two new classes (Node,Tree) using TclOO.
AK: What where the enhancements you needed ?
tjk: The primary change is to the serialization/deserialization commands. The new pair allows you to serialize a subtree and then deserialize the stream on an arbitrary leaf node. The documentation below provides more details.
Documentation for the Tree class is very similar to that for
::struct::tree since it is a reimplmentation. 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
implmentation.
The following section itemizes each of the ::struct::tree
commands and describes any changes in the equivelent Tree class
method. The current version of the code is missing
implementations for the walk and walkproc commands.
Tree class and methods
==================================
The following information documents the mapping from the
::struct::tree implmentation to the Tree class. In the text below
each ::struct::tree command is preceded by '>> ' and then
followed by the equivelent Tree method.
NOTE: The ::struct::tree did not allow node name that contained
whitespace or colons (":"), the Tree class implementation
doesn't have this restriction.
>> ::struct::tree ?treeName? ?=|:=|as|deserialize source?
>> treeName option ?arg arg ...?
>> ::struct::tree::prune
>> treeName = sourcetree
>> treeName --> desttree
set treeName [Tree new]
The returned Tree instance doesn't have a name. The
deserialize method is used if a tree needs to be initialized
from a serialization.
>> treeName ancestors node
${treeName} ancestors node
>> treeName append node key value
${treeName} key.append node key value
>> treeName attr key
>> treeName attr key -nodes list
>> treeName attr key -glob globpattern
>> treeName attr key -regexp repattern
${treeName} key.nodes
${treeName} key.nodes key -nodes list
${treeName} key.nodes key -glob globpattern
${treeName} key.nodes key -regexp repattern
>> treeName children ?-all? node ?filter cmdprefix?
${treeName} children node
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 availible for node
introspection.
>> treeName deserialize serialization
${treeName} deserialize node serialization ?-force?
The deserialize command was changed to support leaf extention
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
${treeName} exists ?node ...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 get node key
${treeName} key.get node key
>> treeName getall node ?pattern?
${treeName} key.getall node ?pattern?
>> 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 keyexists node key
${treeName} key.exists node key
>> 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 lappend node key value
${treeName} key.lappend node key value
>> treeName leaves
${treeName} key.lappend node key value
>> 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 recursivly 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 set node key ?value?
${treeName} key.set node key ?value?
>> 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 unset node key
${treeName} key.unset node key
>> treeName walk node ?-order order? ?-type type? loopvar script
* NOT YET IMPLEMENTED
>> treeName walkproc node ?-order order? ?-type type? cmdprefix
* NOT YET IMPLEMENTED
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 attributeds. This class supports the
following methods.
${node} parent
${node} children
${node} insert index ?node ...node?
${node} attrs ?new? ?-force?
${node} attrs.filter ?globpat?
${node} attr.keys ?globpat?
${node} attr.set attr value
${node} attr.unset attr
${node} attr.exists attr
${node} attr.get attr
${node} attr.append attr value
${node} attr.lappend attr value
package provide Tree 0.1
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
}
}