tree.tcl

一个用TCL/TK写的用于verilog的集成编辑环境.

# ------------------------------------------------------------------------------
#  tree.tcl
#  This file is part of Unifix BWidget Toolkit
#  $Id: tree.tcl,v 1.12 1999/07/09 08:10:38 eric 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}
            {-drawcross  Enum       auto    0 {auto allways never}}
        }
    }

    Widget::tkinclude Tree canvas :cmd \
        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 {=0 ""}}
        {-deltay           Int 15 0 {=0 ""}}
        {-padx             Int 20 0 {=0 ""}}
        {-background       TkResource "" 0 listbox}
        {-selectbackground TkResource "" 0 listbox}
        {-selectforeground TkResource "" 0 listbox}
        {-width            TkResource "" 0 listbox}
        {-height           TkResource "" 0 listbox}
        {-showlines        Boolean 1  0}
        {-linesfill        TkResource black  0 {frame -background}}
        {-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 "" :cmd {-deltay -yscrollincrement}

    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 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)     ""

    set path [eval canvas $path [Widget::subcget $path :cmd] \
                  -width  [expr {[Widget::getoption $path -width]*8}] \
                  -height [expr {[Widget::getoption $path -height]*[Widget::getoption $path -deltay]}] \
                  -xscrollincrement 8]

    $path bind cross <ButtonPress-1> {Tree::_cross_event %W}
    bind $path <Configure> "Tree::_update_scrollregion $path"
    bind $path <Destroy>   "Tree::_destroy $path"

    DragSite::setdrag $path $path Tree::_init_drag_cmd [Widget::getoption $path -dragendcmd] 1
    DropSite::setdrop $path $path Tree::_over_cmd Tree::_drop_cmd 1

    rename $path ::$path:cmd
    proc ::$path { cmd args } "return \[eval Tree::\$cmd $path \$args\]"

    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:cmd itemconfigure line  -fill $fill -stipple $stipple
        $path:cmd itemconfigure cross -foreground $fill
    }

    if { $ch1 } {
        _redraw_idle $path 3
    } elseif { $ch2 } {
        _redraw_idle $path 1
    }

    if { [Widget::hasChanged $path -height h] } {
        $path:cmd configure -height [expr {$h*$dy}]
    }
    if { [Widget::hasChanged $path -width w] } {
        $path:cmd 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 Tree::_init_drag_cmd $dragend $force
    DropSite::setdrop $path $path 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::getoption $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] } {
            _redraw_idle $path 3
        } elseif { $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 } {
    variable $path
    upvar 0  $path data

    if { ![string compare $node "root"] || ![info exists data($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:cmd bind "node" $event \
            "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
    } else {
        $path:cmd bind "node" $event {}
    }
}


# ------------------------------------------------------------------------------
#  Command Tree::bindImage
# ------------------------------------------------------------------------------
proc Tree::bindImage { path event script } {
    if { $script != "" } {
        $path:cmd bind "img" $event \
            "$script \[string range \[lindex \[$path:cmd gettags current\] 1\] 2 end\]"
    } else {
        $path:cmd bind "img" $event {}
    }
}


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

    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]
                _subdelete $path [list $node]
            }
        }
    }

    set sel $data(selnodes)
    set data(selnodes) {}
    eval selection $path set $sel
    _redraw_idle $path 3
}


# ------------------------------------------------------------------------------
#  Command Tree::move
# ------------------------------------------------------------------------------
proc Tree::move { path parent node index } {
    variable $path