Page contents
See Also edit
Introduction edit
Richard Suchenwirth 2003-03-18 - Trees are a fundamental graph and data structure. They consist of nodes, where each node has a content (e.g. a string) and zero or more child nodes. Each node except the "root" has exactly one parent node.In Tcl, trees can be represented in various ways. Since 8.4, nested lists make an efficient tree representation, where access goes with lset and multi-index lindex. The following routine traverses such a tree and returns a list of node indices that can be used to iterate with foreach and lindex to access each node in sequence.Trees as irregular nested list
Concept and code
For a silly example, consider the following directory tree:/ /bin /usr /usr/bin /usr/local /usr/local/bin /usr/local/libwhich as a nested list, where each node is a directory, can very compactly be written as
{{} bin {usr bin {local bin lib}}}The list of all node indices is0 1 {2 0} {2 1} {2 2 0} {2 2 1} {2 2 2}which, when iterated over with lindex, enumerates all directory basenames:0: 1:bin 2 0:usr 2 1:bin 2 2 0:local 2 2 1:bin 2 2 2:liband, with the additional code in absolutePath and fromRoot, can also reconstruct the absolute paths (with an anomaly in /, which comes as empty string - but that's not a bug of these algorithms, but a peculiarity that Unix-like pathnames, Tk widget pathnames, Tcl namespace names have in common):
0:, 1:bin,/bin 2 0:usr,/usr 2 1:bin,/usr/bin 2 2 0:local,/usr/local 2 2 1:bin,/usr/local/bin 2 2 2:lib,/usr/local/libWe observe that leaves, i.e. nodes which have no children, have a nonzero as last index element, while nodes with children have a zero there. If you chop the trailing zero off, lindex gives you the subtree starting from that node.Lars H 2005-05-13: No, all node indices should end with a zero. The only reason it works to leave it out in this example is that all node contents are equal to their list-quoted forms. Consider the following tree (containing the Swedish monarchs of the Vasa dynasty [1]):
set tree {{Gustav Vasa} {{Erik XIV}} {{Johan III} Sigismund} {{Karl IX} {{Gustav II Adolf} Kristina}}}The proper index of Erik XIV is 1 0 despite him being a leaf, because he has a space in his name. 1 is the index for the subtree containing only that leaf, but that still has list-quoting in place.RS continues: An alternative would have been to represent each node as a pair {content children}, where the children are again a list. This would however lead to a much higher nesting depth:{{} {{bin {}} {usr {{bin {}} {local {{bin {}} {lib {}}}}}}}}while making the algorithms slightly simpler. As the procedures are written once, but hopefully used on many big trees, I decided for the simpler data representation.}
proc traverse {tree {prefix {}}} {
set res {}
if {[llength $tree] > 1} {
lappend res [concat $prefix 0] ;# content
set i 0
foreach child [lrange $tree 1 end] {
eval lappend res [traverse $child [concat $prefix [incr i]]]
}
} else {set res [list $prefix]} ;# leaf
set res
}
proc fromRoot index {
set res {}
set path {}
foreach i $index {
if $i {lappend res [concat $path 0]}
lappend path $i
}
lappend res $index
}
proc absolutePath {tree index} {
set res {}
foreach i [fromRoot $index] {
lappend res [lindex $tree $i]
}
set res
}
if 0 {Of course we want to modify such trees too - here's a first shot which inserts into a given tree, at given node ID, another (sub)tree (which might of course be just a single node) as child of the specified node. See usage examples in the test code at bottom:}
proc addSubtree {tree index subtree} {
if {[lindex $index end] == 0} {set index [lrange $index 0 end-1]}
set node [lindex $tree $index]
lappend node $subtree
lset tree $index $node
set tree
}
#------------ Testing:
set testtree {{} bin {usr bin {local bin lib}}}
puts [traverse $testtree]
foreach i [traverse $testtree] {
puts $i:[lindex $testtree $i],[join [absolutePath $testtree $i] /]
}
set testtree [addSubtree $testtree {2 0} lib]
set testtree [addSubtree $testtree {2 3} tcl8.4]
puts {added /usr/lib}
foreach i [traverse $testtree] {
puts $i:[lindex $testtree $i],[join [absolutePath $testtree $i] /]
}
if 0 {More tree routines: Determining the parent of a node, given its index, can be done without having to look at the tree itself. We have to distinguish the cases of a non-leaf, where we first chop off the trailing 0. As parent for root an empty string is returned by the second, "one-armed" if - the empty string result should be checked after calling: it is a valid index, but one that returns the whole tree if used with lindex.}
proc parent index {
if {[lindex $index end] == 0} {set index [lrange $index 0 end-1]}
if {$index ne {}} {lreplace $index end end 0}
}
if 0 {Graphical User Interface
Pierre Coueffin 2005-05-12: I wanted to embed a graphical representation of some nested-list type trees that my code generates into a paper I am working on. I came up with the following code, which needs BWidget to work.}
proc gui {w tree} {
package require BWidget
Tree $w
foreach i [lrange [traverse $tree] 1 end] {
set parent [absolutePath $tree [parent $i]]
if {$parent eq {{}} } {
set parent root
}
set node [absolutePath $tree $i]
set text [lindex $tree $i]
$w insert end $parent $node -text $text -open yes
}
return $w
}
if 0 {Then I do:pack [gui .tree $treedata]and I can generate a nice postscript representation by abusing the knowledge that BWidget uses a canvas widget to draw trees on:
set postscript [.tree.c postscript]
Comments
2009-02-10 I: noticed one problem with the gui proc above. It assigns node names based on the text in the list item. The problem with that is, in some applications, you may have duplicate text in different list members. It raises an error when it tries to name a new node with duplicate text if the nodes are at the same level, i.e. siblings, in the tree. You need a unique ID for each new node. I changed the proc like this, and it seems to work better.}
proc gui {w tree} {
package require BWidget
Tree $w -width 30 -height 35
# the variable i here seems to be unique to each node. It comes from the traverse proc and seems to assign
# a unique value for each item in the tree, so I used that for the node names. Now I can use the same text in sibling
# list items without causing the error.
foreach i [lrange [traverse $tree] 1 end] {
set parent [absolutePath $tree [parent $i]]
if {$parent eq {{}} } {
set parent root
}
if {$parent ne {root}} {
set parent [parent $i]
}
set node $i
set text [lindex $tree $i]
$w insert end $parent $node -text $text -open yes
}
return $w
}
if 0 {Here's some test data I used that did not work with the first gui, but does seem to work with the above changes: For example, the three instances of "appearance" at the same level in the list would cause an error before, but now are tolerated.# Patient with a sore throat?
set tree_data {
{} {{appearance} {no_distress {Viral}}}
{{appearance} {toxic {Epiglottitis}}}
{{appearance} {uncomfortable
{{exudate} {no
{{ulcers} {no {Viral }}}
{{ulcers} {yes {"Herpes Stomatitis"}}}}
}
{{exudate} {yes
{{temp} {100.5 {Mononucleosis}}}
{{temp} {101 {Mononucleosis}}}
{{temp} {103 {Streptococcal}}}}
}}}
} Trees as regular nested list
Page contents
FM, 2009-02-28 : using idea of Lars H (the nested list should always end with {}) that I implemented in nl2 package (see nested list to get the source, otherwise the code below won't work) :nl2tree package : tree as 2-length nested list
}
namespace eval nl2tree {
proc append {tree ParentNode TreeToAppend} {
# nl2tree append ...
upvar $tree Tree
set Index [lreplace [nl2tree lindex $Tree $ParentNode] end end 1]
set l [::lindex $Tree $Index]
nl2 append l $TreeToAppend
lset Tree $Index $l
}
proc children {tree node} {
# nl2tree children ...
set Children [list]
foreach {parent children} [::lindex $tree] {
foreach child [nl2 index $children] {
if {$parent eq $node} {
lappend Children [nl2 index $child 0]
} else {
lappend Children {*}[nl2tree children $child $node]
}
}
return $Children
}
return
}
proc delete {tree node} {
# nl2tree delete ...
upvar $tree Tree
if {$node eq [nl2tree root $Tree]} {uplevel "unset $tree"; return}
set NodeIndex [nl2tree lindex $Tree $node]
set ParentIndex [nl2tree lindex $Tree [set Parent [nl2tree parent $Tree $node]]]
set SubTreeIndex [lreplace $ParentIndex end end]
set L [list $Parent]
foreach N [nl2tree children $Tree [::lindex $Tree $ParentIndex]] {
if {[set i [nl2tree lindex $Tree $N]] ne $NodeIndex} {
lappend L $Subtree
}
}
lset Tree $SubTreeIndex [nl2 right {*}$L]
}
proc insert {tree Parent index TreeToInsert} {
# nl2tree insert ...
upvar $tree Tree
set ParentIndex [lreplace [nl2tree lindex $Tree $Parent] end end 1]
set l [::lindex $Tree $ParentIndex]
if {$index < [nl2tree numchildren $Tree $Parent]} {
lset Tree $ParentIndex [nl2 insert $l $index $TreeToInsert]
}
}
proc lindex {tree node {index {}}} {
# nl2tree lindex ...
foreach {parent children} [::lindex $tree] {
if {$parent eq $node} {return [list {*}$index 0]}
set j 1
foreach child [nl2 index $children] {
set {childIndex} [list {*}$index {*}[lrepeat $j 1] 0 0]
if {[set p [nl2tree lindex $child $node $childIndex]] ne {}} {
return $p
}
incr j
}
}
return
}
proc node {tree args} {
# nl2tree node ...
foreach i $args {
incr i
lappend Index {*}[lrepeat $i 1] 0 0
}
lappend Index 0
::lindex $tree {*}$Index
}
proc numchildren {tree node} {
# nl2tree numchildren ...
set Index [lreplace [nl2tree lindex $tree $node] end end 1]
nl2 length [::lindex $tree $Index]
}
proc parent {tree node {Parent {}}} {
# nl2tree parent ...
foreach {parent children} [::lindex $tree] {
if {$parent eq $node} {
return $Parent
}
foreach child [nl2 index $children] {
if {[set p [nl2tree parent $child $node $parent]] ne {}} {
return $p
}
}
}
return
}
proc root {tree} {
# nl2tree root ...
return [::lindex $tree 0]
}
namespace export *
namespace ensemble create
}
package provide nl2tree 0.1
if 0 {Example of application with tree as 2-length nested list
Page contents
}
# console show
# 1°/ Hand made tree (with some sugar)
interp alias {} Root {} nl2 right
interp alias {} + {} nl2 right
interp alias {} ° {} nl2 right
set HandMadeTree [Root :: \
[+ nl3 \
[+ nl3::is \
[° nl3::is::left] \
[° nl3::is::middle] \
[° nl3::is::right]]\
[+ nl3::repeat\
[° nl3::repeat::left] \
[° nl3::repeat::middle] \
[° nl3::repeat::right]\
]] \
\
[+ nl4 \
[+ nl4::is \
[° nl4::is::east] \
[° nl4::is::north] \
[° nl4::is::south] \
[° nl4::is::west] \
] \
[+ nl4::repeat \
[° nl4::repeat::east] \
[° nl4::repeat::north] \
[° nl4::repeat::south] \
[° nl4::repeat::west] \
]\
[+ nl4::merge \
[° nl4::merge::east] \
[° nl4::merge::north] \
[° nl4::merge::south] \
[° nl4::merge::west] \
]]\
\
[+ nl5 \
[+ nl5::is \
[° nl5::is::east] \
[° nl5::is::north] \
[° nl5::is::center] \
[° nl5::is::south] \
[° nl5::is::west] \
]\
[° nl5::etc]]]
proc HandMadeTree {} {
return $::HandMadeTree
}
# 2°/ frequently usefull
proc Namespaces {{namespace ::}} {
set L [list]
foreach nc [namespace children $namespace] {
lappend L [Namespaces ${nc}]
}
return [nl2 right $namespace {*}$L]
}
proc Widgets {{top .}} {
set L [list]
foreach w [winfo children $top] {
lappend L [Widgets $w]
}
return [nl2 right $top {*}$L]
}
proc Directories {{dir ~} {depth 4}} {
set L [list]
if {[incr depth -1] == 0} {return {}}
foreach d [glob -type d -nocomplain -- $dir/*] {
lappend L [Directories $d $depth]
}
return [nl2 right [file normalize $dir] {*}$L]
}
# basic graphic user interface
proc Gui {} {
toplevel .top1
wm title .top1 "Tree as nested list"
foreach demo [list "Directories" "Namespaces" "Widgets" "HandMadeTree"] {
ttk::treeview .top1.ttk_treeview$demo
.top1.ttk_treeview$demo heading \#0 -text $demo
pack .top1.ttk_treeview$demo -expand 1 -fill both -side left
Populate .top1.ttk_treeview$demo [$demo]
}
bind .top1.ttk_treeviewDirectories <<TreeviewOpen>> {
if {[glob -nocomplain -type d -- [%W focus]/*] ne {}} {
Populate %W [Directories [glob -nocomplain [%W focus]]] [%W focus]
}
}
}
proc Populate {W L {topnode {}}} {
foreach {parent children} [lindex $L] {
catch {$W insert $topnode end -id $parent -text {*}$parent};# catch is usefull only for directories
foreach child [nl2 index $children] {
Populate $W $child $parent
}
}
}
Gui
if 0 {FM : How does this work ?The first element of the 2-length nested list contains the root node, the second contains the lists of the children nodes which are themselves 2-length nested list ... etc.Well ? But, how does one assign data to nodes in such trees ? Here are three ideas :- For simplest cases, put it in the ttk::treeview widget.
- Alternatively cut the first element in two parts (one for the node, the other part for data) - this requires a change to the proc of ensemble nl2tree.
- Use 3-constant-length nested list (i.e nl3). The first index would be set to the name of the node, the second index would contain data, and the third would contain the list of children nodes
nl3tree package : tree as 3-length nested list
Page contents
FM: Here is an example with 3-constant-length nested list(see nested list to get the nl3 code).Given the nl3tree ensemble below :
}
# source nl3.tcl; # -> use the nl3 ensemble given in nested list page
# package require nl3
namespace eval nl3tree {
proc help args {
set nl3tree [dict create \
append "nl3tree append TreeVariable parent childtree :\n\tAppend a child tree to the children list of a node of the given tree variable" \
children "nl3tree children TreeValue node : \n\tList children of a node of a tree value" \
delete "nl3tree delete TreeVariable node : \n\tDelete the tree node (and it's descendant) of the given tree variable" \
insert "nl3tree insert TreeVariable parent index childtree : \n\tInsert a child tree at the index to to the children list of a node of a tree variable" \
get "nl3tree get TreeValue node ?keys ?keys : \n\tGiven the tree value TreeValue, get the data of a node - same interface as dict" \
glob "nl3tree glob TreeValue pattern : \n\tGiven the tree value TreeValue, search for node which have a glob pattern like pattern argument" \
keys "nl3tree keys TreeValue node : \n\tGiven a tree value TreeValue, retrieve the keys of data of the node - same interface as dict" \
lindex "nl3tree lindex TreeValue node : \n\tGiven a tree value, return the index (the list index) of the node" \
node "nl3tree node TreeValue args : \n\tGiven a tree value, return the node of specifies index (the tree index) specified as args. If args is empty, then the root node is return. The first children of the root node as an index 0; the second children of the root node has an index 1. The first children of the first children of the root node has an index of 0 0; 'nl3tree \$tree 0 1 0 2' return the third children of the first children of the second children of the first children of the root node" \
numchildren "nl3tree numchildren TreeValue node : \n\tReturn the number of child of the node in the tree store in TreeValue" \
parent "nl3tree parent TreeValue node : \n\tReturn the parent of node in the tree store in TreeValue" \
root "nl3tree root TreeValue : \n\tReturn the root node of the TreeValue given in argument" \
set "nl3tree set TreeVariable node ?keys ?keys : \n\tSet the value of the key for the node given in argument"]
if {[llength $args] == 0} {
puts "nl3tree subcommands :"
foreach k [dict keys $nl3tree] {
puts $k
}
puts "type nl3tree help ?subcommand ?subcommand ?... for more information on those subcommands"
} elseif {[llength $args] == 1} {
puts [dict get $nl3tree $args]
} else {
foreach k $args {
puts "[dict get $nl3tree $k]"
}
}
}
proc append {tree ParentNode TreeToAppend} {
# nl3tree append ... Ok
upvar $tree Tree
::set Index [lreplace [nl3tree lindex $Tree $ParentNode] end end [nl3 rindice [nl3 type $Tree]] 0 0]
::set l [::lindex $Tree $Index]
lappend l $TreeToAppend
lset Tree $Index $l
}
proc children {tree parent} {
# nl3tree children ... Ok
::set Children [list]
lassign [nl3 index $tree] node data children
foreach {child} [::lindex $children] {
if {$parent eq $node} {
lappend Children {*}[::lindex $child 0]
} else {
lappend Children {*}[children $child $parent]
}
}
return $Children
}
proc delete {tree node} {
# nl3tree delete ... Ok
upvar $tree Tree
if {$node eq [nl3tree root $Tree]} {uplevel "unset $tree"; return}
::set TailIndex [::lindex [::set NodeIndex [nl3tree lindex $Tree $node]] end-1]
::set ListNodeIndex [lreplace $NodeIndex end-1 end]
::set L [lreplace [::lindex $Tree $ListNodeIndex] $TailIndex $TailIndex]
::set ParentIndex [nl3tree lindex $Tree [::set Parent [nl3tree parent $Tree $node]]]
::set SubTreeIndex [lreplace $ParentIndex end end]
lset Tree {*}$SubTreeIndex [nl3 rindice [nl3 type $Tree]] 0 0 $L
return
}
proc get {tree node args} {
# nl3tree get ... Ok
::set index [lreplace [nl3tree lindex $tree $node] end end]
return [dict get [nl3 index [::lindex $tree $index] 1] {*}$args]
}
proc glob {tree pattern {index {}}} {
# nl3tree glob ... Ok
lassign [nl3 index $tree] node data children
if {[string match $pattern $node]} {
lappend L $node
}
::set j 0
foreach {child} [::lindex $children] {
::set {childIndex} [list {*}$index [nl3 rindice [nl3 type $tree]] 0 0 $j]
lappend L {*}[nl3tree glob $child $pattern $childIndex]
incr j
}
if {[info exist L]} {
return $L
}
}
proc insert {tree Parent index TreeToInsert} {
# nl3tree insert ...Ok
upvar $tree Tree
::set ParentIndex [lreplace [nl3tree lindex $Tree $Parent] end end [nl3 rindice [nl3 type $Tree]] 0 0]
::set l [::lindex $Tree $ParentIndex]
if {$index < [nl3tree numchildren $Tree $Parent]} {
lset Tree $ParentIndex [linsert $l $index $TreeToInsert]
}
}
proc keys {tree node args} {
# nl3tree keys ... Ok
::set index [lreplace [nl3tree lindex $tree $node] end end]
return [dict keys [nl3 index [::lindex $tree $index] 1] {*}$args]
}
proc lindex {tree parent {index {}}} {
# nl3tree lindex ... Ok
lassign [nl3 index $tree] node data children
if {$parent eq $node} {
return [list {*}$index 0]
}
::set j 0
foreach {child} [::lindex $children] {
::set {childIndex} [list {*}$index [nl3 rindice [nl3 type $tree]] 0 0 $j]
if {[::set p [nl3tree lindex $child $parent $childIndex]] ne {}} {
return $p
}
incr j
}
return
}
proc node {tree args} {
# nl3tree node ... Ok
::set i 0
foreach i $args {
lappend Index [nl3 rindice [nl3 type $tree]] 0 0 $i
incr i
}
lappend Index 0
::lindex $tree {*}$Index
}
proc numchildren {tree node} {
# nl3tree numchildren ... Ok
::set Index [lreplace [nl3tree lindex $tree $node] end end]
llength [nl3 index [::lindex $tree $Index] 2]
}
proc parent {tree parent {Parent {}}} {
# nl3tree parent ... Ok
lassign [nl3 index $tree] node data children
if {$parent eq $node} {
return $Parent
}
foreach {child} [::lindex $children] {
if {[::set p [nl3tree parent $child $parent $node]] ne {}} {
return $p
}
}
return
}
proc root {tree} {
# nl3tree root ... Ok
return [::lindex $tree 0]
}
proc set {tree node args} {
# nl3tree set .. Ok
set numdict 0
upvar $tree Tree
::set keys [lrange $args 0 end-1]
::set arg [::lindex $args end]
::set index [lreplace [nl3tree lindex $Tree $node] end end ]
::set DictIndex [::lindex [nl3 iorder [nl3 type [::lindex $Tree $index]]] [expr {$numdict+1}]]
::set Dict [nl3 index [::lindex $Tree $index] [expr {$numdict+1}]]
dict set Dict {*}$keys $arg
lset Tree {*}$index $DictIndex [list $Dict]
return $Dict
}
namespace export *
namespace ensemble create
}
package provide nl3tree 0.1
if 0 {nl3tree package example
Page contents
Now, it's possible to store data in the tree.Here's an example dealing with the most currents trees found in tcl/tk (Namespaces, Widgets, Directories). It should look like that :
}
# package require nl3; # need nl3 ensemble (look at the [nested list] page)
# source nl3tree.tcl; # need nl3tree ensemble (look at just above)
# console show; # if you to play with it
# make a node
proc nl3node {N D args} {
if {[llength $args] != 0} {
return [nl3 middle $N $D [list $args]]
} else {
return [nl3 middle $N $D]
}
}
# Some sugar
interp alias {} + {} nl3node
interp alias {} ° {} nl3node
# Making interface as a tree. Each keys of each node will be a lambda to be apply.
set GUI \
[+ root \
[dict create \
interface {
{} {
toplevel .top1
wm title .top1 "Tree as nested list of llength 3"
ttk::notebook .top1.nb
pack .top1.nb -side top -expand 1 -fill both
}
}]\
\
[+ Directories \
[dict create \
interface {
{} {
ttk::frame .top1.nb.fDirectories
pack .top1.nb.fDirectories -side top -expand 0 -fill both
ttk::treeview .top1.nb.fDirectories.ttk_treeview
.top1.nb.fDirectories.ttk_treeview heading \#0 -text Directories
.top1.nb.fDirectories.ttk_treeview column \#0 -width 500
pack .top1.nb.fDirectories.ttk_treeview -expand 0 -side left -fill both
bind .top1.nb.fDirectories.ttk_treeview <<TreeviewOpen>> {
if {[glob -nocomplain -type d -directory [%W focus] -- *] ne {}} {
Display %W [Directories [%W focus]] [%W focus]
}
}
.top1.nb add .top1.nb.fDirectories -text Directories
}
} \
display {
{} {
Display .top1.nb.fDirectories.ttk_treeview [Directories]
}
}] \
\
[° files \
[dict create \
interface {
{} {
# load shellicon0.1.dll -> encoding problem
pack [ttk::labelframe .top1.nb.fDirectories.ttk_labelframe1 \
-text fichiers] -expand 1 -fill both -side left
pack [canvas .top1.nb.fDirectories.ttk_labelframe1.c -bg white -relief sunken -borderwidth 3] -expand 1 -fill both -side left
pack [ttk::scrollbar .top1.nb.fDirectories.ttk_labelframe1.sv -orient v -command {
.top1.nb.fDirectories.ttk_labelframe1.c yview
}] -expand 0 -fill y -side left
.top1.nb.fDirectories.ttk_labelframe1.c configure \
-yscrollcommand {.top1.nb.fDirectories.ttk_labelframe1.sv set}
bind .top1.nb.fDirectories.ttk_treeview <<TreeviewSelect>> {
set i 0
set Canvas [winfo parent %W].ttk_labelframe1.c
$Canvas delete all
%W configure -cursor wait
set ::Selected [list]
set ::FilesSelected [list]
proc ::menuFic {F} {
menu .m0 -tearoff false
.m0 add command -label {Renommer} -command {}
.m0 add command -label {Ouvrir avec} -command {}
return .m0
}
foreach fic [glob -nocomplain -directory [%W focus] -type f -- *] {
# bug : ::shellicon::get ne gère pas correctement les accents
# + bug core dump
# catch {$Canvas create image 20 [incr i 20] -image [::shellicon::get $fic]}
set tag [$Canvas create text 40 [incr i 20] -text [file tail $fic] -anchor w]
$Canvas bind $tag <Double-1> [subst {exec -- [auto_execok start] \"\" [list $fic] &}]
$Canvas bind $tag <ButtonPress-3> [subst -noc {
if {[llength \$::Selected] == 0} {
%%W lower [set Select [%%W create rectangle {*}[%%W bbox current] -fill LightBlue]]
lappend ::Selected \$Select
lappend ::FilesSelected [%%W bbox current]
} elseif {[llength \$::Selected] > 0 && [%%W bbox current] ni \$::FilesSelected } {
%%W delete {*}\$::Selected
%%W lower [set Select [%%W create rectangle {*}[%%W bbox current] -fill LightBlue]]
lappend ::Selected \$Select
lappend ::FilesSelected [%%W bbox current]
}
tk_popup [::menuFic "$fic"] %%X %%Y
destroy .m0
%%W delete {*}\$::Selected
set ::FilesSelected [list]
set ::Selected [list]
}]
$Canvas bind $tag <ButtonPress-1> {
if {[%%W bbox current] ni $::FilesSelected } {
%%W delete {*}$::Selected
set ::FilesSelected [list]
set ::Selected [list]
}
%%W lower [set Select [%%W create rectangle {*}[%%W bbox current] -fill LightBlue]]
lappend ::Selected $Select
lappend ::FilesSelected [%%W bbox current]
}
$Canvas bind $tag <Control-ButtonPress-1> {
%%W lower [set Select [%%W create rectangle {*}[%%W bbox current] -fill LightBlue]]
lappend ::Selected $Select
lappend ::FilesSelected [%%W bbox current]
}
}
%W configure -cursor arrow
$Canvas configure -scrollregion [list 0 0 500 [expr {$i+30}]]
}
}
}]\
]]\
\
[+ Namespaces \
[dict create \
interface {
{} {
ttk::frame .top1.nb.fNamespaces
pack .top1.nb.fNamespaces -side top -expand 1 -fill both
ttk::treeview .top1.nb.fNamespaces.ttk_treeview
.top1.nb.fNamespaces.ttk_treeview heading \#0 -text Namespaces
.top1.nb.fNamespaces.ttk_treeview column \#0
pack .top1.nb.fNamespaces.ttk_treeview -expand 1 -side left -fill both
ttk::frame .top1.nb.fNamespaces.ttk_frame
pack .top1.nb.fNamespaces.ttk_frame -side left -fill both -expand 1
.top1.nb add .top1.nb.fNamespaces -text Namespaces
ttk::notebook .top1.nb.fNamespaces.nb
pack .top1.nb.fNamespaces.nb -side top -expand 1 -fill both
bind .top1.nb.fNamespaces.ttk_treeview <<TreeviewSelect>> {
[winfo parent %W].nb.ttk_frame1.lb0 delete 0 end
[winfo parent %W].nb.ttk_frame1.lb1 delete 0 end
[winfo parent %W].nb.ttk_frame1.lb0 insert end {*}[lindex [%W item [%W focus] -values] 0]
[winfo parent %W].nb.ttk_frame1.lb0 selection set 0
update
[winfo parent %W].nb.ttk_frame2.lb delete 0 end
[winfo parent %W].nb.ttk_frame2.lb insert end {*}[lindex [%W item [%W focus] -values] 1]
[winfo parent %W].nb.ttk_frame2.lb selection set 0
[winfo parent %W].nb.ttk_frame2.t delete 0.0 end
update idletask
# focus -force [winfo parent %W].nb.ttk_frame1.lb0
event generate [winfo parent %W].nb.ttk_frame1.lb0 <<ListboxSelect>>
event generate [winfo parent %W].nb.ttk_frame2.lb <<ListboxSelect>>
}
}
} \
display {
{} {
Display .top1.nb.fNamespaces.ttk_treeview [Namespaces]
}
}]\
[° vars \
[dict create \
interface {
{} {
pack [ttk::frame .top1.nb.fNamespaces.nb.ttk_frame1] -expand 1 -fill both -side left
pack [listbox .top1.nb.fNamespaces.nb.ttk_frame1.lb0 -width 33] -expand 0 -fill both -side left
pack [listbox .top1.nb.fNamespaces.nb.ttk_frame1.lb1] -expand 1 -fill both -side left
bind .top1.nb.fNamespaces.nb.ttk_frame1.lb0 <<ListboxSelect>> {
update
if {[%W curselection] ne {}} {
[winfo parent %W].lb1 delete 0 end
catch {
[winfo parent %W].lb1 insert end {*}[set [%W get [%W curselection]]]
}
catch {
foreach e [array names [%W get [%W curselection]]] {
lappend L [list $e [array get [%W get [%W curselection]] $e]]
}
[winfo parent %W].lb1 insert end {*}$L
unset L
}
}
}
.top1.nb.fNamespaces.nb add .top1.nb.fNamespaces.nb.ttk_frame1 -text variables
}
}\
]]\
[° procs \
[dict create \
interface {
{} {
pack [ttk::frame .top1.nb.fNamespaces.nb.ttk_frame2] -expand 1 -fill both -side left
pack [listbox .top1.nb.fNamespaces.nb.ttk_frame2.lb -width 33] -expand 1 -fill both -side left
pack [text .top1.nb.fNamespaces.nb.ttk_frame2.t] -expand 1 -fill both -side left
bind .top1.nb.fNamespaces.nb.ttk_frame2.lb <<ListboxSelect>> {
update
if {[%W curselection] ne {}} {
[winfo parent %W].t delete 0.0 end
[winfo parent %W].t insert end "[set P [%W get [%W curselection]]] {[info args $P]} {\n [info body $P] \n}"
unset P
}
}
.top1.nb.fNamespaces.nb add .top1.nb.fNamespaces.nb.ttk_frame2 -text procs
}
}\
]]\
]\
\
[+ Widgets \
[dict create \
interface {
{} {
ttk::frame .top1.nb.fWidgets
pack .top1.nb.fWidgets -side top -expand 0 -fill both
ttk::treeview .top1.nb.fWidgets.ttk_treeview
.top1.nb.fWidgets.ttk_treeview heading \#0 -text Widgets
.top1.nb.fWidgets.ttk_treeview column \#0 -width 300
pack .top1.nb.fWidgets.ttk_treeview -expand 0 -side left -fill both
.top1.nb add .top1.nb.fWidgets -text Widgets
ttk::notebook .top1.nb.fWidgets.nb
pack .top1.nb.fWidgets.nb -expand 1 -side left -fill both
}
} \
display {
{} {
Display .top1.nb.fWidgets.ttk_treeview [Widgets]
}
}\
]\
[° configure \
[dict create \
interface {
{} {
.top1.nb.fWidgets.nb add [ttk::frame .top1.nb.fWidgets.nb.ttk_frame1] \
-text configuration
bind .top1.nb.fWidgets.ttk_treeview <<TreeviewSelect>> {
destroy {*}[winfo children [winfo parent %W].nb.ttk_frame1]
pack [label .top1.nb.fWidgets.nb.ttk_frame1.l -text "[nl3tree get [Widgets] [%W focus] command] [nl3tree get [Widgets] [%W focus] path] " -width 50 -height 2 -anchor w] -anchor w -side top -fill none -expand 0 -padx 20
set i 0
foreach {o v} [nl3tree get [Widgets] [%W focus] configure] {
pack [ttk::frame .top1.nb.fWidgets.nb.ttk_frame1.f$i] -side top -fill both -expand 1
pack [label .top1.nb.fWidgets.nb.ttk_frame1.f$i.l -text $o -width 20] -side left -fill both -expand 0
pack [entry .top1.nb.fWidgets.nb.ttk_frame1.f$i.e] -side left -fill both -expand 1
.top1.nb.fWidgets.nb.ttk_frame1.f$i.e insert end $v
incr i
}
destroy {*}[winfo children [winfo parent %W].nb.ttk_frame2]
set i 0
set manager [dict keys [nl3tree get [Widgets] [%W focus] geometry]]
pack [label .top1.nb.fWidgets.nb.ttk_frame2.l -text $manager -width 20 -height 2 -anchor w] -anchor w -side top -fill none -expand 0 -padx 20
foreach {o v} [nl3tree get [Widgets] [%W focus] geometry $manager] {
pack [ttk::frame .top1.nb.fWidgets.nb.ttk_frame2.f$i] -side top -fill both -expand 1 -padx 40
pack [label .top1.nb.fWidgets.nb.ttk_frame2.f$i.l -text $o -width 20 -anchor w] -side left -fill both -expand 0
pack [entry .top1.nb.fWidgets.nb.ttk_frame2.f$i.e] -side left -fill both -expand 1
.top1.nb.fWidgets.nb.ttk_frame2.f$i.e insert end $v
incr i
}
}
}
}]\
]\
[° geometry \
[dict create \
interface {
{} {
.top1.nb.fWidgets.nb add [ttk::frame .top1.nb.fWidgets.nb.ttk_frame2] \
-text geometry
}
}
]]]]
proc class2command {w} {
set D [dict create \
Toplevel toplevel Button button Canvas canvas Checkbutton checkbutton Entry entry \
Frame frame Label label Labelframe labelframe Listbox listbox Menu menu Menubutton menubutton \
Message message Panedwindow panedwindow Radiobutton radiobutton Scale scale Scrollbar scrollbar \
Spinbox spinbox Text text TButton ttk::button TCheckbutton ttk::checkbutton TCombobox ttk::combobox \
TEntry ttk::entry TFrame ttk::frame TLabel ttk::label TLabelframe ttk::labelframe \
TMenubutton ttk::menubutton TNotebook ttk::notebook TPanedwindow ttk::panedwindow \
TProgressbar ttk::progressbar TRadiobutton ttk::radiobutton TScrollbar ttk::scrollbar \
TSeparator ttk::separator TSizegrip ttk::sizegrip Treeview ttk::treeview ]
if {$w ne "."} {
return [dict get $D [winfo class $w]]
} else {
return
}
}
# 2°/ frequently rencontred tree
# Making the namespace tree
proc Namespaces {{namespace ::}} {
set L [list]
foreach nc [namespace children $namespace] {
lappend L [Namespaces ${nc}]
}
return [nl3 middle $namespace [dict create vars [info vars ${namespace}::*] procs [info procs ${namespace}::*]] [list $L]]
}
# Making the widget tree
proc Widgets {{top .}} {
set L [list]
foreach w [winfo children $top] {
lappend L [Widgets $w]
}
foreach Op [$top conf] {
if {[llength $Op] == 5} {lappend Options [lindex $Op 0] [lindex $Op end]}
}
switch -exact -- [winfo manager $top] {
grid {set Geometry [list grid [grid info $top]]}
notebook {set Geometry [list [winfo parent $top] [list add $top]]}
pack {set Geometry [list pack [pack info $top]]}
place {set Geometry [list place [place info $top]]}
wm {
set Geometry [list wm [dict create \
geometry [wm geom $top]\
title [wm title $top]\
attributes [wm attributes $top]\
focusmodel [wm focusmodel $top]\
overrideredirect [wm overrideredirect $top]\
resizable [wm resizable $top]\
minsize [wm minsize $top]\
maxsize [wm maxsize $top]\
stackorder [wm stackorder $top]]]
}
default {
set Geometry {}
}
}
return [nl3 middle $top [dict create configure $Options geometry $Geometry command [class2command $top] path $top] [list $L]]
}
# Making a directory tree (change the default value of dir (c:/) if you are running it on linux / MAC OSX
proc Directories {{dir c:/} {depth 4}} {
set L [list]
if {[incr depth -1] == 0} {return {}}
foreach d [glob -type d -nocomplain -directory $dir -- *] {
lappend L [Directories $d $depth]
}
return [nl3 middle [file normalize $dir] [dict create] [list $L]]
}
# Populate the trees
proc Display {W L {topnode {}}} {
lassign [nl3 index $L] parent data children
catch {$W insert $topnode end -id $parent -text $parent}
if {[llength $data] > 0} {
foreach key [dict keys $data] {
lappend V [dict get $data $key]
}
$W item $parent -values $V
}
foreach {child} [::lindex $children] {
Display $W $child $parent
}
}
# Gui
proc TreeGui {tree node} {
# Traverse the treeGUI and apply the lambda to create the interface
if {![catch {nl3tree get $tree $node interface}]} {
apply [nl3tree get $tree $node interface]
}
if {![catch {nl3tree get $tree $node display}]} {
apply [nl3tree get $tree $node display]
}
foreach n [nl3tree children $tree $node] {
TreeGui $tree $n
}
}
TreeGui $GUI root
if 0 {nl4tree package : tree as 4-length nested list
Page contents
}
# package require nl4;# look at [nested list] page to get the nl4 ensemble command
namespace eval nl4tree {
proc append {tree ParentNode TreeToAppend} {
# nl4tree append ... Ok
upvar $tree Tree
::set Index [lreplace [nl4tree lindex $Tree $ParentNode] end end [nl4 rindice [nl4 type $Tree]] 0 0]
::set l [::lindex $Tree $Index]
lappend l $TreeToAppend
lset Tree $Index $l
}
proc children {tree parent} {
# nl4tree children ... Ok
::set Children [list]
lassign [nl4 index $tree] node data0 data1 children
foreach {child} [::lindex $children] {
if {$parent eq $node} {
lappend Children {*}[::lindex $child 0]
} else {
lappend Children {*}[nl4tree children $child $parent]
}
}
return $Children
}
proc delete {tree node} {
# nl4tree delete ... Ok
upvar $tree Tree
if {$node eq [nl4tree root $Tree]} {uplevel "unset $tree"; return}
::set TailIndex [::lindex [::set NodeIndex [nl4tree lindex $Tree $node]] end-1]
::set ListNodeIndex [lreplace $NodeIndex end-1 end]
::set L [lreplace [::lindex $Tree $ListNodeIndex] $TailIndex $TailIndex]
::set ParentIndex [nl4tree lindex $Tree [::set Parent [nl4tree parent $Tree $node]]]
::set SubTreeIndex [lreplace $ParentIndex end end]
lset Tree {*}$SubTreeIndex [nl4 rindice [nl4 type $Tree]] 0 0 $L
return
}
proc get {tree node numdict args} {
# nl4tree get .. Ok
::set index [lreplace [nl4tree lindex $tree $node] end end]
return [dict get [nl4 index [::lindex $tree $index] [expr {$numdict+1}]] {*}$args]
}
proc glob {tree pattern {index {}}} {
# nl4tree glob ... Ok
lassign [nl4 index $tree] node data0 data1 children
if {[string match $pattern $node]} {
lappend L $node
}
::set j 0
foreach {child} [::lindex $children] {
::set {childIndex} [list {*}$index [nl4 rindice [nl4 type $tree]] 0 0 $j]
lappend L {*}[nl4tree glob $child $pattern $childIndex]
incr j
}
if {[info exist L]} {
return $L
}
}
proc insert {tree Parent index TreeToInsert} {
# nl4tree insert ...Ok
upvar $tree Tree
::set ParentIndex [lreplace [nl4tree lindex $Tree $Parent] end end [nl4 rindice [nl4 type $Tree]] 0 0]
::set l [::lindex $Tree $ParentIndex]
if {$index < [nl4tree numchildren $Tree $Parent]} {
lset Tree $ParentIndex [linsert $l $index $TreeToInsert]
}
}
proc keys {tree node numdict args} {
# nl4tree keys ... Ok
::set index [lreplace [nl4tree lindex $tree $node] end end]
return [dict keys [nl4 index [::lindex $tree $index] [expr {$numdict+1}]] {*}$args]
}
proc lindex {tree parent {index {}}} {
# nl4tree lindex ... Ok
lassign [nl4 index $tree] node data0 data1 children
if {$parent eq $node} {
return [list {*}$index 0]
}
::set j 0
foreach {child} [::lindex $children] {
::set {childIndex} [list {*}$index [nl4 rindice [nl4 type $tree]] 0 0 $j]
if {[::set p [nl4tree lindex $child $parent $childIndex]] ne {}} {
return $p
}
incr j
}
return
}
proc node {tree args} {
# nl4tree node ... Ok
::set i 0
foreach i $args {
lappend Index [nl4 rindice [nl4 type $tree]] 0 0 $i
incr i
}
lappend Index 0
::lindex $tree {*}$Index
}
proc numchildren {tree node} {
# nl4tree numchildren ... Ok
::set Index [lreplace [nl4tree lindex $tree $node] end end]
llength [nl4 index [::lindex $tree $Index] 3]
}
proc parent {tree parent {Parent {}}} {
# nl4tree parent ... Ok
lassign [nl4 index $tree] node data0 data1 children
if {$parent eq $node} {
return $Parent
}
foreach {child} [::lindex $children] {
if {[::set p [nl4tree parent $child $parent $node]] ne {}} {
return $p
}
}
return
}
proc root {tree} {
# nl4tree root ... Ok
return [::lindex $tree 0]
}
proc set {tree node numdict args} {
# nl4tree set .. Ok
upvar $tree Tree
::set keys [lrange $args 0 end-1]
::set arg [::lindex $args end]
::set index [lreplace [nl4tree lindex $Tree $node] end end ]
::set DictIndex [::lindex [nl4 iorder [nl4 type [::lindex $Tree $index]]] [expr {$numdict+1}]]
::set Dict [nl4 index [::lindex $Tree $index] [expr {$numdict+1}]]
dict set Dict {*}$keys $arg
lset Tree {*}$index $DictIndex [list $Dict]
return $Dict
}
namespace export *
namespace ensemble create
}
package provide nl4tree 0.1
if 0 {nl4tree package example
Page contents
Look at Menu as trees as nested list to see an example with an nl4tree.
nlntree package : tree as n-length nested list (n > 4)
Suppose you have the nl4tree package in the file nl4tree.tclTo build a nl5tree package, simply take the nl5 package in nested list page, then do :set nl4fid [open nl4tree.tcl r]
set nl5fid [open nl5tree.tcl w]
puts $nl5fid [regsub -all {nl4} [regsub -all {node data0 data1 children} [read $nl4fid] {node data0 data1 data2 children}] {nl5}]
close $nl4fid
close $nl5fiduse it with (for example)proc + {N D0 D1 D2 args} {
return [nl5 center $N $D0 $D1 $D2 [list $args]]
}
set nl5Tree [+ [incr node] [dict create] [dict create] [dict create] \
[+ [incr node] [dict create] [dict create] [dict create] \
[+ [incr node] [dict create] [dict create] [dict create] \
[+ [incr node] [dict create] [dict create] [dict create] {}] \
[+ [incr node] [dict create] [dict create] [dict create] {}] \
] \
] \
[+ [incr node] [dict create] [dict create] [dict create] \
[+ [incr node] [dict create] [dict create] [dict create] \
[+ [incr node] [dict create] [dict create] [dict create] {}] \
[+ [incr node] [dict create] [dict create] [dict create] {}]\
]\
] \
[+ [incr node] [dict create] [dict create] [dict create] \
[+ [incr node] [dict create] [dict create] [dict create] \
[+ [incr node] [dict create] [dict create] [dict create] {}] \
[+ [incr node] [dict create] [dict create] [dict create] {}] \
]\
] \
]
nl5tree children $nl5Tree [nl5tree root $nl5Tree]; # == 2 6 10
nl5tree children $nl5Tree 6; # == 7
nl5tree children $nl5Tree 7; # == 8 9
The same if you do have an nl6 package (with 4 data dict in the tree) ...# open files
puts $nl6fid [regsub -all {nl4} [regsub -all {node data0 data1 children} [read $nl4fid] {node data0 data1 data2 data3 children}] {nl6}]
# close files... nl7 package (with 5 data dict in the tree), nl8 package (with 6 data dict in the tree) ...etcIf you don't want to have data as dict, you'll need to change the interface}
