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 {
R0lGODdhCQAJAJEAAGZmZv///wAAAP///ywAAAAACQAJAAACGYSPFD8A8IDA
+AEQJDsAKH4A4AGB8YPgYwEAOw==
}
image create photo ::ttree::tree-open -data {
R0lGODdhCQAJAJEAAGZmZv///wAAAP///ywAAAAACQAJAAACHoSPFD8ATo6A
REhEEBCSHQARQUoCICJISQBQ/CD4WAA7
}
image create photo ::ttree::tree-dot -data {
R0lGODdhCQAJAJEAAP///wAAAP///////ywAAAAACQAJAAACD4SPqXtB8CEg
8CiEj6l7BQA7
}
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 } {
break;
}
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"}
