Updated 2015-03-02 02:27:10 by RLE

MG Aug 20th 2007 - I've recently started re-writing an old app which had become hideously bloated and unmaintainable, and decided to redo it using Tcl/Tk 8.5 which, I've discovered since, has some really nice features that 8.4 doesn't. I also decided to try and minimize dependancies on external libraries, particularly ones that weren't pure Tcl, to try and make it easier to deploy using Tclkit on several platforms. And I found myself wanting a Tree widget, which Tk doesn't have natively.

Tile/ttk has a treeview widget, but I've not used any Tile widgets in my app, and didn't really want to go down that road just for one widget. TkTreeCtrl is very nice, but written in C, not pure-Tcl, and I didn't want to include the whole of BWidget just to get their tree widget.

The only pure-Tcl/Tk one I could find was tktree, which didn't have quite the look I wanted, and the code was larger than the rest of my app so far combined, having features I didn't need. So I wrote the (very minimal) Tree Widget below, which (ab)uses Tk 8.5's text widget.

It's somewhat limited - you can add new entries, but you can't delete them or move them (I don't need those features, so for my use they're bloat), though deleting would be very easy to add. The commands are simple:
   ::ttree::tree $widgetPath ?$args? - creates a new tree widget. Any extra args are passed to the underlying
                text widget.
   ::ttree::add $widgetPath $parent $label $cmd - adds a new entry to tree widget $widgetPath.
                $parent is the entry to add this as a child of (use 0 to make it a root entry),
                $label is the string to be displayed, and $cmd is the command run when it's clicked.
   ::ttree::show $widgetPath $id - expand all necessary branches to make $id visible

  • (Later on Aug 20th) - Added ::ttree::show; turns out I needed that, too.

The code:
 package require Tcl 8.5
 namespace eval ::ttree {}
 image create photo ::ttree::tree-close -data {
 image create photo ::ttree::tree-open -data {
 image create photo ::ttree::tree-dot -data {
 proc ::ttree::tree {w args} {
   variable tree;
   ::text $w -cursor {} -spacing3 1p
   if { [llength $args] > 0 } {
        $w configure {*}$args
   set tree($w,items) 0
   set tags [bindtags $w]
   set pos [lsearch -exact $tags "Text"]
   bindtags $w [lreplace $tags $pos $pos]
   bind $w <Destroy> [list array unset ::ttree::tree %W,*]
   $w tag configure sub-0 -elide 0
   return $w;
 };# ttree::tree
 proc ::ttree::add {w parent txt cmd} {
   variable tree;
   if { ![winfo exists $w] || ![info exists tree($w,items)] } {
        error "widget \"$w\" does not exist, or is not a tree widget"
   if { $parent != 0 && ![info exists tree($w,parent,$parent)] } {
        error "tree \"$w\" has no id \"$parent \""
   return [addSub $w $parent $txt $cmd];
 proc ::ttree::addSub {w parent txt cmd} {
   variable tree;
   set new [incr tree($w,items)]
   set tree($w,parent,$new) $parent
   set taglist [list id-$new]
   set tagParent $parent
   while { [info exists tree($w,parent,$tagParent)] } {
           lappend taglist sub-$tagParent
           set tagParent $tree($w,parent,$tagParent)
   $w tag configure id-$new -lmargin1 "[expr {13 * ([llength $taglist]-1) }]p"
   if { $parent != 0 && ![info exists tree($w,children,$parent)] } {
        setUpParent $w $parent
   lappend tree($w,children,$parent) $new
   if { $parent == 0 } {
        set where end
      } else {
        if { [catch {$w index sub-$parent.last} where] } {
             set where [$w index id-$parent.last]
   $w insert $where " $txt\n" $taglist
   set where [$w index id-$new.first+1char]
   $w image create $where -image ::ttree::tree-dot -align center -pady 2 -padx 4
   $w tag add btn-$new $where
   if { $cmd != "" } {
        $w tag bind id-$new <1> $cmd
   return $new;
 };# ttree::addSub
 proc ::ttree::setUpParent {w parent} {
   variable tree;
   $w tag configure sub-$parent -elide 1 
   set tree($w,elide,$parent) 1
   $w tag lower btn-$parent
   $w tag lower sub-$parent 
   $w tag bind btn-$parent <Button-1> [list ::ttree::toggle $w $parent]
   $w image configure btn-$parent.first -image ::ttree::tree-open
 };# ttree::setUpParent

 proc ::ttree::toggle {w parent} {
   variable tree;
   set base [expr {!$tree($w,elide,$parent)}]
   set tree($w,elide,$parent) $base
   $w image configure btn-$parent.first -image [expr {$base ? "::ttree::tree-open" : "::ttree::tree-close"}]
   $w tag configure sub-$parent -elide [expr { $base ? 1 : "" }]
 };# ttree::toggle
 proc ::ttree::show {w id} {
   variable tree;
   while { [info exists tree($w,parent,$id)] } {
      set id $tree($w,parent,$id)
      if { $id == 0 } {
      if { $tree($w,elide,$id) } {
           toggle $w $id
 };# ttree::show
 # Optional, export [tree] and [add] into the global namespace
 namespace eval ::ttree {namespace export tree add}
 namespace import ::ttree::*

And a demo
 pack [ttree::tree .t]
 ttree::add .t 0 Foo {puts "foo"}
 ttree::add .t 0 Bar {puts "bar"}
 ttree::add .t 1 Baz {}
 ttree::add .t 1 Bleep {puts "bleep"}
 ttree::add .t 0 Bloop {puts "bloop"}
 ttree::add .t 0 Splash {puts "splash"}
 ttree::add .t 3 Boing {puts "boing"}
 ttree::add .t 3 Sprocket {puts "sprocket"}
 ttree::add .t 3 Meep {puts "meep"}