package provide Tree 1.0

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 ""} } {
        my variable children
        if { [llength ${new}] != 0 } {
            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 ""} } {
        my variable attrs
        if { ${new} ne "" } {
            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 ""]]
    }

    ##### 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 { [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}
    }

    # --
    # Serialize one node.
    #
    # The result is a list of the following elements.
    #
    # 1) node name
    # 2) name of parent node
    # 3) ordered list of child names
    # 4) dictionary of attributes
    #
    method SerializeNode { array name {isroot 0} } {
        upvar ${array} AR
        my variable root
        my variable nodes
        if { ${isroot} == 1 } {
            set idx "root"
        } else {
            set idx ${name}
        }
        set node [my Name2Node ${name}]
        set children [my children ${name}]
        set AR(${idx}) [list [my parent ${name}] ${children} [${node} attrs.filter]]
        foreach child ${children} {
            my SerializeNode AR ${child}
        }
        return
    }

    # --
    # Deserialize one node.
    #
    # When this procedure is called, node has already been created
    # and the parent has been set.
    method DeserializeNode { array name {isroot 0} } {
        upvar ${array} AR
        my variable root
        if { ${isroot} == 1 } {
            # set the node to values found in subtree root
            set idx "root"
        } else {
            set idx ${name}
        }
        set node [my Name2Node ${name}]
        # unpack the serialization for the node
        lassign $AR(${idx}) parent children attrs
        # set the node attributes
        ${node} attrs ${attrs}
        # create all the child nodes
        my insert ${name} end {*}${children}
        # configure all the child nodes
        foreach child ${children} {
            my DeserializeNode AR ${child}
        }
    }

    # --
    # 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 ""
        }
    }

    ##### 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}'"
            }
        }
    }

    # --
    #
    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 args } {
        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 } {
        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}
        # 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 args } {
        my variable nodes
        if { [my exists ${parent}] ne ""  } {
            error "node (${parent}) - not found"
        }
        if { "-filter" in ${args} } {
            set filter [lindex ${args} [lsearch -exact ${args} "-filter"]+1]
            return [my GetSubtree ${parent} ${filter}]
        } else {
            return [my GetSubtree ${parent}]
        }
    }

    # --
    # Replace the attribute and subtree definitions of node 'name'
    # with the definitions found in the 'alist' serialization. The
    # 'name' node must be a leaf node an will becomes the root of
    # the serialization.
    method deserialize { name alist } {
        my variable root
        my variable nodes
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        if { ![my isleaf ${name}] } {
            error "node (${name}) - is not a leaf node"
        }
        # delete all the child nodes of 'name'
        set children [my children ${name}]
        my delete {*}${children}
        array set AR ${alist}
        my DeserializeNode AR ${name} 1
        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 nodes
        set found [my NotUsed {*}${args}]
        if { ${found} ne ""  } {
            error "node (${found}) - already used"
        }
        set pnode [my Name2Node ${parent}]
        set nlist ""
        foreach name ${args} {
            # create a new child that references the parent
            set node [Node new ${pnode}]
            # add the node to the index
            dict set nodes ${name} ${node}
            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
    }

    # --
    #
    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 { args } {
        if { [llength ${args}] == 0 } {
            set args [my nodes]
        } else {
            set notfound [my exists {*}${args}]
            if { ${notfound} ne ""  } {
                error "node (${notfound}) - not found"
            }
        }
        set result {}
        foreach name ${args} {
            set node [my Name2Node ${name}]
            lappend result {*}[${node} attr.keys]
        }
        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 opt } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set node [my Name2Node ${name}]
        return [${node} attr.exists ${opt}]
    }

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

    # --
    #
    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
    }

    # --
    #
    method key.nodes { key args } {
        set result {}
        set names [my nodes]
        switch -exact [lindex ${args} 0] {
        "-nodes" {
            set names [lrange ${args} 1 end]
        }
        "-glob" {
            set nlist {}
            set gpat [lindex ${args} 1]
            foreach name ${names} {
                if { [string match ${gpat} ${name}] == 1 } {
                    lappend nlist ${name}
                }
            }
            set names ${nlist}
        }
        "-regexp" {
            set nlist {}
            set rpat [lindex ${args} 1]
            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 [my key.get ${name} ${key}]
            }
        }
        return ${result}
    }

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


    # --
    #
    method key.unset { name opt } {
        if { [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set node [my Name2Node ${name}]
        ${node} attr.unset ${opt}
    }
    # --
    #
    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 returned result is a list in the form of an array get
    # where the elements are the names of the nodes and the values
    # are the result returned from the SerializeNode command.
    # The special name 'root' is given to the element of the node
    # being serialize.
    #
    method serialize { name {opts ""}} {
        my variable root
        my variable nodes
        if { ${name} ne "root" && [my exists ${name}] ne ""  } {
            error "node (${name}) - not found"
        }
        set AR() {}
        my SerializeNode AR ${name} 1
        array unset AR {}
        if { "-remove" in ${opts} } {
            my delete ${name}
        }
        return [array get AR]
    }

    # --
    #
    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}]
        # remove the range of children from the parent and insert the new node
        ${pnode} children [lreplace ${children} ${from} ${to} ${node}]
        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}
        } 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}
            ${pnode2} children ${children2}
            ${node1} parent ${pnode2}
            ${node2} parent ${pnode1}
        }
        return
    }
}