tree.tcl

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

# ----------------------------------------------------------------------------
#  tree.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: tree.tcl,v 1.48 2003/10/20 21:23:53 damonc 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 {
    Widget::define Tree tree DragSite DropSite DynamicHelp

    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}}
	    {-padx       Int        -1      0 "%d >= -1"}
	    {-deltax     Int        -1      0 "%d >= -1"}
	    {-anchor     String     "w"     0 ""}
        }
    }

    DynamicHelp::include Tree::Node balloon

    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}}
	{-crossfill        TkResource black  0 {listbox -foreground}}
        {-redraw           Boolean 1  0}
        {-opencmd          String  "" 0}
        {-closecmd         String  "" 0}
        {-dropovermode     Flag    "wpn" 0 "wpn"}
        {-bg               Synonym -background}

        {-crossopenimage    String  ""  0}
        {-crosscloseimage   String  ""  0}
        {-crossopenbitmap   String  ""  0}
        {-crossclosebitmap  String  ""  0}
    }

    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 Tree <FocusIn>   [list after idle {BWidget::refocus %W %W.c}]
    bind Tree <Destroy>   [list Tree::_destroy %W]
    bind Tree <Configure> [list Tree::_update_scrollregion %W]


    bind TreeSentinalStart <Button-1> {
	if { $::Tree::sentinal(%W) } {
	    set ::Tree::sentinal(%W) 0
	    break
	}
    }

    bind TreeSentinalEnd <Button-1> {
	set ::Tree::sentinal(%W) 0
    }

    bind TreeFocus <Button-1> [list focus %W]

    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

    if {[Widget::cget $path -crossopenbitmap] == ""} {
        set file [file join $::BWIDGET::LIBRARY images "minus.xbm"]
        Widget::configure $path [list -crossopenbitmap @$file]
    }
    if {[Widget::cget $path -crossclosebitmap] == ""} {
        set file [file join $::BWIDGET::LIBRARY images "plus.xbm"]
        Widget::configure $path [list -crossclosebitmap @$file]
    }

    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 [list 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 <ButtonPress-1> [list Tree::_cross_event $path]

    # Added by [e-mail]
    # These allow keyboard traversal of the tree
    bind $path.c <KeyPress-Up>    [list Tree::_keynav up $path]
    bind $path.c <KeyPress-Down>  [list Tree::_keynav down $path]
    bind $path.c <KeyPress-Right> [list Tree::_keynav right $path]
    bind $path.c <KeyPress-Left>  [list Tree::_keynav left $path]
    bind $path.c <KeyPress-space> [list +Tree::_keynav space $path]

    # These allow keyboard control of the scrolling
    bind $path.c <Control-KeyPress-Up>    [list $path.c yview scroll -1 units]
    bind $path.c <Control-KeyPress-Down>  [list $path.c yview scroll  1 units]
    bind $path.c <Control-KeyPress-Left>  [list $path.c xview scroll -1 units]
    bind $path.c <Control-KeyPress-Right> [list $path.c xview scroll  1 units]
    # [e-mail]

    BWidget::bindMouseWheel $path.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

    Widget::create Tree $path

    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 <Button-1> to select the clicked node -- no reason not to, right?

    ## Bind button 1 to select the node via the _mouse_select command.
    ## This command will generate the proper <<TreeSelect>> virtual event
    ## when necessary.
    set selectcmd Tree::_mouse_select
    Tree::bindText  $path <Button-1>         [list $selectcmd $path set]
    Tree::bindImage $path <Button-1>         [list $selectcmd $path set]
    Tree::bindText  $path <Control-Button-1> [list $selectcmd $path toggle]
    Tree::bindImage $path <Control-Button-1> [list $selectcmd $path 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 <Double-Button-1> \
	[list 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
    }

    if { [Widget::hasChanged $path -crossfill fill] } {
        $path.c itemconfigure cross -foreground $fill
    }

    if {[Widget::hasChanged $path -selectfill fill]} {
	# Make sure that the full-width boxes have either all or none
	# of the standard node bindings
	if {$fill} {
	    foreach event [$path.c bind "node"] {
		$path.c bind "box" $event [$path.c bind "node" $event]
	    }
	} else {
	    foreach event [$path.c bind "node"] {
		$path.c bind "box" $event {}
	    }
	}
    }

    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

    set node [_node_name $path $node]
    set node [Widget::nextIndex $path $node]

    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 equal $index "end"]} {
        lappend data($parent) $node
    } else {
        incr index
        set data($parent) [linsert $data($parent) $index $node]
    }
    set data($node) [list $parent]

    if { [string equal $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

    set node [_node_name $path $node]
    if { [string equal $node "root"] || ![info exists data($node)] } {
        return -code error "node \"$node\" does not exist"
    }

    set result [Widget::configure $path.$node $args]

    _set_help $path $node

    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}]
            }
        }