1# tree.tcl -- 2# 3# Implementation of a tree data structure for Tcl. 4# 5# Copyright (c) 1998-2000 by Ajuba Solutions. 6# 7# See the file "license.terms" for information on usage and redistribution 8# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 9# 10# RCS: @(#) $Id: tree_tcl.tcl,v 1.5 2009/06/22 18:21:59 andreas_kupries Exp $ 11 12package require Tcl 8.2 13package require struct::list 14 15namespace eval ::struct::tree { 16 # Data storage in the tree module 17 # ------------------------------- 18 # 19 # There's a lot of bits to keep track of for each tree: 20 # nodes 21 # node values 22 # node relationships 23 # 24 # It would quickly become unwieldy to try to keep these in arrays or lists 25 # within the tree namespace itself. Instead, each tree structure will get 26 # its own namespace. Each namespace contains: 27 # children array mapping nodes to their children list 28 # parent array mapping nodes to their parent node 29 # node:$node array mapping keys to values for the node $node 30 31 # counter is used to give a unique name for unnamed trees 32 variable counter 0 33 34 # Only export one command, the one used to instantiate a new tree 35 namespace export tree_tcl 36} 37 38# ::struct::tree::tree_tcl -- 39# 40# Create a new tree with a given name; if no name is given, use 41# treeX, where X is a number. 42# 43# Arguments: 44# name Optional name of the tree; if null or not given, generate one. 45# 46# Results: 47# name Name of the tree created 48 49proc ::struct::tree::tree_tcl {args} { 50 variable counter 51 52 set src {} 53 set srctype {} 54 55 switch -exact -- [llength [info level 0]] { 56 1 { 57 # Missing name, generate one. 58 incr counter 59 set name "tree${counter}" 60 } 61 2 { 62 # Standard call. New empty tree. 63 set name [lindex $args 0] 64 } 65 4 { 66 # Copy construction. 67 foreach {name as src} $args break 68 switch -exact -- $as { 69 = - := - as { 70 set srctype tree 71 } 72 deserialize { 73 set srctype serial 74 } 75 default { 76 return -code error \ 77 "wrong # args: should be \"tree ?name ?=|:=|as|deserialize source??\"" 78 } 79 } 80 } 81 default { 82 # Error. 83 return -code error \ 84 "wrong # args: should be \"tree ?name ?=|:=|as|deserialize source??\"" 85 } 86 } 87 88 # FIRST, qualify the name. 89 if {![string match "::*" $name]} { 90 # Get caller's namespace; append :: if not global namespace. 91 set ns [uplevel 1 [list namespace current]] 92 if {"::" != $ns} { 93 append ns "::" 94 } 95 96 set name "$ns$name" 97 } 98 if {[llength [info commands $name]]} { 99 return -code error \ 100 "command \"$name\" already exists, unable to create tree" 101 } 102 103 # Set up the namespace for the object, 104 # identical to the object command. 105 namespace eval $name { 106 variable rootname 107 set rootname root 108 109 # Set up root node's child list 110 variable children 111 set children(root) [list] 112 113 # Set root node's parent 114 variable parent 115 set parent(root) [list] 116 117 # Set up the node attribute mapping 118 variable attribute 119 array set attribute {} 120 121 # Set up a counter for use in creating unique node names 122 variable nextUnusedNode 123 set nextUnusedNode 1 124 125 # Set up a counter for use in creating node attribute arrays. 126 variable nextAttr 127 set nextAttr 0 128 } 129 130 # Create the command to manipulate the tree 131 interp alias {} $name {} ::struct::tree::TreeProc $name 132 133 # Automatic execution of assignment if a source 134 # is present. 135 if {$src != {}} { 136 switch -exact -- $srctype { 137 tree { 138 set code [catch {_= $name $src} msg] 139 if {$code} { 140 namespace delete $name 141 interp alias {} $name {} 142 return -code $code -errorinfo $::errorInfo -errorcode $::errorCode $msg 143 } 144 } 145 serial { 146 set code [catch {_deserialize $name $src} msg] 147 if {$code} { 148 namespace delete $name 149 interp alias {} $name {} 150 return -code $code -errorinfo $::errorInfo -errorcode $::errorCode $msg 151 } 152 } 153 default { 154 return -code error \ 155 "Internal error, illegal srctype \"$srctype\"" 156 } 157 } 158 } 159 160 # Give object to caller for use. 161 return $name 162} 163 164# ::struct::tree::prune_tcl -- 165# 166# Abort the walk script, and ignore any children of the 167# node we are currently at. 168# 169# Arguments: 170# None. 171# 172# Results: 173# None. 174# 175# Sideeffects: 176# 177# Stops the execution of the script and throws a signal to the 178# surrounding walker to go to the next node, and ignore the 179# children of the current node. 180 181proc ::struct::tree::prune_tcl {} { 182 return -code 5 183} 184 185########################## 186# Private functions follow 187 188# ::struct::tree::TreeProc -- 189# 190# Command that processes all tree object commands. 191# 192# Arguments: 193# name Name of the tree object to manipulate. 194# cmd Subcommand to invoke. 195# args Arguments for subcommand. 196# 197# Results: 198# Varies based on command to perform 199 200proc ::struct::tree::TreeProc {name {cmd ""} args} { 201 # Do minimal args checks here 202 if { [llength [info level 0]] == 2 } { 203 return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" 204 } 205 206 # Split the args into command and args components 207 set sub _$cmd 208 if { [llength [info commands ::struct::tree::$sub]] == 0 } { 209 set optlist [lsort [info commands ::struct::tree::_*]] 210 set xlist {} 211 foreach p $optlist { 212 set p [namespace tail $p] 213 lappend xlist [string range $p 1 end] 214 } 215 set optlist [linsert [join $xlist ", "] "end-1" "or"] 216 return -code error \ 217 "bad option \"$cmd\": must be $optlist" 218 } 219 220 set code [catch {uplevel 1 [linsert $args 0 ::struct::tree::$sub $name]} result] 221 222 if {$code == 1} { 223 return -errorinfo [ErrorInfoAsCaller uplevel $sub] \ 224 -errorcode $::errorCode -code error $result 225 } elseif {$code == 2} { 226 return -code $code $result 227 } 228 return $result 229} 230 231# ::struct::tree::_:= -- 232# 233# Assignment operator. Copies the source tree into the 234# destination, destroying the original information. 235# 236# Arguments: 237# name Name of the tree object we are copying into. 238# source Name of the tree object providing us with the 239# data to copy. 240# 241# Results: 242# Nothing. 243 244proc ::struct::tree::_= {name source} { 245 _deserialize $name [$source serialize] 246 return 247} 248 249# ::struct::tree::_--> -- 250# 251# Reverse assignment operator. Copies this tree into the 252# destination, destroying the original information. 253# 254# Arguments: 255# name Name of the tree object to copy 256# dest Name of the tree object we are copying to. 257# 258# Results: 259# Nothing. 260 261proc ::struct::tree::_--> {name dest} { 262 $dest deserialize [_serialize $name] 263 return 264} 265 266# ::struct::tree::_ancestors -- 267# 268# Return the list of all parent nodes of a node in a tree. 269# 270# Arguments: 271# name Name of the tree. 272# node Node to look up. 273# 274# Results: 275# parents List of parents of node $node. 276# Immediate ancestor (parent) first, 277# Root of tree (ancestor of all) last. 278 279proc ::struct::tree::_ancestors {name node} { 280 if { ![_exists $name $node] } { 281 return -code error "node \"$node\" does not exist in tree \"$name\"" 282 } 283 284 variable ${name}::parent 285 set a {} 286 while {[info exists parent($node)]} { 287 set node $parent($node) 288 if {$node == {}} break 289 lappend a $node 290 } 291 return $a 292} 293 294# ::struct::tree::_attr -- 295# 296# Return attribute data for one key and multiple nodes, possibly all. 297# 298# Arguments: 299# name Name of the tree object. 300# key Name of the attribute to retrieve. 301# 302# Results: 303# children Dictionary mapping nodes to attribute data. 304 305proc ::struct::tree::_attr {name key args} { 306 # Syntax: 307 # 308 # t attr key 309 # t attr key -nodes {nodelist} 310 # t attr key -glob nodepattern 311 # t attr key -regexp nodepattern 312 313 variable ${name}::attribute 314 315 set usage "wrong # args: should be \"[list $name] attr key ?-nodes list|-glob pattern|-regexp pattern?\"" 316 if {([llength $args] != 0) && ([llength $args] != 2)} { 317 return -code error $usage 318 } elseif {[llength $args] == 0} { 319 # This automatically restricts the list 320 # to nodes which can have the attribute 321 # in question. 322 323 set nodes [array names attribute] 324 } else { 325 # Determine a list of nodes to look at 326 # based on the chosen restriction. 327 328 foreach {mode value} $args break 329 switch -exact -- $mode { 330 -nodes { 331 # This is the only branch where we have to 332 # perform an explicit restriction to the 333 # nodes which have attributes. 334 set nodes {} 335 foreach n $value { 336 if {![info exists attribute($n)]} continue 337 lappend nodes $n 338 } 339 } 340 -glob { 341 set nodes [array names attribute $value] 342 } 343 -regexp { 344 set nodes {} 345 foreach n [array names attribute] { 346 if {![regexp -- $value $n]} continue 347 lappend nodes $n 348 } 349 } 350 default { 351 return -code error $usage 352 } 353 } 354 } 355 356 # Without possibly matching nodes 357 # the result has to be empty. 358 359 if {![llength $nodes]} { 360 return {} 361 } 362 363 # Now locate matching keys and their values. 364 365 set result {} 366 foreach n $nodes { 367 upvar ${name}::$attribute($n) data 368 if {[info exists data($key)]} { 369 lappend result $n $data($key) 370 } 371 } 372 373 return $result 374} 375 376# ::struct::tree::_deserialize -- 377# 378# Assignment operator. Copies a serialization into the 379# destination, destroying the original information. 380# 381# Arguments: 382# name Name of the tree object we are copying into. 383# serial Serialized tree to copy from. 384# 385# Results: 386# Nothing. 387 388proc ::struct::tree::_deserialize {name serial} { 389 # As we destroy the original tree as part of 390 # the copying process we don't have to deal 391 # with issues like node names from the new tree 392 # interfering with the old ... 393 394 # I. Get the serialization of the source tree 395 # and check it for validity. 396 397 CheckSerialization $serial attr p c rn 398 399 # Get all the relevant data into the scope 400 401 variable ${name}::rootname 402 variable ${name}::children 403 variable ${name}::parent 404 variable ${name}::attribute 405 variable ${name}::nextAttr 406 407 # Kill the existing parent/children information and insert the new 408 # data in their place. 409 410 foreach n [array names parent] { 411 unset parent($n) children($n) 412 } 413 array set parent [array get p] 414 array set children [array get c] 415 unset p c 416 417 set nextAttr 0 418 foreach a [array names attribute] { 419 unset ${name}::$attribute($a) 420 } 421 foreach n [array names attr] { 422 GenAttributeStorage $name $n 423 array set ${name}::$attribute($n) $attr($n) 424 } 425 426 set rootname $rn 427 428 ## Debug ## Dump internals ... 429 if {0} { 430 puts "___________________________________ $name" 431 puts $rootname 432 parray children 433 parray parent 434 parray attribute 435 puts ___________________________________ 436 } 437 return 438} 439 440# ::struct::tree::_children -- 441# 442# Return the list of children for a given node of a tree. 443# 444# Arguments: 445# name Name of the tree object. 446# node Node to look up. 447# 448# Results: 449# children List of children for the node. 450 451proc ::struct::tree::_children {name args} { 452 # args := ?-all? node ?filter cmdprefix? 453 454 # '-all' implies that not only the direct children of the 455 # node, but all their children, and so on, are returned. 456 # 457 # 'filter cmd' implies that only those nodes in the result list 458 # which pass the test 'cmd' are placed into the final result. 459 460 set usage "wrong # args: should be \"[list $name] children ?-all? node ?filter cmd?\"" 461 462 if {([llength $args] < 1) || ([llength $args] > 4)} { 463 return -code error $usage 464 } 465 if {[string equal [lindex $args 0] -all]} { 466 set all 1 467 set args [lrange $args 1 end] 468 } else { 469 set all 0 470 } 471 472 # args := node ?filter cmdprefix? 473 474 if {([llength $args] != 1) && ([llength $args] != 3)} { 475 return -code error $usage 476 } 477 if {[llength $args] == 3} { 478 foreach {node _const_ cmd} $args break 479 if {![string equal $_const_ filter] || ![llength $cmd]} { 480 return -code error $usage 481 } 482 } else { 483 set node [lindex $args 0] 484 set cmd {} 485 } 486 487 if { ![_exists $name $node] } { 488 return -code error "node \"$node\" does not exist in tree \"$name\"" 489 } 490 491 if {$all} { 492 set result [DescendantsCore $name $node] 493 } else { 494 variable ${name}::children 495 set result $children($node) 496 } 497 498 if {[llength $cmd]} { 499 lappend cmd $name 500 set result [uplevel 1 [list ::struct::list filter $result $cmd]] 501 } 502 503 return $result 504} 505 506# ::struct::tree::_cut -- 507# 508# Destroys the specified node of a tree, but not its children. 509# These children are made into children of the parent of the 510# destroyed node at the index of the destroyed node. 511# 512# Arguments: 513# name Name of the tree object. 514# node Node to look up and cut. 515# 516# Results: 517# None. 518 519proc ::struct::tree::_cut {name node} { 520 variable ${name}::rootname 521 522 if { [string equal $node $rootname] } { 523 # Can't delete the special root node 524 return -code error "cannot cut root node" 525 } 526 527 if { ![_exists $name $node] } { 528 return -code error "node \"$node\" does not exist in tree \"$name\"" 529 } 530 531 variable ${name}::parent 532 variable ${name}::children 533 534 # Locate our parent, children and our location in the parent 535 set parentNode $parent($node) 536 set childNodes $children($node) 537 538 set index [lsearch -exact $children($parentNode) $node] 539 540 # Excise this node from the parent list, 541 set newChildren [lreplace $children($parentNode) $index $index] 542 543 # Put each of the children of $node into the parent's children list, 544 # in the place of $node, and update the parent pointer of those nodes. 545 foreach child $childNodes { 546 set newChildren [linsert $newChildren $index $child] 547 set parent($child) $parentNode 548 incr index 549 } 550 set children($parentNode) $newChildren 551 552 KillNode $name $node 553 return 554} 555 556# ::struct::tree::_delete -- 557# 558# Remove a node from a tree, including all of its values. Recursively 559# removes the node's children. 560# 561# Arguments: 562# name Name of the tree. 563# node Node to delete. 564# 565# Results: 566# None. 567 568proc ::struct::tree::_delete {name node} { 569 variable ${name}::rootname 570 if { [string equal $node $rootname] } { 571 # Can't delete the special root node 572 return -code error "cannot delete root node" 573 } 574 if {![_exists $name $node]} { 575 return -code error "node \"$node\" does not exist in tree \"$name\"" 576 } 577 578 variable ${name}::children 579 variable ${name}::parent 580 581 # Remove this node from its parent's children list 582 set parentNode $parent($node) 583 set index [lsearch -exact $children($parentNode) $node] 584 ldelete children($parentNode) $index 585 586 # Yes, we could use the stack structure implemented in ::struct::stack, 587 # but it's slower than inlining it. Since we don't need a sophisticated 588 # stack, don't bother. 589 set st [list] 590 foreach child $children($node) { 591 lappend st $child 592 } 593 594 KillNode $name $node 595 596 while {[llength $st] > 0} { 597 set node [lindex $st end] 598 ldelete st end 599 foreach child $children($node) { 600 lappend st $child 601 } 602 603 KillNode $name $node 604 } 605 return 606} 607 608# ::struct::tree::_depth -- 609# 610# Return the depth (distance from the root node) of a given node. 611# 612# Arguments: 613# name Name of the tree. 614# node Node to find. 615# 616# Results: 617# depth Number of steps from node to the root node. 618 619proc ::struct::tree::_depth {name node} { 620 if { ![_exists $name $node] } { 621 return -code error "node \"$node\" does not exist in tree \"$name\"" 622 } 623 variable ${name}::parent 624 variable ${name}::rootname 625 set depth 0 626 while { ![string equal $node $rootname] } { 627 incr depth 628 set node $parent($node) 629 } 630 return $depth 631} 632 633# ::struct::tree::_descendants -- 634# 635# Return the list containing all descendants of a node in a tree. 636# 637# Arguments: 638# name Name of the tree. 639# node Node to look at. 640# 641# Results: 642# desc (filtered) List of nodes descending from 'node'. 643 644proc ::struct::tree::_descendants {name node args} { 645 # children -all sucessor, allows filtering. 646 647 set usage "wrong # args: should be \"[list $name] descendants node ?filter cmd?\"" 648 649 if {[llength $args] > 2} { 650 return -code error $usage 651 } elseif {[llength $args] == 2} { 652 foreach {_const_ cmd} $args break 653 if {![string equal $_const_ filter] || ![llength $cmd]} { 654 return -code error $usage 655 } 656 } else { 657 set cmd {} 658 } 659 660 if { ![_exists $name $node] } { 661 return -code error "node \"$node\" does not exist in tree \"$name\"" 662 } 663 664 set result [DescendantsCore $name $node] 665 666 if {[llength $cmd]} { 667 lappend cmd $name 668 set result [uplevel 1 [list ::struct::list filter $result $cmd]] 669 } 670 671 return $result 672} 673 674proc ::struct::tree::DescendantsCore {name node} { 675 # CORE for listing of node descendants. 676 # No checks ... 677 # No filtering ... 678 679 variable ${name}::children 680 681 # New implementation. Instead of keeping a second, and explicit, 682 # list of pending nodes to shift through (= copying of array data 683 # around), we reuse the result list for that, using a counter and 684 # direct access to list elements to keep track of what nodes have 685 # not been handled yet. This eliminates a whole lot of array 686 # copying within the list implementation in the Tcl core. The 687 # result is unchanged, i.e. the nodes are in the same order as 688 # before. 689 690 set result $children($node) 691 set at 0 692 693 while {$at < [llength $result]} { 694 set n [lindex $result $at] 695 incr at 696 foreach c $children($n) { 697 lappend result $c 698 } 699 } 700 701 return $result 702} 703 704# ::struct::tree::_destroy -- 705# 706# Destroy a tree, including its associated command and data storage. 707# 708# Arguments: 709# name Name of the tree to destroy. 710# 711# Results: 712# None. 713 714proc ::struct::tree::_destroy {name} { 715 namespace delete $name 716 interp alias {} $name {} 717} 718 719# ::struct::tree::_exists -- 720# 721# Test for existence of a given node in a tree. 722# 723# Arguments: 724# name Name of the tree to query. 725# node Node to look for. 726# 727# Results: 728# 1 if the node exists, 0 else. 729 730proc ::struct::tree::_exists {name node} { 731 return [info exists ${name}::parent($node)] 732} 733 734# ::struct::tree::_get -- 735# 736# Get a keyed value from a node in a tree. 737# 738# Arguments: 739# name Name of the tree. 740# node Node to query. 741# key Key to lookup. 742# 743# Results: 744# value Value associated with the key given. 745 746proc ::struct::tree::_get {name node key} { 747 if {![_exists $name $node]} { 748 return -code error "node \"$node\" does not exist in tree \"$name\"" 749 } 750 751 variable ${name}::attribute 752 if {![info exists attribute($node)]} { 753 # No attribute data for this node, key has to be invalid. 754 return -code error "invalid key \"$key\" for node \"$node\"" 755 } 756 757 upvar ${name}::$attribute($node) data 758 if {![info exists data($key)]} { 759 return -code error "invalid key \"$key\" for node \"$node\"" 760 } 761 return $data($key) 762} 763 764# ::struct::tree::_getall -- 765# 766# Get a serialized list of key/value pairs from a node in a tree. 767# 768# Arguments: 769# name Name of the tree. 770# node Node to query. 771# 772# Results: 773# value A serialized list of key/value pairs. 774 775proc ::struct::tree::_getall {name node {pattern *}} { 776 if {![_exists $name $node]} { 777 return -code error "node \"$node\" does not exist in tree \"$name\"" 778 } 779 780 variable ${name}::attribute 781 if {![info exists attribute($node)]} { 782 # No attributes ... 783 return {} 784 } 785 786 upvar ${name}::$attribute($node) data 787 return [array get data $pattern] 788} 789 790# ::struct::tree::_height -- 791# 792# Return the height (distance from the given node to its deepest child) 793# 794# Arguments: 795# name Name of the tree. 796# node Node we wish to know the height for.. 797# 798# Results: 799# height Distance to deepest child of the node. 800 801proc ::struct::tree::_height {name node} { 802 if { ![_exists $name $node] } { 803 return -code error "node \"$node\" does not exist in tree \"$name\"" 804 } 805 806 variable ${name}::children 807 variable ${name}::parent 808 809 if {[llength $children($node)] == 0} { 810 # No children, is a leaf, height is 0. 811 return 0 812 } 813 814 # New implementation. We iteratively compute the height for each 815 # node under the specified one, from the bottom up. The previous 816 # implementation, using recursion will fail if the encountered 817 # subtree has a height greater than the currently set recursion 818 # limit. 819 820 array set h {} 821 822 # NOTE: Check out if a for loop doing direct access, i.e. without 823 # list reversal, is faster. 824 825 foreach n [struct::list reverse [DescendantsCore $name $node]] { 826 # Height of leafs 827 if {![llength $children($n)]} {set h($n) 0} 828 829 # Height of our parent is max of our and previous height. 830 set p $parent($n) 831 if {![info exists h($p)] || ($h($n) >= $h($p))} { 832 set h($p) [expr {$h($n) + 1}] 833 } 834 } 835 836 # NOTE: Check out how much we gain by caching the result. 837 # For all nodes we have this computed. Use cache here 838 # as well to cut the inspection of descendants down. 839 # This may degenerate into a recursive solution again 840 # however. 841 842 return $h($node) 843} 844 845# ::struct::tree::_keys -- 846# 847# Get a list of keys from a node in a tree. 848# 849# Arguments: 850# name Name of the tree. 851# node Node to query. 852# 853# Results: 854# value A serialized list of key/value pairs. 855 856proc ::struct::tree::_keys {name node {pattern *}} { 857 if {![_exists $name $node]} { 858 return -code error "node \"$node\" does not exist in tree \"$name\"" 859 } 860 861 variable ${name}::attribute 862 if {![info exists attribute($node)]} { 863 # No attribute data for this node. 864 return {} 865 } 866 867 upvar ${name}::$attribute($node) data 868 return [array names data $pattern] 869} 870 871# ::struct::tree::_keyexists -- 872# 873# Test for existence of a given key for a node in a tree. 874# 875# Arguments: 876# name Name of the tree. 877# node Node to query. 878# key Key to lookup. 879# 880# Results: 881# 1 if the key exists, 0 else. 882 883proc ::struct::tree::_keyexists {name node key} { 884 if {![_exists $name $node]} { 885 return -code error "node \"$node\" does not exist in tree \"$name\"" 886 } 887 888 variable ${name}::attribute 889 if {![info exists attribute($node)]} { 890 # No attribute data for this node, key cannot exist 891 return 0 892 } 893 894 upvar ${name}::$attribute($node) data 895 return [info exists data($key)] 896} 897 898# ::struct::tree::_index -- 899# 900# Determine the index of node with in its parent's list of children. 901# 902# Arguments: 903# name Name of the tree. 904# node Node to look up. 905# 906# Results: 907# index The index of the node in its parent 908 909proc ::struct::tree::_index {name node} { 910 variable ${name}::rootname 911 if { [string equal $node $rootname] } { 912 # The special root node has no parent, thus no index in it either. 913 return -code error "cannot determine index of root node" 914 } 915 916 if { ![_exists $name $node] } { 917 return -code error "node \"$node\" does not exist in tree \"$name\"" 918 } 919 920 variable ${name}::children 921 variable ${name}::parent 922 923 # Locate the parent and ourself in its list of children 924 set parentNode $parent($node) 925 926 return [lsearch -exact $children($parentNode) $node] 927} 928 929# ::struct::tree::_insert -- 930# 931# Add a node to a tree; if the node(s) specified already exist, they 932# will be moved to the given location. 933# 934# Arguments: 935# name Name of the tree. 936# parentNode Parent to add the node to. 937# index Index at which to insert. 938# args Node(s) to insert. If none is given, the routine 939# will insert a single node with a unique name. 940# 941# Results: 942# nodes List of nodes inserted. 943 944proc ::struct::tree::_insert {name parentNode index args} { 945 if { [llength $args] == 0 } { 946 # No node name was given; generate a unique one 947 set args [list [GenerateUniqueNodeName $name]] 948 } 949 if { ![_exists $name $parentNode] } { 950 return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" 951 } 952 953 variable ${name}::parent 954 variable ${name}::children 955 variable ${name}::rootname 956 957 # Make sure the index is numeric 958 959 if {[string equal $index "end"]} { 960 set index [llength $children($parentNode)] 961 } elseif {[regexp {^end-([0-9]+)$} $index -> n]} { 962 set index [expr {[llength $children($parentNode)] - $n}] 963 } 964 965 foreach node $args { 966 if {[_exists $name $node] } { 967 # Move the node to its new home 968 if { [string equal $node $rootname] } { 969 return -code error "cannot move root node" 970 } 971 972 # Cannot make a node its own descendant (I'm my own grandpa...) 973 set ancestor $parentNode 974 while { ![string equal $ancestor $rootname] } { 975 if { [string equal $ancestor $node] } { 976 return -code error "node \"$node\" cannot be its own descendant" 977 } 978 set ancestor $parent($ancestor) 979 } 980 # Remove this node from its parent's children list 981 set oldParent $parent($node) 982 set ind [lsearch -exact $children($oldParent) $node] 983 ldelete children($oldParent) $ind 984 985 # If the node is moving within its parent, and its old location 986 # was before the new location, decrement the new location, so that 987 # it gets put in the right spot 988 if { [string equal $oldParent $parentNode] && $ind < $index } { 989 incr index -1 990 } 991 } else { 992 # Set up the new node 993 set children($node) [list] 994 } 995 996 # Add this node to its parent's children list 997 set children($parentNode) [linsert $children($parentNode) $index $node] 998 999 # Update the parent pointer for this node 1000 set parent($node) $parentNode 1001 incr index 1002 } 1003 1004 return $args 1005} 1006 1007# ::struct::tree::_isleaf -- 1008# 1009# Return whether the given node of a tree is a leaf or not. 1010# 1011# Arguments: 1012# name Name of the tree object. 1013# node Node to look up. 1014# 1015# Results: 1016# isleaf True if the node is a leaf; false otherwise. 1017 1018proc ::struct::tree::_isleaf {name node} { 1019 if { ![_exists $name $node] } { 1020 return -code error "node \"$node\" does not exist in tree \"$name\"" 1021 } 1022 1023 variable ${name}::children 1024 return [expr {[llength $children($node)] == 0}] 1025} 1026 1027# ::struct::tree::_move -- 1028# 1029# Move a node (and all its subnodes) from where ever it is to a new 1030# location in the tree. 1031# 1032# Arguments: 1033# name Name of the tree 1034# parentNode Parent to add the node to. 1035# index Index at which to insert. 1036# node Node to move; the node must exist in the tree. 1037# args Additional nodes to move; these nodes must exist 1038# in the tree. 1039# 1040# Results: 1041# None. 1042 1043proc ::struct::tree::_move {name parentNode index node args} { 1044 set args [linsert $args 0 $node] 1045 1046 # Can only move a node to a real location in the tree 1047 if { ![_exists $name $parentNode] } { 1048 return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" 1049 } 1050 1051 variable ${name}::parent 1052 variable ${name}::children 1053 variable ${name}::rootname 1054 1055 # Make sure the index is numeric 1056 1057 if {[string equal $index "end"]} { 1058 set index [llength $children($parentNode)] 1059 } elseif {[regexp {^end-([0-9]+)$} $index -> n]} { 1060 set index [expr {[llength $children($parentNode)] - $n}] 1061 } 1062 1063 # Validate all nodes to move before trying to move any. 1064 foreach node $args { 1065 if { [string equal $node $rootname] } { 1066 return -code error "cannot move root node" 1067 } 1068 1069 # Can only move real nodes 1070 if { ![_exists $name $node] } { 1071 return -code error "node \"$node\" does not exist in tree \"$name\"" 1072 } 1073 1074 # Cannot move a node to be a descendant of itself 1075 set ancestor $parentNode 1076 while { ![string equal $ancestor $rootname] } { 1077 if { [string equal $ancestor $node] } { 1078 return -code error "node \"$node\" cannot be its own descendant" 1079 } 1080 set ancestor $parent($ancestor) 1081 } 1082 } 1083 1084 # Remove all nodes from their current parent's children list 1085 foreach node $args { 1086 set oldParent $parent($node) 1087 set ind [lsearch -exact $children($oldParent) $node] 1088 1089 ldelete children($oldParent) $ind 1090 1091 # Update the nodes parent value 1092 set parent($node) $parentNode 1093 } 1094 1095 # Add all nodes to their new parent's children list 1096 set children($parentNode) \ 1097 [eval [list linsert $children($parentNode) $index] $args] 1098 1099 return 1100} 1101 1102# ::struct::tree::_next -- 1103# 1104# Return the right sibling for a given node of a tree. 1105# 1106# Arguments: 1107# name Name of the tree object. 1108# node Node to retrieve right sibling for. 1109# 1110# Results: 1111# sibling The right sibling for the node, or null if node was 1112# the rightmost child of its parent. 1113 1114proc ::struct::tree::_next {name node} { 1115 # The 'root' has no siblings. 1116 variable ${name}::rootname 1117 if { [string equal $node $rootname] } { 1118 return {} 1119 } 1120 1121 if { ![_exists $name $node] } { 1122 return -code error "node \"$node\" does not exist in tree \"$name\"" 1123 } 1124 1125 # Locate the parent and our place in its list of children. 1126 variable ${name}::parent 1127 variable ${name}::children 1128 1129 set parentNode $parent($node) 1130 set index [lsearch -exact $children($parentNode) $node] 1131 1132 # Go to the node to the right and return its name. 1133 return [lindex $children($parentNode) [incr index]] 1134} 1135 1136# ::struct::tree::_numchildren -- 1137# 1138# Return the number of immediate children for a given node of a tree. 1139# 1140# Arguments: 1141# name Name of the tree object. 1142# node Node to look up. 1143# 1144# Results: 1145# numchildren Number of immediate children for the node. 1146 1147proc ::struct::tree::_numchildren {name node} { 1148 if { ![_exists $name $node] } { 1149 return -code error "node \"$node\" does not exist in tree \"$name\"" 1150 } 1151 1152 variable ${name}::children 1153 return [llength $children($node)] 1154} 1155 1156# ::struct::tree::_nodes -- 1157# 1158# Return a list containing all nodes known to the tree. 1159# 1160# Arguments: 1161# name Name of the tree object. 1162# 1163# Results: 1164# nodes List of nodes in the tree. 1165 1166proc ::struct::tree::_nodes {name} { 1167 variable ${name}::children 1168 return [array names children] 1169} 1170 1171# ::struct::tree::_parent -- 1172# 1173# Return the name of the parent node of a node in a tree. 1174# 1175# Arguments: 1176# name Name of the tree. 1177# node Node to look up. 1178# 1179# Results: 1180# parent Parent of node $node 1181 1182proc ::struct::tree::_parent {name node} { 1183 if { ![_exists $name $node] } { 1184 return -code error "node \"$node\" does not exist in tree \"$name\"" 1185 } 1186 # FRINK: nocheck 1187 return [set ${name}::parent($node)] 1188} 1189 1190# ::struct::tree::_previous -- 1191# 1192# Return the left sibling for a given node of a tree. 1193# 1194# Arguments: 1195# name Name of the tree object. 1196# node Node to look up. 1197# 1198# Results: 1199# sibling The left sibling for the node, or null if node was 1200# the leftmost child of its parent. 1201 1202proc ::struct::tree::_previous {name node} { 1203 # The 'root' has no siblings. 1204 variable ${name}::rootname 1205 if { [string equal $node $rootname] } { 1206 return {} 1207 } 1208 1209 if { ![_exists $name $node] } { 1210 return -code error "node \"$node\" does not exist in tree \"$name\"" 1211 } 1212 1213 # Locate the parent and our place in its list of children. 1214 variable ${name}::parent 1215 variable ${name}::children 1216 1217 set parentNode $parent($node) 1218 set index [lsearch -exact $children($parentNode) $node] 1219 1220 # Go to the node to the right and return its name. 1221 return [lindex $children($parentNode) [incr index -1]] 1222} 1223 1224# ::struct::tree::_rootname -- 1225# 1226# Query or change the name of the root node. 1227# 1228# Arguments: 1229# name Name of the tree. 1230# 1231# Results: 1232# The name of the root node 1233 1234proc ::struct::tree::_rootname {name} { 1235 variable ${name}::rootname 1236 return $rootname 1237} 1238 1239# ::struct::tree::_rename -- 1240# 1241# Change the name of any node. 1242# 1243# Arguments: 1244# name Name of the tree. 1245# node Name of node to be renamed 1246# newname New name for the node. 1247# 1248# Results: 1249# The new name of the node. 1250 1251proc ::struct::tree::_rename {name node newname} { 1252 if { ![_exists $name $node] } { 1253 return -code error "node \"$node\" does not exist in tree \"$name\"" 1254 } 1255 if {[_exists $name $newname]} { 1256 return -code error "unable to rename node to \"$newname\",\ 1257 node of that name already present in the tree \"$name\"" 1258 } 1259 1260 set oldname $node 1261 1262 # Perform the rename in the internal 1263 # data structures. 1264 1265 variable ${name}::rootname 1266 variable ${name}::children 1267 variable ${name}::parent 1268 variable ${name}::attribute 1269 1270 set children($newname) $children($oldname) 1271 unset children($oldname) 1272 set parent($newname) $parent($oldname) 1273 unset parent($oldname) 1274 1275 foreach c $children($newname) { 1276 set parent($c) $newname 1277 } 1278 1279 if {[string equal $oldname $rootname]} { 1280 set rootname $newname 1281 } else { 1282 set p $parent($newname) 1283 set pos [lsearch -exact $children($p) $oldname] 1284 lset children($p) $pos $newname 1285 } 1286 1287 if {[info exists attribute($oldname)]} { 1288 set attribute($newname) $attribute($oldname) 1289 unset attribute($oldname) 1290 } 1291 1292 return $newname 1293} 1294 1295# ::struct::tree::_serialize -- 1296# 1297# Serialize a tree object (partially) into a transportable value. 1298# 1299# Arguments: 1300# name Name of the tree. 1301# node Root node of the serialized tree. 1302# 1303# Results: 1304# A list structure describing the part of the tree which was serialized. 1305 1306proc ::struct::tree::_serialize {name args} { 1307 if {[llength $args] > 1} { 1308 return -code error \ 1309 "wrong # args: should be \"[list $name] serialize ?node?\"" 1310 } elseif {[llength $args] == 1} { 1311 set node [lindex $args 0] 1312 1313 if {![_exists $name $node]} { 1314 return -code error "node \"$node\" does not exist in tree \"$name\"" 1315 } 1316 } else { 1317 variable ${name}::rootname 1318 set node $rootname 1319 } 1320 1321 set tree [list] 1322 Serialize $name $node tree 1323 return $tree 1324} 1325 1326# ::struct::tree::_set -- 1327# 1328# Set or get a value for a node in a tree. 1329# 1330# Arguments: 1331# name Name of the tree. 1332# node Node to modify or query. 1333# args Optional argument specifying a value. 1334# 1335# Results: 1336# val Value associated with the given key of the given node 1337 1338proc ::struct::tree::_set {name node key args} { 1339 if {[llength $args] > 1} { 1340 return -code error "wrong # args: should be \"$name set node key\ 1341 ?value?\"" 1342 } 1343 if {![_exists $name $node]} { 1344 return -code error "node \"$node\" does not exist in tree \"$name\"" 1345 } 1346 1347 # Process the arguments ... 1348 1349 if {[llength $args] > 0} { 1350 # Setting the value. This may have to create 1351 # the attribute array for this particular 1352 # node 1353 1354 variable ${name}::attribute 1355 if {![info exists attribute($node)]} { 1356 # No attribute data for this node, 1357 # so create it as we need it now. 1358 GenAttributeStorage $name $node 1359 } 1360 upvar ${name}::$attribute($node) data 1361 1362 return [set data($key) [lindex $args end]] 1363 } else { 1364 # Getting the value 1365 1366 return [_get $name $node $key] 1367 } 1368} 1369 1370# ::struct::tree::_append -- 1371# 1372# Append a value for a node in a tree. 1373# 1374# Arguments: 1375# name Name of the tree. 1376# node Node to modify. 1377# key Name of attribute to modify. 1378# value Value to append 1379# 1380# Results: 1381# val Value associated with the given key of the given node 1382 1383proc ::struct::tree::_append {name node key value} { 1384 if {![_exists $name $node]} { 1385 return -code error "node \"$node\" does not exist in tree \"$name\"" 1386 } 1387 1388 variable ${name}::attribute 1389 if {![info exists attribute($node)]} { 1390 # No attribute data for this node, 1391 # so create it as we need it. 1392 GenAttributeStorage $name $node 1393 } 1394 1395 upvar ${name}::$attribute($node) data 1396 return [append data($key) $value] 1397} 1398 1399# ::struct::tree::_lappend -- 1400# 1401# lappend a value for a node in a tree. 1402# 1403# Arguments: 1404# name Name of the tree. 1405# node Node to modify or query. 1406# key Name of attribute to modify. 1407# value Value to append 1408# 1409# Results: 1410# val Value associated with the given key of the given node 1411 1412proc ::struct::tree::_lappend {name node key value} { 1413 if {![_exists $name $node]} { 1414 return -code error "node \"$node\" does not exist in tree \"$name\"" 1415 } 1416 1417 variable ${name}::attribute 1418 if {![info exists attribute($node)]} { 1419 # No attribute data for this node, 1420 # so create it as we need it. 1421 GenAttributeStorage $name $node 1422 } 1423 1424 upvar ${name}::$attribute($node) data 1425 return [lappend data($key) $value] 1426} 1427 1428# ::struct::tree::_leaves -- 1429# 1430# Return a list containing all leaf nodes known to the tree. 1431# 1432# Arguments: 1433# name Name of the tree object. 1434# 1435# Results: 1436# nodes List of leaf nodes in the tree. 1437 1438proc ::struct::tree::_leaves {name} { 1439 variable ${name}::children 1440 1441 set res {} 1442 foreach n [array names children] { 1443 if {[llength $children($n)]} continue 1444 lappend res $n 1445 } 1446 return $res 1447} 1448 1449# ::struct::tree::_size -- 1450# 1451# Return the number of descendants of a given node. The default node 1452# is the special root node. 1453# 1454# Arguments: 1455# name Name of the tree. 1456# node Optional node to start counting from (default is root). 1457# 1458# Results: 1459# size Number of descendants of the node. 1460 1461proc ::struct::tree::_size {name args} { 1462 variable ${name}::rootname 1463 if {[llength $args] > 1} { 1464 return -code error \ 1465 "wrong # args: should be \"[list $name] size ?node?\"" 1466 } elseif {[llength $args] == 1} { 1467 set node [lindex $args 0] 1468 1469 if { ![_exists $name $node] } { 1470 return -code error "node \"$node\" does not exist in tree \"$name\"" 1471 } 1472 } else { 1473 # If the node is the root, we can do the cheap thing and just count the 1474 # number of nodes (excluding the root node) that we have in the tree with 1475 # array size. 1476 1477 return [expr {[array size ${name}::parent] - 1}] 1478 } 1479 1480 # If the node is the root, we can do the cheap thing and just count the 1481 # number of nodes (excluding the root node) that we have in the tree with 1482 # array size. 1483 1484 if { [string equal $node $rootname] } { 1485 return [expr {[array size ${name}::parent] - 1}] 1486 } 1487 1488 # Otherwise we have to do it the hard way and do a full tree search 1489 variable ${name}::children 1490 set size 0 1491 set st [list ] 1492 foreach child $children($node) { 1493 lappend st $child 1494 } 1495 while { [llength $st] > 0 } { 1496 set node [lindex $st end] 1497 ldelete st end 1498 incr size 1499 foreach child $children($node) { 1500 lappend st $child 1501 } 1502 } 1503 return $size 1504} 1505 1506# ::struct::tree::_splice -- 1507# 1508# Add a node to a tree, making a range of children from the given 1509# parent children of the new node. 1510# 1511# Arguments: 1512# name Name of the tree. 1513# parentNode Parent to add the node to. 1514# from Index at which to insert. 1515# to Optional end of the range of children to replace. 1516# Defaults to 'end'. 1517# args Optional node name; if given, must be unique. If not 1518# given, a unique name will be generated. 1519# 1520# Results: 1521# node Name of the node added to the tree. 1522 1523proc ::struct::tree::_splice {name parentNode from {to end} args} { 1524 1525 if { ![_exists $name $parentNode] } { 1526 return -code error "node \"$parentNode\" does not exist in tree \"$name\"" 1527 } 1528 1529 if { [llength $args] == 0 } { 1530 # No node name given; generate a unique node name 1531 set node [GenerateUniqueNodeName $name] 1532 } else { 1533 set node [lindex $args 0] 1534 } 1535 1536 if { [_exists $name $node] } { 1537 return -code error "node \"$node\" already exists in tree \"$name\"" 1538 } 1539 1540 variable ${name}::children 1541 variable ${name}::parent 1542 1543 if {[string equal $from "end"]} { 1544 set from [expr {[llength $children($parentNode)] - 1}] 1545 } elseif {[regexp {^end-([0-9]+)$} $from -> n]} { 1546 set from [expr {[llength $children($parentNode)] - 1 - $n}] 1547 } 1548 if {[string equal $to "end"]} { 1549 set to [expr {[llength $children($parentNode)] - 1}] 1550 } elseif {[regexp {^end-([0-9]+)$} $to -> n]} { 1551 set to [expr {[llength $children($parentNode)] - 1 - $n}] 1552 } 1553 1554 # Save the list of children that are moving 1555 set moveChildren [lrange $children($parentNode) $from $to] 1556 1557 # Remove those children from the parent 1558 ldelete children($parentNode) $from $to 1559 1560 # Add the new node 1561 _insert $name $parentNode $from $node 1562 1563 # Move the children 1564 set children($node) $moveChildren 1565 foreach child $moveChildren { 1566 set parent($child) $node 1567 } 1568 1569 return $node 1570} 1571 1572# ::struct::tree::_swap -- 1573# 1574# Swap two nodes in a tree. 1575# 1576# Arguments: 1577# name Name of the tree. 1578# node1 First node to swap. 1579# node2 Second node to swap. 1580# 1581# Results: 1582# None. 1583 1584proc ::struct::tree::_swap {name node1 node2} { 1585 # Can't swap the magic root node 1586 variable ${name}::rootname 1587 if {[string equal $node1 $rootname] || [string equal $node2 $rootname]} { 1588 return -code error "cannot swap root node" 1589 } 1590 1591 # Can only swap two real nodes 1592 if {![_exists $name $node1]} { 1593 return -code error "node \"$node1\" does not exist in tree \"$name\"" 1594 } 1595 if {![_exists $name $node2]} { 1596 return -code error "node \"$node2\" does not exist in tree \"$name\"" 1597 } 1598 1599 # Can't swap a node with itself 1600 if {[string equal $node1 $node2]} { 1601 return -code error "cannot swap node \"$node1\" with itself" 1602 } 1603 1604 # Swapping nodes means swapping their labels and values 1605 variable ${name}::children 1606 variable ${name}::parent 1607 1608 set parent1 $parent($node1) 1609 set parent2 $parent($node2) 1610 1611 # Replace node1 with node2 in node1's parent's children list, and 1612 # node2 with node1 in node2's parent's children list 1613 set i1 [lsearch -exact $children($parent1) $node1] 1614 set i2 [lsearch -exact $children($parent2) $node2] 1615 1616 lset children($parent1) $i1 $node2 1617 lset children($parent2) $i2 $node1 1618 1619 # Make node1 the parent of node2's children, and vis versa 1620 foreach child $children($node2) { 1621 set parent($child) $node1 1622 } 1623 foreach child $children($node1) { 1624 set parent($child) $node2 1625 } 1626 1627 # Swap the children lists 1628 set children1 $children($node1) 1629 set children($node1) $children($node2) 1630 set children($node2) $children1 1631 1632 if { [string equal $node1 $parent2] } { 1633 set parent($node1) $node2 1634 set parent($node2) $parent1 1635 } elseif { [string equal $node2 $parent1] } { 1636 set parent($node1) $parent2 1637 set parent($node2) $node1 1638 } else { 1639 set parent($node1) $parent2 1640 set parent($node2) $parent1 1641 } 1642 1643 return 1644} 1645 1646# ::struct::tree::_unset -- 1647# 1648# Remove a keyed value from a node. 1649# 1650# Arguments: 1651# name Name of the tree. 1652# node Node to modify. 1653# key Name of attribute to unset. 1654# 1655# Results: 1656# None. 1657 1658proc ::struct::tree::_unset {name node key} { 1659 if {![_exists $name $node]} { 1660 return -code error "node \"$node\" does not exist in tree \"$name\"" 1661 } 1662 1663 variable ${name}::attribute 1664 if {![info exists attribute($node)]} { 1665 # No attribute data for this node, 1666 # nothing to do. 1667 return 1668 } 1669 1670 upvar ${name}::$attribute($node) data 1671 catch {unset data($key)} 1672 1673 if {[array size data] == 0} { 1674 # No attributes stored for this node, squash the whole array. 1675 unset attribute($node) 1676 unset data 1677 } 1678 return 1679} 1680 1681# ::struct::tree::_walk -- 1682# 1683# Walk a tree using a pre-order depth or breadth first 1684# search. Pre-order DFS is the default. At each node that is visited, 1685# a command will be called with the name of the tree and the node. 1686# 1687# Arguments: 1688# name Name of the tree. 1689# node Node at which to start. 1690# args Optional additional arguments specifying the type and order of 1691# the tree walk, and the command to execute at each node. 1692# Format is 1693# ?-type {bfs|dfs}? ?-order {pre|post|in|both}? a n script 1694# 1695# Results: 1696# None. 1697 1698proc ::struct::tree::_walk {name node args} { 1699 set usage "$name walk node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? loopvar script" 1700 1701 if {[llength $args] > 7 || [llength $args] < 2} { 1702 return -code error "wrong # args: should be \"$usage\"" 1703 } 1704 1705 if { ![_exists $name $node] } { 1706 return -code error "node \"$node\" does not exist in tree \"$name\"" 1707 } 1708 1709 set args [WalkOptions $args 2 $usage] 1710 # Remainder is 'a n script' 1711 1712 foreach {loopvariables script} $args break 1713 1714 if {[llength $loopvariables] > 2} { 1715 return -code error "too many loop variables, at most two allowed" 1716 } elseif {[llength $loopvariables] == 2} { 1717 foreach {avar nvar} $loopvariables break 1718 } else { 1719 set nvar [lindex $loopvariables 0] 1720 set avar {} 1721 } 1722 1723 # Make sure we have a script to run, otherwise what's the point? 1724 if { [string equal $script ""] } { 1725 return -code error "no script specified, or empty" 1726 } 1727 1728 # Do the walk 1729 variable ${name}::children 1730 set st [list ] 1731 lappend st $node 1732 1733 # Compute some flags for the possible places of command evaluation 1734 set leave [expr {[string equal $order post] || [string equal $order both]}] 1735 set enter [expr {[string equal $order pre] || [string equal $order both]}] 1736 set touch [string equal $order in] 1737 1738 if {$leave} { 1739 set lvlabel leave 1740 } elseif {$touch} { 1741 # in-order does not provide a sense 1742 # of nesting for the parent, hence 1743 # no enter/leave, just 'visit'. 1744 set lvlabel visit 1745 } 1746 1747 set rcode 0 1748 set rvalue {} 1749 1750 if {[string equal $type "dfs"]} { 1751 # Depth-first walk, several orders of visiting nodes 1752 # (pre, post, both, in) 1753 1754 array set visited {} 1755 1756 while { [llength $st] > 0 } { 1757 set node [lindex $st end] 1758 1759 if {[info exists visited($node)]} { 1760 # Second time we are looking at this 'node'. 1761 # Pop it, then evaluate the command (post, both, in). 1762 1763 ldelete st end 1764 1765 if {$leave || $touch} { 1766 # Evaluate the script at this node 1767 WalkCall $avar $nvar $name $node $lvlabel $script 1768 # prune stops execution of loop here. 1769 } 1770 } else { 1771 # First visit of this 'node'. 1772 # Do *not* pop it from the stack so that we are able 1773 # to visit again after its children 1774 1775 # Remember it. 1776 set visited($node) . 1777 1778 if {$enter} { 1779 # Evaluate the script at this node (pre, both). 1780 # 1781 # Note: As this is done before the children are 1782 # looked at the script may change the children of 1783 # this node and thus affect the walk. 1784 1785 WalkCall $avar $nvar $name $node "enter" $script 1786 # prune stops execution of loop here. 1787 } 1788 1789 # Add the children of this node to the stack. 1790 # The exact behaviour depends on the chosen 1791 # order. For pre, post, both-order we just 1792 # have to add them in reverse-order so that 1793 # they will be popped left-to-right. For in-order 1794 # we have rearrange the stack so that the parent 1795 # is revisited immediately after the first child. 1796 # (but only if there is ore than one child,) 1797 1798 set clist $children($node) 1799 set len [llength $clist] 1800 1801 if {$touch && ($len > 1)} { 1802 # Pop node from stack, insert into list of children 1803 ldelete st end 1804 set clist [linsert $clist 1 $node] 1805 incr len 1806 } 1807 1808 for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { 1809 lappend st [lindex $clist $i] 1810 } 1811 } 1812 } 1813 } else { 1814 # Breadth first walk (pre, post, both) 1815 # No in-order possible. Already captured. 1816 1817 if {$leave} { 1818 set backward $st 1819 } 1820 1821 while { [llength $st] > 0 } { 1822 set node [lindex $st 0] 1823 ldelete st 0 1824 1825 if {$enter} { 1826 # Evaluate the script at this node 1827 WalkCall $avar $nvar $name $node "enter" $script 1828 # prune stops execution of loop here. 1829 } 1830 1831 # Add this node's children 1832 # And create a mirrored version in case of post/both order. 1833 1834 foreach child $children($node) { 1835 lappend st $child 1836 if {$leave} { 1837 set backward [linsert $backward 0 $child] 1838 } 1839 } 1840 } 1841 1842 if {$leave} { 1843 foreach node $backward { 1844 # Evaluate the script at this node 1845 WalkCall $avar $nvar $name $node "leave" $script 1846 } 1847 } 1848 } 1849 1850 if {$rcode != 0} { 1851 return -code $rcode $rvalue 1852 } 1853 return 1854} 1855 1856proc ::struct::tree::_walkproc {name node args} { 1857 set usage "$name walkproc node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? ?--? cmdprefix" 1858 1859 if {[llength $args] > 6 || [llength $args] < 1} { 1860 return -code error "wrong # args: should be \"$usage\"" 1861 } 1862 1863 if { ![_exists $name $node] } { 1864 return -code error "node \"$node\" does not exist in tree \"$name\"" 1865 } 1866 1867 set args [WalkOptions $args 1 $usage] 1868 # Remainder is 'n cmdprefix' 1869 1870 set script [lindex $args 0] 1871 1872 # Make sure we have a script to run, otherwise what's the point? 1873 if { ![llength $script] } { 1874 return -code error "no script specified, or empty" 1875 } 1876 1877 # Do the walk 1878 variable ${name}::children 1879 set st [list ] 1880 lappend st $node 1881 1882 # Compute some flags for the possible places of command evaluation 1883 set leave [expr {[string equal $order post] || [string equal $order both]}] 1884 set enter [expr {[string equal $order pre] || [string equal $order both]}] 1885 set touch [string equal $order in] 1886 1887 if {$leave} { 1888 set lvlabel leave 1889 } elseif {$touch} { 1890 # in-order does not provide a sense 1891 # of nesting for the parent, hence 1892 # no enter/leave, just 'visit'. 1893 set lvlabel visit 1894 } 1895 1896 set rcode 0 1897 set rvalue {} 1898 1899 if {[string equal $type "dfs"]} { 1900 # Depth-first walk, several orders of visiting nodes 1901 # (pre, post, both, in) 1902 1903 array set visited {} 1904 1905 while { [llength $st] > 0 } { 1906 set node [lindex $st end] 1907 1908 if {[info exists visited($node)]} { 1909 # Second time we are looking at this 'node'. 1910 # Pop it, then evaluate the command (post, both, in). 1911 1912 ldelete st end 1913 1914 if {$leave || $touch} { 1915 # Evaluate the script at this node 1916 WalkCallProc $name $node $lvlabel $script 1917 # prune stops execution of loop here. 1918 } 1919 } else { 1920 # First visit of this 'node'. 1921 # Do *not* pop it from the stack so that we are able 1922 # to visit again after its children 1923 1924 # Remember it. 1925 set visited($node) . 1926 1927 if {$enter} { 1928 # Evaluate the script at this node (pre, both). 1929 # 1930 # Note: As this is done before the children are 1931 # looked at the script may change the children of 1932 # this node and thus affect the walk. 1933 1934 WalkCallProc $name $node "enter" $script 1935 # prune stops execution of loop here. 1936 } 1937 1938 # Add the children of this node to the stack. 1939 # The exact behaviour depends on the chosen 1940 # order. For pre, post, both-order we just 1941 # have to add them in reverse-order so that 1942 # they will be popped left-to-right. For in-order 1943 # we have rearrange the stack so that the parent 1944 # is revisited immediately after the first child. 1945 # (but only if there is ore than one child,) 1946 1947 set clist $children($node) 1948 set len [llength $clist] 1949 1950 if {$touch && ($len > 1)} { 1951 # Pop node from stack, insert into list of children 1952 ldelete st end 1953 set clist [linsert $clist 1 $node] 1954 incr len 1955 } 1956 1957 for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { 1958 lappend st [lindex $clist $i] 1959 } 1960 } 1961 } 1962 } else { 1963 # Breadth first walk (pre, post, both) 1964 # No in-order possible. Already captured. 1965 1966 if {$leave} { 1967 set backward $st 1968 } 1969 1970 while { [llength $st] > 0 } { 1971 set node [lindex $st 0] 1972 ldelete st 0 1973 1974 if {$enter} { 1975 # Evaluate the script at this node 1976 WalkCallProc $name $node "enter" $script 1977 # prune stops execution of loop here. 1978 } 1979 1980 # Add this node's children 1981 # And create a mirrored version in case of post/both order. 1982 1983 foreach child $children($node) { 1984 lappend st $child 1985 if {$leave} { 1986 set backward [linsert $backward 0 $child] 1987 } 1988 } 1989 } 1990 1991 if {$leave} { 1992 foreach node $backward { 1993 # Evaluate the script at this node 1994 WalkCallProc $name $node "leave" $script 1995 } 1996 } 1997 } 1998 1999 if {$rcode != 0} { 2000 return -code $rcode $rvalue 2001 } 2002 return 2003} 2004 2005proc ::struct::tree::WalkOptions {theargs n usage} { 2006 upvar 1 type type order order 2007 2008 # Set defaults 2009 set type dfs 2010 set order pre 2011 2012 while {[llength $theargs]} { 2013 set flag [lindex $theargs 0] 2014 switch -exact -- $flag { 2015 "-type" { 2016 if {[llength $theargs] < 2} { 2017 return -code error "value for \"$flag\" missing" 2018 } 2019 set type [string tolower [lindex $theargs 1]] 2020 set theargs [lrange $theargs 2 end] 2021 } 2022 "-order" { 2023 if {[llength $theargs] < 2} { 2024 return -code error "value for \"$flag\" missing" 2025 } 2026 set order [string tolower [lindex $theargs 1]] 2027 set theargs [lrange $theargs 2 end] 2028 } 2029 "--" { 2030 set theargs [lrange $theargs 1 end] 2031 break 2032 } 2033 default { 2034 break 2035 } 2036 } 2037 } 2038 2039 if {[llength $theargs] == 0} { 2040 return -code error "wrong # args: should be \"$usage\"" 2041 } 2042 if {[llength $theargs] != $n} { 2043 return -code error "unknown option \"$flag\"" 2044 } 2045 2046 # Validate that the given type is good 2047 switch -exact -- $type { 2048 "dfs" - "bfs" { 2049 set type $type 2050 } 2051 default { 2052 return -code error "bad search type \"$type\": must be bfs or dfs" 2053 } 2054 } 2055 2056 # Validate that the given order is good 2057 switch -exact -- $order { 2058 "pre" - "post" - "in" - "both" { 2059 set order $order 2060 } 2061 default { 2062 return -code error "bad search order \"$order\":\ 2063 must be both, in, pre, or post" 2064 } 2065 } 2066 2067 if {[string equal $order "in"] && [string equal $type "bfs"]} { 2068 return -code error "unable to do a ${order}-order breadth first walk" 2069 } 2070 2071 return $theargs 2072} 2073 2074# ::struct::tree::WalkCall -- 2075# 2076# Helper command to 'walk' handling the evaluation 2077# of the user-specified command. Information about 2078# the tree, node and current action are substituted 2079# into the command before it evaluation. 2080# 2081# Arguments: 2082# tree Tree we are walking 2083# node Node we are at. 2084# action The current action. 2085# cmd The command to call, already partially substituted. 2086# 2087# Results: 2088# None. 2089 2090proc ::struct::tree::WalkCall {avar nvar tree node action cmd} { 2091 2092 if {$avar != {}} { 2093 upvar 2 $avar a ; set a $action 2094 } 2095 upvar 2 $nvar n ; set n $node 2096 2097 set code [catch {uplevel 2 $cmd} result] 2098 2099 # decide what to do upon the return code: 2100 # 2101 # 0 - the body executed successfully 2102 # 1 - the body raised an error 2103 # 2 - the body invoked [return] 2104 # 3 - the body invoked [break] 2105 # 4 - the body invoked [continue] 2106 # 5 - the body invoked [struct::tree::prune] 2107 # everything else - return and pass on the results 2108 # 2109 switch -exact -- $code { 2110 0 {} 2111 1 { 2112 return -errorinfo [ErrorInfoAsCaller uplevel WalkCall] \ 2113 -errorcode $::errorCode -code error $result 2114 } 2115 3 { 2116 # FRINK: nocheck 2117 return -code break 2118 } 2119 4 {} 2120 5 { 2121 upvar order order 2122 if {[string equal $order post] || [string equal $order in]} { 2123 return -code error "Illegal attempt to prune ${order}-order walking" 2124 } 2125 return -code continue 2126 } 2127 default { 2128 upvar 1 rcode rcode rvalue rvalue 2129 set rcode $code 2130 set rvalue $result 2131 return -code break 2132 #return -code $code $result 2133 } 2134 } 2135 return {} 2136} 2137 2138proc ::struct::tree::WalkCallProc {tree node action cmd} { 2139 2140 lappend cmd $tree $node $action 2141 set code [catch {uplevel 2 $cmd} result] 2142 2143 # decide what to do upon the return code: 2144 # 2145 # 0 - the body executed successfully 2146 # 1 - the body raised an error 2147 # 2 - the body invoked [return] 2148 # 3 - the body invoked [break] 2149 # 4 - the body invoked [continue] 2150 # 5 - the body invoked [struct::tree::prune] 2151 # everything else - return and pass on the results 2152 # 2153 switch -exact -- $code { 2154 0 {} 2155 1 { 2156 return -errorinfo [ErrorInfoAsCaller uplevel WalkCallProc] \ 2157 -errorcode $::errorCode -code error $result 2158 } 2159 3 { 2160 # FRINK: nocheck 2161 return -code break 2162 } 2163 4 {} 2164 5 { 2165 upvar order order 2166 if {[string equal $order post] || [string equal $order in]} { 2167 return -code error "Illegal attempt to prune ${order}-order walking" 2168 } 2169 return -code continue 2170 } 2171 default { 2172 upvar 1 rcode rcode rvalue rvalue 2173 set rcode $code 2174 set rvalue $result 2175 return -code break 2176 } 2177 } 2178 return {} 2179} 2180 2181proc ::struct::tree::ErrorInfoAsCaller {find replace} { 2182 set info $::errorInfo 2183 set i [string last "\n (\"$find" $info] 2184 if {$i == -1} {return $info} 2185 set result [string range $info 0 [incr i 6]] ;# keep "\n (\"" 2186 append result $replace ;# $find -> $replace 2187 incr i [string length $find] 2188 set j [string first ) $info [incr i]] ;# keep rest of parenthetical 2189 append result [string range $info $i $j] 2190 return $result 2191} 2192 2193# ::struct::tree::GenerateUniqueNodeName -- 2194# 2195# Generate a unique node name for the given tree. 2196# 2197# Arguments: 2198# name Name of the tree to generate a unique node name for. 2199# 2200# Results: 2201# node Name of a node guaranteed to not exist in the tree. 2202 2203proc ::struct::tree::GenerateUniqueNodeName {name} { 2204 variable ${name}::nextUnusedNode 2205 while {[_exists $name "node${nextUnusedNode}"]} { 2206 incr nextUnusedNode 2207 } 2208 return "node${nextUnusedNode}" 2209} 2210 2211# ::struct::tree::KillNode -- 2212# 2213# Delete all data of a node. 2214# 2215# Arguments: 2216# name Name of the tree containing the node 2217# node Name of the node to delete. 2218# 2219# Results: 2220# none 2221 2222proc ::struct::tree::KillNode {name node} { 2223 variable ${name}::parent 2224 variable ${name}::children 2225 variable ${name}::attribute 2226 2227 # Remove all record of $node 2228 unset parent($node) 2229 unset children($node) 2230 2231 if {[info exists attribute($node)]} { 2232 # FRINK: nocheck 2233 unset ${name}::$attribute($node) 2234 unset attribute($node) 2235 } 2236 return 2237} 2238 2239# ::struct::tree::GenAttributeStorage -- 2240# 2241# Create an array to store the attributes of a node in. 2242# 2243# Arguments: 2244# name Name of the tree containing the node 2245# node Name of the node which got attributes. 2246# 2247# Results: 2248# none 2249 2250proc ::struct::tree::GenAttributeStorage {name node} { 2251 variable ${name}::nextAttr 2252 variable ${name}::attribute 2253 2254 set attr "a[incr nextAttr]" 2255 set attribute($node) $attr 2256 return 2257} 2258 2259# ::struct::tree::Serialize -- 2260# 2261# Serialize a tree object (partially) into a transportable value. 2262# 2263# Arguments: 2264# name Name of the tree. 2265# node Root node of the serialized tree. 2266# 2267# Results: 2268# None 2269 2270proc ::struct::tree::Serialize {name node tvar} { 2271 upvar 1 $tvar tree 2272 2273 variable ${name}::attribute 2274 variable ${name}::parent 2275 2276 # 'node' is the root of the tree to serialize. The precondition 2277 # for the call is that this node is already stored in the list 2278 # 'tvar', at index 'rootidx'. 2279 2280 # The attribute data for 'node' goes immediately after the 'node' 2281 # data. the node information is _not_ yet stored, and this command 2282 # has to do this. 2283 2284 2285 array set r {} 2286 set loc($node) 0 2287 2288 lappend tree $node {} 2289 if {[info exists attribute($node)]} { 2290 upvar ${name}::$attribute($node) data 2291 lappend tree [array get data] 2292 } else { 2293 # Encode nodes without attributes. 2294 lappend tree {} 2295 } 2296 2297 foreach n [DescendantsCore $name $node] { 2298 set loc($n) [llength $tree] 2299 lappend tree $n $loc($parent($n)) 2300 2301 if {[info exists attribute($n)]} { 2302 upvar ${name}::$attribute($n) data 2303 lappend tree [array get data] 2304 } else { 2305 # Encode nodes without attributes. 2306 lappend tree {} 2307 } 2308 } 2309 2310 return $tree 2311} 2312 2313 2314proc ::struct::tree::CheckSerialization {ser avar pvar cvar rnvar} { 2315 upvar 1 $avar attr $pvar p $cvar ch $rnvar rn 2316 2317 # Overall length ok ? 2318 2319 if {[llength $ser] % 3} { 2320 return -code error \ 2321 "error in serialization: list length not a multiple of 3." 2322 } 2323 2324 set rn {} 2325 array set p {} 2326 array set ch {} 2327 array set attr {} 2328 2329 # Basic decoder pass 2330 2331 foreach {node parent nattr} $ser { 2332 2333 # Initialize children data, if not already done 2334 if {![info exists ch($node)]} { 2335 set ch($node) {} 2336 } 2337 # Attribute length ok ? Dictionary! 2338 if {[llength $nattr] % 2} { 2339 return -code error \ 2340 "error in serialization: malformed attribute dictionary." 2341 } 2342 # Remember attribute data only for non-empty nodes 2343 if {[llength $nattr]} { 2344 set attr($node) $nattr 2345 } 2346 # Remember root 2347 if {$parent == {}} { 2348 lappend rn $node 2349 set p($node) {} 2350 continue 2351 } 2352 # Parent reference ok ? 2353 if { 2354 ![string is integer -strict $parent] || 2355 ($parent % 3) || 2356 ($parent < 0) || 2357 ($parent >= [llength $ser]) 2358 } { 2359 return -code error \ 2360 "error in serialization: bad parent reference \"$parent\"." 2361 } 2362 # Remember parent, and reconstruct children 2363 2364 set p($node) [lindex $ser $parent] 2365 lappend ch($p($node)) $node 2366 } 2367 2368 # Root node information ok ? 2369 2370 if {[llength $rn] < 1} { 2371 return -code error \ 2372 "error in serialization: no root specified." 2373 } elseif {[llength $rn] > 1} { 2374 return -code error \ 2375 "error in serialization: multiple root nodes." 2376 } 2377 set rn [lindex $rn 0] 2378 2379 # Duplicate node names ? 2380 2381 if {[array size ch] < ([llength $ser] / 3)} { 2382 return -code error \ 2383 "error in serialization: duplicate node names." 2384 } 2385 2386 # Cycles in the parent relationship ? 2387 2388 array set visited {} 2389 foreach n [array names p] { 2390 if {[info exists visited($n)]} {continue} 2391 array set _ {} 2392 while {$n != {}} { 2393 if {[info exists _($n)]} { 2394 # Node already converted, cycle. 2395 return -code error \ 2396 "error in serialization: cycle detected." 2397 } 2398 set _($n) . 2399 # root ? 2400 if {$p($n) == {}} {break} 2401 set n $p($n) 2402 if {[info exists visited($n)]} {break} 2403 set visited($n) . 2404 } 2405 unset _ 2406 } 2407 # Ok. The data is now ready for the caller. 2408 2409 return 2410} 2411 2412########################## 2413# Private functions follow 2414# 2415# Do a compatibility version of [lset] for pre-8.4 versions of Tcl. 2416# This version does not do multi-arg [lset]! 2417 2418proc ::struct::tree::K { x y } { set x } 2419 2420if { [package vcompare [package provide Tcl] 8.4] < 0 } { 2421 proc ::struct::tree::lset { var index arg } { 2422 upvar 1 $var list 2423 set list [::lreplace [K $list [set list {}]] $index $index $arg] 2424 } 2425} 2426 2427proc ::struct::tree::ldelete {var index {end {}}} { 2428 upvar 1 $var list 2429 if {$end == {}} {set end $index} 2430 set list [lreplace [K $list [set list {}]] $index $end] 2431 return 2432} 2433 2434# ### ### ### ######### ######### ######### 2435## Ready 2436 2437namespace eval ::struct { 2438 # Put 'tree::tree' into the general structure namespace 2439 # for pickup by the main management. 2440 2441 namespace import -force tree::tree_tcl 2442} 2443