tree.tcl

The BWidget Toolkit is a high-level Widget Set for Tcl/Tk built using native Tcl/Tk 8.x namespaces.

# ----------------------------------------------------------------------------
#  Command Tree::_subdelete
# ----------------------------------------------------------------------------
proc Tree::_subdelete { path lnodes } {
    variable $path
    upvar 0  $path data

    set sel $data(selnodes)

    while { [llength $lnodes] } {
        set lsubnodes [list]
        foreach node $lnodes {
            foreach subnode [lrange $data($node) 1 end] {
                lappend lsubnodes $subnode
            }
            unset data($node)
	    set idx [lsearch -exact $sel $node]
	    if { $idx >= 0 } {
		set sel [lreplace $sel $idx $idx]
	    }
            if { [set win [Widget::getoption $path.$node -window]] != "" } {
                destroy $win
            }
            Widget::destroy $path.$node
        }
        set lnodes $lsubnodes
    }

    set data(selnodes) $sel
}


# ----------------------------------------------------------------------------
#  Command Tree::_update_scrollregion
# ----------------------------------------------------------------------------
proc Tree::_update_scrollregion { path } {
    set bd   [expr {2*([$path.c cget -borderwidth]+[$path.c cget -highlightthickness])}]
    set w    [expr {[winfo width  $path] - $bd}]
    set h    [expr {[winfo height $path] - $bd}]
    set xinc [$path.c cget -xscrollincrement]
    set yinc [$path.c cget -yscrollincrement]
    set bbox [$path.c bbox node]
    if { [llength $bbox] } {
        set xs [lindex $bbox 2]
        set ys [lindex $bbox 3]

        if { $w < $xs } {
            set w [expr {int($xs)}]
            if { [set r [expr {$w % $xinc}]] } {
                set w [expr {$w+$xinc-$r}]
            }
        }
        if { $h < $ys } {
            set h [expr {int($ys)}]
            if { [set r [expr {$h % $yinc}]] } {
                set h [expr {$h+$yinc-$r}]
            }
        }
    }

    $path.c configure -scrollregion [list 0 0 $w $h]

    if {[Widget::getoption $path -selectfill]} {
        _redraw_selection $path
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_cross_event
# ----------------------------------------------------------------------------
proc Tree::_cross_event { path } {
    variable $path
    upvar 0  $path data

    set node [Tree::_get_node_name $path current 1]
    if { [Widget::getoption $path.$node -open] } {
        Tree::itemconfigure $path $node -open 0
        if { [set cmd [Widget::getoption $path -closecmd]] != "" } {
            uplevel \#0 $cmd [list $node]
        }
    } else {
        Tree::itemconfigure $path $node -open 1
        if { [set cmd [Widget::getoption $path -opencmd]] != "" } {
            uplevel \#0 $cmd [list $node]
        }
    }
}


proc Tree::_draw_cross { path node open x y } {
    set idc [$path.c find withtag c:$node]

    if { $open } {
        set img [Widget::cget $path -crossopenimage]
        set bmp [Widget::cget $path -crossopenbitmap]
    } else {
        set img [Widget::cget $path -crosscloseimage]
        set bmp [Widget::cget $path -crossclosebitmap]
    }

    ## If we already have a cross for this node, we just adjust the image.
    if {$idc != ""} {
        if {$img == ""} {
            $path.c itemconfigure $idc -bitmap $bmp
        } else {
            $path.c itemconfigure $idc -image $img
        }
        return
    }

    ## Create a new image for the cross.  If the user has specified an
    ## image, it overrides a bitmap.
    if {$img == ""} {
        $path.c create bitmap $x $y \
            -bitmap     $bmp \
            -background [$path.c cget -background] \
            -foreground [Widget::getoption $path -crossfill] \
            -tags       [list cross c:$node] -anchor c
    } else {
        $path.c create image $x $y \
            -image      $img \
            -tags       [list cross c:$node] -anchor c
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_draw_node
# ----------------------------------------------------------------------------
proc Tree::_draw_node { path node x0 y0 deltax deltay padx showlines } {
    global   env
    variable $path
    upvar 0  $path data

    set x1 [expr {$x0+$deltax+5}]
    set y1 $y0
    if { $showlines } {
        $path.c create line $x0 $y0 $x1 $y0 \
            -fill    [Widget::getoption $path -linesfill]   \
            -stipple [Widget::getoption $path -linestipple] \
            -tags    line
    }
    $path.c create text [expr {$x1+$padx}] $y0 \
        -text   [Widget::getoption $path.$node -text] \
        -fill   [Widget::getoption $path.$node -fill] \
        -font   [Widget::getoption $path.$node -font] \
        -anchor w \
    	-tags   [Tree::_get_node_tags $path $node [list node n:$node]]
    set len [expr {[llength $data($node)] > 1}]
    set dc  [Widget::getoption $path.$node -drawcross]
    set exp [Widget::getoption $path.$node -open]

    if { $len && $exp } {
        set y1 [_draw_subnodes $path [lrange $data($node) 1 end] \
                    [expr {$x0+$deltax}] $y0 $deltax $deltay $padx $showlines]
    }

    if {![string equal $dc "never"] && ($len || [string equal $dc "allways"])} {
        _draw_cross $path $node $exp $x0 $y0
    }

    if { [set win [Widget::getoption $path.$node -window]] != "" } {
	set a [Widget::cget $path.$node -anchor]
        $path.c create window $x1 $y0 -window $win -anchor $a \
		-tags [Tree::_get_node_tags $path $node [list win i:$node]]
    } elseif { [set img [Widget::getoption $path.$node -image]] != "" } {
	set a [Widget::cget $path.$node -anchor]
        $path.c create image $x1 $y0 -image $img -anchor $a \
		-tags   [Tree::_get_node_tags $path $node [list img i:$node]]
    }
    set box [$path.c bbox n:$node i:$node]
    set id [$path.c create rect 0 [lindex $box 1] \
		[winfo screenwidth $path] [lindex $box 3] \
		-tags [Tree::_get_node_tags $path $node [list box b:$node]] \
		-fill {} -outline {}]
    $path.c lower $id

    _set_help $path $node

    return $y1
}


# ----------------------------------------------------------------------------
#  Command Tree::_draw_subnodes
# ----------------------------------------------------------------------------
proc Tree::_draw_subnodes { path nodes x0 y0 deltax deltay padx showlines } {
    set y1 $y0
    foreach node $nodes {
	set padx   [_get_node_padx $path $node]
	set deltax [_get_node_deltax $path $node]
        set yp $y1
        set y1 [_draw_node $path $node $x0 [expr {$y1+$deltay}] $deltax $deltay $padx $showlines]
    }
    if { $showlines && [llength $nodes] } {
        set id [$path.c create line $x0 $y0 $x0 [expr {$yp+$deltay}] \
                    -fill    [Widget::getoption $path -linesfill]   \
                    -stipple [Widget::getoption $path -linestipple] \
                    -tags    line]

        $path.c lower $id
    }
    return $y1
}


# ----------------------------------------------------------------------------
#  Command Tree::_update_nodes
# ----------------------------------------------------------------------------
proc Tree::_update_nodes { path } {
    global   env
    variable $path
    upvar 0  $path data

    set deltax [Widget::getoption $path -deltax]
    set padx   [Widget::getoption $path -padx]
    foreach {node flag} $data(upd,nodes) {
        set idn [$path.c find withtag "n:$node"]
        if { $idn == "" } {
            continue
        }
	set padx   [_get_node_padx $path $node]
	set deltax [_get_node_deltax $path $node]
        set c  [$path.c coords $idn]
        set x0 [expr {[lindex $c 0]-$padx}]
        set y0 [lindex $c 1]
        if { $flag & 48 } {
            # -window or -image modified
            set win  [Widget::getoption $path.$node -window]
            set img  [Widget::getoption $path.$node -image]
            set idi  [$path.c find withtag i:$node]
            set type [lindex [$path.c gettags $idi] 1]
            if { [string length $win] } {
                if { [string equal $type "win"] } {
                    $path.c itemconfigure $idi -window $win
                } else {
                    $path.c delete $idi
                    $path.c create window $x0 $y0 -window $win -anchor w \
			    -tags [Tree::_get_node_tags $path $node \
			    	[list win i:$node]]
                }
            } elseif { [string length $img] } {
                if { [string equal $type "img"] } {
                    $path.c itemconfigure $idi -image $img
                } else {
                    $path.c delete $idi
                    $path.c create image $x0 $y0 -image $img -anchor w \
			    -tags [Tree::_get_node_tags $path $node \
			    	[list img i:$node]]
                }
            } else {
                $path.c delete $idi
            }
        }

        if { $flag & 8 } {
            # -drawcross modified
            set len [expr {[llength $data($node)] > 1}]
            set dc  [Widget::getoption $path.$node -drawcross]
            set exp [Widget::getoption $path.$node -open]

            if {![string equal $dc "never"]
                && ($len || [string equal $dc "allways"])} {
                _draw_cross $path $node $exp $x0 $y0
            } else {
		set idc [$path.c find withtag c:$node]
                $path.c delete $idc
            }
        }

        if { $flag & 7 } {
            # -font, -text or -fill modified
            $path.c itemconfigure $idn \
                -text [Widget::getoption $path.$node -text] \
                -fill [Widget::getoption $path.$node -fill] \
                -font [Widget::getoption $path.$node -font]
        }
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_draw_tree
# ----------------------------------------------------------------------------
proc Tree::_draw_tree { path } {
    variable $path
    upvar 0  $path data

    $path.c delete all
    set cursor [$path.c cget -cursor]
    $path.c configure -cursor watch
    _draw_subnodes $path [lrange $data(root) 1 end] 8 \
        [expr {-[Widget::getoption $path -deltay]/2}] \
        [Widget::getoption $path -deltax] \
        [Widget::getoption $path -deltay] \
        [Widget::getoption $path -padx]   \
        [Widget::getoption $path -showlines]
    $path.c configure -cursor $cursor
}


# ----------------------------------------------------------------------------
#  Command Tree::_redraw_tree
# ----------------------------------------------------------------------------
proc Tree::_redraw_tree { path } {
    variable $path
    upvar 0  $path data

    if { [Widget::getoption $path -redraw] } {
        if { $data(upd,level) == 2 } {
            _update_nodes $path
        } elseif { $data(upd,level) == 3 } {
            _draw_tree $path
        }
        _redraw_selection $path
        _update_scrollregion $path
        set data(upd,nodes)   {}
        set data(upd,level)   0
        set data(upd,afterid) ""
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_redraw_selection
# ----------------------------------------------------------------------------
proc Tree::_redraw_selection { path } {
    variable $path
    upvar 0  $path data

    set selbg [Widget::getoption $path -selectbackground]
    set selfg [Widget::getoption $path -selectforeground]
    set fill  [Widget::getoption $path -selectfill]
    if {$fill} {
        set scroll [$path.c cget -scrollregion]
        if {[llength $scroll]} {
            set xmax [expr {[lindex $scroll 2]-1}]
        } else {
            set xmax [winfo width $path]
        }
    }
    foreach id [$path.c find withtag sel] {
        set node [Tree::_get_node_name $path $id 1]
        $path.c itemconfigure "n:$node" -fill [Widget::getoption $path.$node -fill]
    }
    $path.c delete sel
    foreach node $data(selnodes) {
        set bbox [$path.c bbox "n:$node"]
        if { [llength $bbox] } {
            if {$fill} {
		# get the image to (if any), as it may have different height
		set bbox [$path.c bbox "n:$node" "i:$node"]
                set bbox [list 0 [lindex $bbox 1] $xmax [lindex $bbox 3]]
            }
            set id [$path.c create rectangle $bbox -tags [list sel s:$node] \
			-fill $selbg -outline $selbg]
            $path.c itemconfigure "n:$node" -fill $selfg
            $path.c lower $id
        }
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_redraw_idle
# ----------------------------------------------------------------------------
proc Tree::_redraw_idle { path level } {
    variable $path
    upvar 0  $path data

    if { [Widget::getoption $path -redraw] && $data(upd,afterid) == "" } {
        set data(upd,afterid) [after idle Tree::_redraw_tree $path]
    }
    if { $level > $data(upd,level) } {
        set data(upd,level) $level
    }
    return ""
}


# ----------------------------------------------------------------------------
#  Command Tree::_init_drag_cmd
# ----------------------------------------------------------------------------