---- <> ---- ** Introduction ** if 0 {[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/lib which 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 is 0 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:lib and, 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/lib We 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], 13 May 2005: 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):'' 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.'' 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 != ""} {lreplace $index end end 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 == {{}} } { 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 == {{}} } { set parent root } if {$parent != "root"} { set parent [parent $i] } set node "$i" set text [lindex $tree $i] $w insert end $parent $node -text $text -open yes } return $w } Here's some test data I used that did not work with the first proc, 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}}}} }}} } if 0 { ---- *** Trees as regular nested list *** ---- <> [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 ====== **** Exemple of application with tree as 2-length nested list **** ---- <> ---- ====== # 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 <> { 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 **** ---- <> ---- [FM] Here is an exemple 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 1 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 1 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 1 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 1 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 1 0 0 $i incr i } lappend Index 0 ::lindex $tree {*}$Index } proc numchildren {tree node} { # nl3tree numchildren ... Ok ::set Index [lreplace [nl3treelindex $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 ====== **** nl3tree package exemple **** ---- <> ---- Now, it's possible to store data in the tree. Here's an exemple dealing with the most currents trees found in tcl/tk (Namespaces, Widgets, Directories). It should look like that : [http://www.florentmerlet.com/images/treeAsNestedList.gif] ====== # 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 <> { 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 <> { 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 [subst {exec -- [auto_execok start] \"\" [list $fic] &}] $Canvas bind $tag [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 { 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 { %%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 <> { [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 <> event generate [winfo parent %W].nb.ttk_frame2.lb <> } } } \ 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 <> { 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 <> { 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 <> { 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 [file join $dir $d] $depth] 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 ====== **** nl4tree package : tree as 4-length nested list **** ---- <> ---- It's possible to do trees with other [nested list], look at [Menu as trees as nested list] to see an example with an nl4tree. } if 0 { ---- See also: * [Binary trees] * [Decision trees] * [Complex data structures] ---- !!!!!! %| [Category Concept] | [Category Data Structure] |% [Arts and crafts of Tcl-Tk programming] !!!!!! }