tree.tcl

是TCL的另外一个编译（解释）器

        $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

    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
    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 {
        set {
            set data(selnodes) {}
            foreach node $args {
                if { [info exists data($node)] } {
		    if { [Widget::getoption $path.$node -selectable] } {
			if { [lsearch $data(selnodes) $node] == -1 } {
			    lappend data(selnodes) $node
			}
		    }
                }
            }

	    if { ![string equal $data(selnodes) ""] } {
		set selectcmd [Widget::getoption $path -selectcommand]
		if { ![string equal $selectcmd ""] } {
		    lappend selectcmd $path
		    lappend selectcmd $data(selnodes)
		    uplevel \#0 $selectcmd
		}
	    }
        }
        add {
            foreach node $args {
                if { [info exists data($node)] } {
		    if { [Widget::getoption $path.$node -selectable] } {
			if { [lsearch $data(selnodes) $node] == -1 } {
			    lappend data(selnodes) $node
			}
		    }
                }
            }
        }
	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 redraw, 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.
	    foreach {node1 node2} $args break
	    if { [info exists data($node1)] && [info exists data($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]
	    }
	}
        remove {
            foreach node $args {
                if { [set idx [lsearch $data(selnodes) $node]] != -1 } {
                    set data(selnodes) [lreplace $data(selnodes) $idx $idx]
                }
            }
        }
        clear {
            set data(selnodes) {}
        }
        get {
            return $data(selnodes)
        }
        includes {
            return [expr {[lsearch $data(selnodes) $args] != -1}]
        }
        default {
            return
        }
    }
    _redraw_idle $path 1
}


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