tree.tcl

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

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

    set node [_node_name $path $node]
    if { [string equal $node "root"] || ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }
    set parent [lindex $data($node) 0]
    return [expr {[lsearch -exact $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 equal $item "node"] ||
                 [string equal $item "img"]  ||
                 [string equal $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 equal $confine "confine"]} {
            # test if x stand inside node bbox
	    set padx [_get_node_padx $path $node]
            set xi [expr {[lindex [$path.c coords n:$node] 0] - $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 node [_node_name $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

    set node [_node_name $path $node]
    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

    set node [_node_name $path $node]
    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

    set node [_node_name $path $node]
    if { [string equal $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

    set node [_node_name $path $node]
    if { [string equal $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
}


proc Tree::toggle { path node } {
    if {[$path itemcget $node -open]} {
        $path closetree $node 0
    } else {
        $path opentree $node 0
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::edit
# ----------------------------------------------------------------------------
proc Tree::edit { path node text {verifycmd ""} {clickres 0} {select 1}} {
    variable _edit
    variable $path
    upvar 0  $path data

    set node [_node_name $path $node]
    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 \
	    [list 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 <Escape> {set Tree::_edit(wait) 0}
        bind $ent <Return> {set Tree::_edit(wait) 1}
        if { $clickres == 0 || $clickres == 1 } {
            bind $frame <Button>  [list set Tree::_edit(wait) $clickres]
        }

        set ok 0
        while { !$ok } {
            tkwait variable Tree::_edit(wait)
            if { !$_edit(wait) || $verifycmd == "" ||
                 [uplevel \#0 $verifycmd [list $_edit(text)]] } {
                set ok 1
            }
        }

        trace vdelete Tree::_edit(text) w \
	    [list Tree::_update_edit_size $path $ent $idw $wmax]
        grab release $frame
        BWidget::focus release $ent
        destroy $frame
        $path.c delete $idw
        $path.c itemconfigure $idn    -fill $oldfg
        $path.c itemconfigure s:$node -fill $sbg -outline $sbg

        if { $_edit(wait) } {
            return $_edit(text)
        }
    }
    return ""
}


# ----------------------------------------------------------------------------
#  Command Tree::xview
# ----------------------------------------------------------------------------
proc Tree::xview { path args } {
    return [eval [list $path.c xview] $args]
}


# ----------------------------------------------------------------------------
#  Command Tree::yview
# ----------------------------------------------------------------------------
proc Tree::yview { path args } {
    return [eval [list $path.c yview] $args]
}


# ----------------------------------------------------------------------------
#  Command Tree::_update_edit_size
# ----------------------------------------------------------------------------
proc Tree::_update_edit_size { path entry idw wmax args } {
    set entw [winfo reqwidth $entry]
    if { $entw+8 >= $wmax } {
        $path.c itemconfigure $idw -width $wmax
    } else {
        $path.c itemconfigure $idw -width 0
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_see
# ----------------------------------------------------------------------------
proc Tree::_see { path idn } {
    set bbox [$path.c bbox $idn]
    set scrl [$path.c cget -scrollregion]

    set ymax [lindex $scrl 3]
    set dy   [$path.c cget -yscrollincrement]
    set yv   [$path yview]
    set yv0  [expr {round([lindex $yv 0]*$ymax/$dy)}]
    set yv1  [expr {round([lindex $yv 1]*$ymax/$dy)}]
    set y    [expr {int([lindex [$path.c coords $idn] 1]/$dy)}]
    if { $y < $yv0 } {
        $path.c yview scroll [expr {$y-$yv0}] units
    } elseif { $y >= $yv1 } {
        $path.c yview scroll [expr {$y-$yv1+1}] units
    }

    set xmax [lindex $scrl 2]
    set dx   [$path.c cget -xscrollincrement]
    set xv   [$path xview]
    set x0   [expr {int([lindex $bbox 0]/$dx)}]
    set xv0  [expr {round([lindex $xv 0]*$xmax/$dx)}]
    set xv1  [expr {round([lindex $xv 1]*$xmax/$dx)}]
    if { $x0 >= $xv1 || $x0 < $xv0 } {
	$path.c xview scroll [expr {$x0-$xv0}] units
    }
}


# ----------------------------------------------------------------------------
#  Command Tree::_recexpand
# ----------------------------------------------------------------------------
# JDC : added option recursive
proc Tree::_recexpand { path node expand recursive cmd } {
    variable $path
    upvar 0  $path data

    if { [Widget::getoption $path.$node -open] != $expand } {
        Widget::setoption $path.$node -open $expand
        if { $cmd != "" } {
            uplevel \#0 $cmd [list $node]
        }
    }

    if { $recursive } {
	foreach subnode [lrange $data($node) 1 end] {
	    _recexpand $path $subnode $expand $recursive $cmd
	}
    }
}