# ---------------------------------------------------------------------------- # tree.tcl # This file is part of Unifix BWidget Toolkit # $Id: tree.tcl,v 1.37 2002/10/14 20:54:12 hobbs Exp $ # ---------------------------------------------------------------------------- # Index of commands: # - Tree::create # - Tree::configure # - Tree::cget # - Tree::insert # - Tree::itemconfigure # - Tree::itemcget # - Tree::bindText # - Tree::bindImage # - Tree::delete # - Tree::move # - Tree::reorder # - Tree::selection # - Tree::exists # - Tree::parent # - Tree::index # - Tree::nodes # - Tree::see # - Tree::opentree # - Tree::closetree # - Tree::edit # - Tree::xview # - Tree::yview # - Tree::_update_edit_size # - Tree::_destroy # - Tree::_see # - Tree::_recexpand # - Tree::_subdelete # - Tree::_update_scrollregion # - Tree::_cross_event # - Tree::_draw_node # - Tree::_draw_subnodes # - Tree::_update_nodes # - Tree::_draw_tree # - Tree::_redraw_tree # - Tree::_redraw_selection # - Tree::_redraw_idle # - Tree::_drag_cmd # - Tree::_drop_cmd # - Tree::_over_cmd # - Tree::_auto_scroll # - Tree::_scroll # ---------------------------------------------------------------------------- namespace eval Tree { namespace eval Node { Widget::declare Tree::Node { {-text String "" 0} {-font TkResource "" 0 listbox} {-image TkResource "" 0 label} {-window String "" 0} {-fill TkResource black 0 {listbox -foreground}} {-data String "" 0} {-open Boolean 0 0} {-selectable Boolean 1 0} {-drawcross Enum auto 0 {auto allways never}} } } Widget::tkinclude Tree canvas .c \ remove { -insertwidth -insertbackground -insertborderwidth -insertofftime -insertontime -selectborderwidth -closeenough -confine -scrollregion -xscrollincrement -yscrollincrement -width -height } \ initialize { -relief sunken -borderwidth 2 -takefocus 1 -highlightthickness 1 -width 200 } Widget::declare Tree { {-deltax Int 10 0 "%d >= 0"} {-deltay Int 15 0 "%d >= 0"} {-padx Int 20 0 "%d >= 0"} {-background TkResource "" 0 listbox} {-selectbackground TkResource "" 0 listbox} {-selectforeground TkResource "" 0 listbox} {-selectcommand String "" 0} {-width TkResource "" 0 listbox} {-height TkResource "" 0 listbox} {-selectfill Boolean 0 0} {-showlines Boolean 1 0} {-linesfill TkResource black 0 {listbox -foreground}} {-linestipple TkResource "" 0 {label -bitmap}} {-redraw Boolean 1 0} {-opencmd String "" 0} {-closecmd String "" 0} {-dropovermode Flag "wpn" 0 "wpn"} {-bg Synonym -background} } DragSite::include Tree "TREE_NODE" 1 DropSite::include Tree { TREE_NODE {copy {} move {}} } Widget::addmap Tree "" .c {-deltay -yscrollincrement} # Trees on windows have a white (system window) background if { $::tcl_platform(platform) == "windows" } { option add *Tree.c.background SystemWindow widgetDefault option add *TreeNode.fill SystemWindowText widgetDefault } bind TreeSentinalStart { if { $::Tree::sentinal(%W) } { set ::Tree::sentinal(%W) 0 break } } bind TreeSentinalEnd { set ::Tree::sentinal(%W) 0 } bind TreeFocus [list focus %W] proc ::Tree { path args } { return [eval Tree::create $path $args] } proc use {} {} variable _edit } # ---------------------------------------------------------------------------- # Command Tree::create # ---------------------------------------------------------------------------- proc Tree::create { path args } { variable $path upvar 0 $path data Widget::init Tree $path $args set ::Tree::sentinal($path.c) 0 set data(root) {{}} set data(selnodes) {} set data(upd,level) 0 set data(upd,nodes) {} set data(upd,afterid) "" set data(dnd,scroll) "" set data(dnd,afterid) "" set data(dnd,selnodes) {} set data(dnd,node) "" frame $path -class Tree -bd 0 -highlightthickness 0 -relief flat \ -takefocus 0 # For 8.4+ we don't want to inherit the padding catch {$path configure -padx 0 -pady 0} eval canvas $path.c [Widget::subcget $path .c] -xscrollincrement 8 bindtags $path.c [list TreeSentinalStart TreeFocus $path.c Canvas \ [winfo toplevel $path] all TreeSentinalEnd] pack $path.c -expand yes -fill both $path.c bind cross [list Tree::_cross_event $path] # Added by ericm@scriptics.com # These allow keyboard traversal of the tree bind $path.c "Tree::_keynav up $path" bind $path.c "Tree::_keynav down $path" bind $path.c "Tree::_keynav right $path" bind $path.c "Tree::_keynav left $path" bind $path.c "+Tree::_keynav space $path" # These allow keyboard control of the scrolling bind $path.c "$path.c yview scroll -1 units" bind $path.c "$path.c yview scroll 1 units" bind $path.c "$path.c xview scroll -1 units" bind $path.c "$path.c xview scroll 1 units" # ericm@scriptics.com bind $path "Tree::_update_scrollregion $path" bind $path "Tree::_destroy $path" bind $path [list after idle {BWidget::refocus %W %W.c}] DragSite::setdrag $path $path.c Tree::_init_drag_cmd \ [Widget::cget $path -dragendcmd] 1 DropSite::setdrop $path $path.c Tree::_over_cmd Tree::_drop_cmd 1 rename $path ::$path:cmd proc ::$path { cmd args } "return \[eval Tree::\$cmd $path \$args\]" set w [Widget::cget $path -width] set h [Widget::cget $path -height] set dy [Widget::cget $path -deltay] $path.c configure -width [expr {$w*8}] -height [expr {$h*$dy}] # ericm # Bind to select the clicked node -- no reason not to, right? Tree::bindText $path "$path selection set" Tree::bindImage $path "$path selection set" Tree::bindText $path "$path selection toggle" Tree::bindImage $path "$path selection toggle" # Add sentinal bindings for double-clicking on items, to handle the # gnarly Tk bug wherein: # ButtonClick # ButtonClick # On a canvas item translates into button click on the item, button click # on the canvas, double-button on the item, single button click on the # canvas (which can happen if the double-button on the item causes some # other event to be handled in between when the button clicks are examined # for the canvas) $path.c bind TreeItemSentinal \ "set ::Tree::sentinal($path.c) 1" # ericm return $path } # ---------------------------------------------------------------------------- # Command Tree::configure # ---------------------------------------------------------------------------- proc Tree::configure { path args } { variable $path upvar 0 $path data set res [Widget::configure $path $args] set ch1 [expr {[Widget::hasChanged $path -deltax val] | [Widget::hasChanged $path -deltay dy] | [Widget::hasChanged $path -padx val] | [Widget::hasChanged $path -showlines val]}] set ch2 [expr {[Widget::hasChanged $path -selectbackground val] | [Widget::hasChanged $path -selectforeground val]}] if { [Widget::hasChanged $path -linesfill fill] | [Widget::hasChanged $path -linestipple stipple] } { $path.c itemconfigure line -fill $fill -stipple $stipple $path.c itemconfigure cross -foreground $fill } if { $ch1 } { _redraw_idle $path 3 } elseif { $ch2 } { _redraw_idle $path 1 } if { [Widget::hasChanged $path -height h] } { $path.c configure -height [expr {$h*$dy}] } if { [Widget::hasChanged $path -width w] } { $path.c configure -width [expr {$w*8}] } if { [Widget::hasChanged $path -redraw bool] && $bool } { set upd $data(upd,level) set data(upd,level) 0 _redraw_idle $path $upd } set force [Widget::hasChanged $path -dragendcmd dragend] DragSite::setdrag $path $path.c Tree::_init_drag_cmd $dragend $force DropSite::setdrop $path $path.c Tree::_over_cmd Tree::_drop_cmd return $res } # ---------------------------------------------------------------------------- # Command Tree::cget # ---------------------------------------------------------------------------- proc Tree::cget { path option } { return [Widget::cget $path $option] } # ---------------------------------------------------------------------------- # Command Tree::insert # ---------------------------------------------------------------------------- proc Tree::insert { path index parent node args } { variable $path upvar 0 $path data if { [info exists data($node)] } { return -code error "node \"$node\" already exists" } if { ![info exists data($parent)] } { return -code error "node \"$parent\" does not exist" } Widget::init Tree::Node $path.$node $args if { ![string compare $index "end"] } { lappend data($parent) $node } else { incr index set data($parent) [linsert $data($parent) $index $node] } set data($node) [list $parent] if { ![string compare $parent "root"] } { _redraw_idle $path 3 } elseif { [visible $path $parent] } { # parent is visible... if { [Widget::getMegawidgetOption $path.$parent -open] } { # ...and opened -> redraw whole _redraw_idle $path 3 } else { # ...and closed -> redraw cross lappend data(upd,nodes) $parent 8 _redraw_idle $path 2 } } return $node } # ---------------------------------------------------------------------------- # Command Tree::itemconfigure # ---------------------------------------------------------------------------- proc Tree::itemconfigure { path node args } { variable $path upvar 0 $path data if { ![string compare $node "root"] || ![info exists data($node)] } { return -code error "node \"$node\" does not exist" } set result [Widget::configure $path.$node $args] if { [visible $path $node] } { set lopt {} set flag 0 foreach opt {-window -image -drawcross -font -text -fill} { set flag [expr {$flag << 1}] if { [Widget::hasChanged $path.$node $opt val] } { set flag [expr {$flag | 1}] } } if { [Widget::hasChanged $path.$node -open val] } { if {[llength $data($node)] > 1} { # node have subnodes - full redraw _redraw_idle $path 3 } else { # force a redraw of the plus/minus sign set flag [expr {$flag | 8}] } } if { $data(upd,level) < 3 && $flag } { if { [set idx [lsearch $data(upd,nodes) $node]] == -1 } { lappend data(upd,nodes) $node $flag } else { incr idx set flag [expr {[lindex $data(upd,nodes) $idx] | $flag}] set data(upd,nodes) [lreplace $data(upd,nodes) $idx $idx $flag] } _redraw_idle $path 2 } } return $result } # ---------------------------------------------------------------------------- # Command Tree::itemcget # ---------------------------------------------------------------------------- proc Tree::itemcget { path node option } { # Instead of upvar'ing $path as data for this test, just directly refer to # it, as that is faster. if { ![string compare $node "root"] || \ ![info exists ::Tree::${path}($node)] } { return -code error "node \"$node\" does not exist" } return [Widget::cget $path.$node $option] } # ---------------------------------------------------------------------------- # Command Tree::bindText # ---------------------------------------------------------------------------- proc Tree::bindText { path event script } { if { $script != "" } { $path.c bind "node" $event \ "$script \[Tree::_get_node_name $path current 2\]" } else { $path.c bind "node" $event {} } } # ---------------------------------------------------------------------------- # Command Tree::bindImage # ---------------------------------------------------------------------------- proc Tree::bindImage { path event script } { if { $script != "" } { $path.c bind "img" $event \ "$script \[Tree::_get_node_name $path current 2\]" } else { $path.c bind "img" $event {} } } # ---------------------------------------------------------------------------- # Command Tree::delete # ---------------------------------------------------------------------------- proc Tree::delete { path args } { variable $path upvar 0 $path data set sel $data(selnodes) foreach lnodes $args { foreach node $lnodes { if { [string compare $node "root"] && [info exists data($node)] } { set parent [lindex $data($node) 0] set idx [lsearch $data($parent) $node] set data($parent) [lreplace $data($parent) $idx $idx] set idx [lsearch $sel $node] if { $idx >= 0 } { set sel [lreplace $sel $idx $idx] } _subdelete $path [list $node] } } } set data(selnodes) {} eval [list selection $path set] $sel _redraw_idle $path 3 } # ---------------------------------------------------------------------------- # Command Tree::move # ---------------------------------------------------------------------------- proc Tree::move { path parent node index } { variable $path upvar 0 $path data if { ![string compare $node "root"] || ![info exists data($node)] } { return -code error "node \"$node\" does not exist" } if { ![info exists data($parent)] } { return -code error "node \"$parent\" does not exist" } set p $parent while { [string compare $p "root"] } { if { ![string compare $p $node] } { return -code error "node \"$parent\" is a descendant of \"$node\"" } set p [parent $path $p] } set oldp [lindex $data($node) 0] set idx [lsearch $data($oldp) $node] set data($oldp) [lreplace $data($oldp) $idx $idx] set data($node) [concat [list $parent] [lrange $data($node) 1 end]] if { ![string compare $index "end"] } { lappend data($parent) $node } else { incr index set data($parent) [linsert $data($parent) $index $node] } if { (![string compare $oldp "root"] || ([visible $path $oldp] && [Widget::getoption $path.$oldp -open])) || (![string compare $parent "root"] || ([visible $path $parent] && [Widget::getoption $path.$parent -open])) } { _redraw_idle $path 3 } } # ---------------------------------------------------------------------------- # Command Tree::reorder # ---------------------------------------------------------------------------- proc Tree::reorder { path node neworder } { variable $path upvar 0 $path data if { ![info exists data($node)] } { return -code error "node \"$node\" does not exist" } set children [lrange $data($node) 1 end] if { [llength $children] } { set children [BWidget::lreorder $children $neworder] set data($node) [linsert $children 0 [lindex $data($node) 0]] if { [visible $path $node] && [Widget::getoption $path.$node -open] } { _redraw_idle $path 3 } } } # ---------------------------------------------------------------------------- # Command Tree::selection # ---------------------------------------------------------------------------- proc Tree::selection { path cmd args } { variable $path upvar 0 $path data switch -- $cmd { toggle { foreach node $args { if {![info exists data($node)]} { return -code error \ "$path selection toggle: Cannot toggle unknown node \"$node\"." } } foreach node $args { if {[$path selection includes $node]} { $path selection remove $node } else { $path selection add $node } } } set { foreach node $args { if {![info exists data($node)]} { return -code error \ "$path selection set: Cannot select unknown node \"$node\"." } } set data(selnodes) {} foreach node $args { if { [Widget::getoption $path.$node -selectable] } { if { [lsearch $data(selnodes) $node] == -1 } { lappend data(selnodes) $node } } } __call_selectcmd $path } add { foreach node $args { if {![info exists data($node)]} { return -code error \ "$path selection add: Cannot select unknown node \"$node\"." } } foreach node $args { if { [Widget::getoption $path.$node -selectable] } { if { [lsearch $data(selnodes) $node] == -1 } { lappend data(selnodes) $node } } } __call_selectcmd $path } range { # Here's our algorithm: # make a list of all nodes, then take the range from node1 # to node2 and select those nodes # # This works because of how this widget handles redraws: # The tree is always completely redrawn, and always from # top to bottom. So the list of visible nodes *is* the # list of nodes, and we can use that to decide which nodes # to select. if {[llength $args] != 2} { return -code error \ "wrong#args: Expected $path selection range node1 node2" } foreach {node1 node2} $args break if {![info exists data($node1)]} { return -code error \ "$path selection range: Cannot start range at unknown node \"$node1\"." } if {![info exists data($node2)]} { return -code error \ "$path selection range: Cannot end range at unknown node \"$node2\"." } set nodes {} foreach nodeItem [$path.c find withtag node] { set node [Tree::_get_node_name $path $nodeItem 2] if { [Widget::getoption $path.$node -selectable] } { lappend nodes $node } } # surles: Set the root string to the first element on the list. if {$node1 == "root"} { set node1 [lindex $nodes 0] } if {$node2 == "root"} { set node2 [lindex $nodes 0] } # Find the first visible ancestor of node1, starting with node1 while {[set index1 [lsearch -exact $nodes $node1]] == -1} { set node1 [lindex $data($node1) 0] } # Find the first visible ancestor of node2, starting with node2 while {[set index2 [lsearch -exact $nodes $node2]] == -1} { set node2 [lindex $data($node2) 0] } # If the nodes were given in backwards order, flip the # indices now if { $index2 < $index1 } { incr index1 $index2 set index2 [expr {$index1 - $index2}] set index1 [expr {$index1 - $index2}] } set data(selnodes) [lrange $nodes $index1 $index2] __call_selectcmd $path } remove { foreach node $args { if { [set idx [lsearch $data(selnodes) $node]] != -1 } { set data(selnodes) [lreplace $data(selnodes) $idx $idx] } } __call_selectcmd $path } clear { if {[llength $args] != 0} { return -code error \ "wrong#args: Expected $path selection clear" } set data(selnodes) {} __call_selectcmd $path } get { if {[llength $args] != 0} { return -code error \ "wrong#args: Expected $path selection get" } return $data(selnodes) } includes { if {[llength $args] != 1} { return -code error \ "wrong#args: Expected $path selection includes node" } set node [lindex $args 0] return [expr {[lsearch $data(selnodes) $node] != -1}] } default { return } } _redraw_idle $path 1 } proc Tree::__call_selectcmd { path } { variable $path upvar 0 $path data set selectcmd [Widget::getoption $path -selectcommand] if { ![string equal $selectcmd ""] } { lappend selectcmd $path lappend selectcmd $data(selnodes) uplevel \#0 $selectcmd } return } # ---------------------------------------------------------------------------- # Command Tree::exists # ---------------------------------------------------------------------------- proc Tree::exists { path node } { variable $path upvar 0 $path data return [info exists data($node)] } # ---------------------------------------------------------------------------- # Command Tree::visible # ---------------------------------------------------------------------------- proc Tree::visible { path node } { set idn [$path.c find withtag n:$node] return [llength $idn] } # ---------------------------------------------------------------------------- # Command Tree::parent # ---------------------------------------------------------------------------- proc Tree::parent { path node } { variable $path upvar 0 $path data if { ![info exists data($node)] } { return -code error "node \"$node\" does not exist" } return [lindex $data($node) 0] } # ---------------------------------------------------------------------------- # Command Tree::index # ---------------------------------------------------------------------------- proc Tree::index { path node } { variable $path upvar 0 $path data if { ![string compare $node "root"] || ![info exists data($node)] } { return -code error "node \"$node\" does not exist" } set parent [lindex $data($node) 0] return [expr {[lsearch $data($parent) $node] - 1}] } # ---------------------------------------------------------------------------- # Tree::find # Returns the node given a position. # findInfo @x,y ?confine? # lineNumber # ---------------------------------------------------------------------------- proc Tree::find {path findInfo {confine ""}} { if {[regexp -- {^@([0-9]+),([0-9]+)$} $findInfo match x y]} { set x [$path.c canvasx $x] set y [$path.c canvasy $y] } elseif {[regexp -- {^[0-9]+$} $findInfo lineNumber]} { set dy [Widget::getoption $path -deltay] set y [expr {$dy*($lineNumber+0.5)}] set confine "" } else { return -code error "invalid find spec \"$findInfo\"" } set found 0 set region [$path.c bbox all] if {[llength $region]} { set xi [lindex $region 0] set xs [lindex $region 2] foreach id [$path.c find overlapping $xi $y $xs $y] { set ltags [$path.c gettags $id] set item [lindex $ltags 1] if { ![string compare $item "node"] || ![string compare $item "img"] || ![string compare $item "win"] } { # item is the label or image/window of the node set node [Tree::_get_node_name $path $id 2] set found 1 break } } } if {$found} { if {[string compare $confine "confine"] == 0} { # test if x stand inside node bbox set xi [expr {[lindex [$path.c coords n:$node] 0]-[Widget::cget $path -padx]}] set xs [lindex [$path.c bbox n:$node] 2] if {$x >= $xi && $x <= $xs} { return $node } } else { return $node } } return "" } # ---------------------------------------------------------------------------- # Command Tree::line # Returns the line where is drawn a node. # ---------------------------------------------------------------------------- proc Tree::line {path node} { set item [$path.c find withtag n:$node] if {[string length $item]} { set dy [Widget::getoption $path -deltay] set y [lindex [$path.c coords $item] 1] set line [expr {int($y/$dy)}] } else { set line -1 } return $line } # ---------------------------------------------------------------------------- # Command Tree::nodes # ---------------------------------------------------------------------------- proc Tree::nodes { path node {first ""} {last ""} } { variable $path upvar 0 $path data if { ![info exists data($node)] } { return -code error "node \"$node\" does not exist" } if { ![string length $first] } { return [lrange $data($node) 1 end] } if { ![string length $last] } { return [lindex [lrange $data($node) 1 end] $first] } else { return [lrange [lrange $data($node) 1 end] $first $last] } } # Tree::visiblenodes -- # # Retrieve a list of all the nodes in a tree. # # Arguments: # path tree to retrieve nodes for. # # Results: # nodes list of nodes in the tree. proc Tree::visiblenodes { path } { variable $path upvar 0 $path data # Root is always open (?), so all of its children automatically get added # to the result, and to the stack. set st [lrange $data(root) 1 end] set result $st while { [llength $st] } { set node [lindex $st end] set st [lreplace $st end end] # Danger, danger! Using getMegawidgetOption is fragile, but much # much faster than going through cget. if { [Widget::getMegawidgetOption $path.$node -open] } { set nodes [lrange $data($node) 1 end] set result [concat $result $nodes] set st [concat $st $nodes] } } return $result } # ---------------------------------------------------------------------------- # Command Tree::see # ---------------------------------------------------------------------------- proc Tree::see { path node } { variable $path upvar 0 $path data if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } { after cancel $data(upd,afterid) _redraw_tree $path } set idn [$path.c find withtag n:$node] if { $idn != "" } { Tree::_see $path $idn } } # ---------------------------------------------------------------------------- # Command Tree::opentree # ---------------------------------------------------------------------------- # JDC: added option recursive proc Tree::opentree { path node {recursive 1} } { variable $path upvar 0 $path data if { ![string compare $node "root"] || ![info exists data($node)] } { return -code error "node \"$node\" does not exist" } _recexpand $path $node 1 $recursive [Widget::getoption $path -opencmd] _redraw_idle $path 3 } # ---------------------------------------------------------------------------- # Command Tree::closetree # ---------------------------------------------------------------------------- proc Tree::closetree { path node {recursive 1} } { variable $path upvar 0 $path data if { ![string compare $node "root"] || ![info exists data($node)] } { return -code error "node \"$node\" does not exist" } _recexpand $path $node 0 $recursive [Widget::getoption $path -closecmd] _redraw_idle $path 3 } # ---------------------------------------------------------------------------- # Command Tree::edit # ---------------------------------------------------------------------------- proc Tree::edit { path node text {verifycmd ""} {clickres 0} {select 1}} { variable _edit variable $path upvar 0 $path data if { [Widget::getoption $path -redraw] && $data(upd,afterid) != "" } { after cancel $data(upd,afterid) _redraw_tree $path } set idn [$path.c find withtag n:$node] if { $idn != "" } { Tree::_see $path $idn set oldfg [$path.c itemcget $idn -fill] set sbg [Widget::getoption $path -selectbackground] set coords [$path.c coords $idn] set x [lindex $coords 0] set y [lindex $coords 1] set bd [expr {[$path.c cget -borderwidth]+[$path.c cget -highlightthickness]}] set w [expr {[winfo width $path] - 2*$bd}] set wmax [expr {[$path.c canvasx $w]-$x}] set _edit(text) $text set _edit(wait) 0 $path.c itemconfigure $idn -fill [Widget::getoption $path -background] $path.c itemconfigure s:$node -fill {} -outline {} set frame [frame $path.edit \ -relief flat -borderwidth 0 -highlightthickness 0 \ -background [Widget::getoption $path -background]] set ent [entry $frame.edit \ -width 0 \ -relief solid \ -borderwidth 1 \ -highlightthickness 0 \ -foreground [Widget::getoption $path.$node -fill] \ -background [Widget::getoption $path -background] \ -selectforeground [Widget::getoption $path -selectforeground] \ -selectbackground $sbg \ -font [Widget::getoption $path.$node -font] \ -textvariable Tree::_edit(text)] pack $ent -ipadx 8 -anchor w set idw [$path.c create window $x $y -window $frame -anchor w] trace variable Tree::_edit(text) w "Tree::_update_edit_size $path $ent $idw $wmax" tkwait visibility $ent grab $frame BWidget::focus set $ent _update_edit_size $path $ent $idw $wmax update if { $select } { $ent selection range 0 end $ent icursor end $ent xview end } bindtags $ent [list $ent Entry] bind $ent {set Tree::_edit(wait) 0} bind $ent {set Tree::_edit(wait) 1} if { $clickres == 0 || $clickres == 1 } { bind $frame