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: tree1.tcl,v 1.5 2005/10/04 17:15:05 andreas_kupries Exp $ 11 12package require Tcl 8.2 13 14namespace eval ::struct {} 15 16namespace eval ::struct::tree { 17 # Data storage in the tree module 18 # ------------------------------- 19 # 20 # There's a lot of bits to keep track of for each tree: 21 # nodes 22 # node values 23 # node relationships 24 # 25 # It would quickly become unwieldy to try to keep these in arrays or lists 26 # within the tree namespace itself. Instead, each tree structure will get 27 # its own namespace. Each namespace contains: 28 # children array mapping nodes to their children list 29 # parent array mapping nodes to their parent node 30 # node:$node array mapping keys to values for the node $node 31 32 # counter is used to give a unique name for unnamed trees 33 variable counter 0 34 35 # Only export one command, the one used to instantiate a new tree 36 namespace export tree 37} 38 39# ::struct::tree::tree -- 40# 41# Create a new tree with a given name; if no name is given, use 42# treeX, where X is a number. 43# 44# Arguments: 45# name Optional name of the tree; if null or not given, generate one. 46# 47# Results: 48# name Name of the tree created 49 50proc ::struct::tree::tree {{name ""}} { 51 variable counter 52 53 if {[llength [info level 0]] == 1} { 54 incr counter 55 set name "tree${counter}" 56 } 57 # FIRST, qualify the name. 58 if {![string match "::*" $name]} { 59 # Get caller's namespace; append :: if not global namespace. 60 set ns [uplevel 1 namespace current] 61 if {"::" != $ns} { 62 append ns "::" 63 } 64 65 set name "$ns$name" 66 } 67 if {[llength [info commands $name]]} { 68 return -code error \ 69 "command \"$name\" already exists, unable to create tree" 70 } 71 72 # Set up the namespace for the object, 73 # identical to the object command. 74 namespace eval $name { 75 # Set up root node's child list 76 variable children 77 set children(root) [list] 78 79 # Set root node's parent 80 variable parent 81 set parent(root) [list] 82 83 # Set up the node attribute mapping 84 variable attribute 85 array set attribute {} 86 87 # Set up a counter for use in creating unique node names 88 variable nextUnusedNode 89 set nextUnusedNode 1 90 91 # Set up a counter for use in creating node attribute arrays. 92 variable nextAttr 93 set nextAttr 0 94 } 95 96 # Create the command to manipulate the tree 97 interp alias {} ::$name {} ::struct::tree::TreeProc $name 98 99 return $name 100} 101 102########################## 103# Private functions follow 104 105# ::struct::tree::TreeProc -- 106# 107# Command that processes all tree object commands. 108# 109# Arguments: 110# name Name of the tree object to manipulate. 111# cmd Subcommand to invoke. 112# args Arguments for subcommand. 113# 114# Results: 115# Varies based on command to perform 116 117proc ::struct::tree::TreeProc {name {cmd ""} args} { 118 # Do minimal args checks here 119 if { [llength [info level 0]] == 2 } { 120 return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" 121 } 122 123 # Split the args into command and args components 124 set sub _$cmd 125 if { [llength [info commands ::struct::tree::$sub]] == 0 } { 126 set optlist [lsort [info commands ::struct::tree::_*]] 127 set xlist {} 128 foreach p $optlist { 129 set p [namespace tail $p] 130 lappend xlist [string range $p 1 end] 131 } 132 set optlist [linsert [join $xlist ", "] "end-1" "or"] 133 return -code error \ 134 "bad option \"$cmd\": must be $optlist" 135 } 136 return [uplevel 1 [linsert $args 0 ::struct::tree::$sub $name]] 137} 138 139# ::struct::tree::_children -- 140# 141# Return the child list for a given node of a tree. 142# 143# Arguments: 144# name Name of the tree object. 145# node Node to look up. 146# 147# Results: 148# children List of children for the node. 149 150proc ::struct::tree::_children {name node} { 151 if { ![_exists $name $node] } { 152 return -code error "node \"$node\" does not exist in tree \"$name\"" 153 } 154 155 variable ${name}::children 156 return $children($node) 157} 158 159# ::struct::tree::_cut -- 160# 161# Destroys the specified node of a tree, but not its children. 162# These children are made into children of the parent of the 163# destroyed node at the index of the destroyed node. 164# 165# Arguments: 166# name Name of the tree object. 167# node Node to look up and cut. 168# 169# Results: 170# None. 171 172proc ::struct::tree::_cut {name node} { 173 if { [string equal $node "root"] } { 174 # Can't delete the special root node 175 return -code error "cannot cut root node" 176 } 177 178 if { ![_exists $name $node] } { 179 return -code error "node \"$node\" does not exist in tree \"$name\"" 180 } 181 182 variable ${name}::parent 183 variable ${name}::children 184 185 # Locate our parent, children and our location in the parent 186 set parentNode $parent($node) 187 set childNodes $children($node) 188 189 set index [lsearch -exact $children($parentNode) $node] 190 191 # Excise this node from the parent list, 192 set newChildren [lreplace $children($parentNode) $index $index] 193 194 # Put each of the children of $node into the parent's children list, 195 # in the place of $node, and update the parent pointer of those nodes. 196 foreach child $childNodes { 197 set newChildren [linsert $newChildren $index $child] 198 set parent($child) $parentNode 199 incr index 200 } 201 set children($parentNode) $newChildren 202 203 KillNode $name $node 204 return 205} 206 207# ::struct::tree::_delete -- 208# 209# Remove a node from a tree, including all of its values. Recursively 210# removes the node's children. 211# 212# Arguments: 213# name Name of the tree. 214# node Node to delete. 215# 216# Results: 217# None. 218 219proc ::struct::tree::_delete {name node} { 220 if { [string equal $node "root"] } { 221 # Can't delete the special root node 222 return -code error "cannot delete root node" 223 } 224 if { ![_exists $name $node] } { 225 return -code error "node \"$node\" does not exist in tree \"$name\"" 226 } 227 228 variable ${name}::children 229 variable ${name}::parent 230 231 # Remove this node from its parent's children list 232 set parentNode $parent($node) 233 set index [lsearch -exact $children($parentNode) $node] 234 set children($parentNode) [lreplace $children($parentNode) $index $index] 235 236 # Yes, we could use the stack structure implemented in ::struct::stack, 237 # but it's slower than inlining it. Since we don't need a sophisticated 238 # stack, don't bother. 239 set st [list] 240 foreach child $children($node) { 241 lappend st $child 242 } 243 244 KillNode $name $node 245 246 while { [llength $st] > 0 } { 247 set node [lindex $st end] 248 set st [lreplace $st end end] 249 foreach child $children($node) { 250 lappend st $child 251 } 252 253 KillNode $name $node 254 } 255 return 256} 257 258# ::struct::tree::_depth -- 259# 260# Return the depth (distance from the root node) of a given node. 261# 262# Arguments: 263# name Name of the tree. 264# node Node to find. 265# 266# Results: 267# depth Number of steps from node to the root node. 268 269proc ::struct::tree::_depth {name node} { 270 if { ![_exists $name $node] } { 271 return -code error "node \"$node\" does not exist in tree \"$name\"" 272 } 273 variable ${name}::parent 274 set depth 0 275 while { ![string equal $node "root"] } { 276 incr depth 277 set node $parent($node) 278 } 279 return $depth 280} 281 282# ::struct::tree::_destroy -- 283# 284# Destroy a tree, including its associated command and data storage. 285# 286# Arguments: 287# name Name of the tree to destroy. 288# 289# Results: 290# None. 291 292proc ::struct::tree::_destroy {name} { 293 namespace delete $name 294 interp alias {} ::$name {} 295} 296 297# ::struct::tree::_exists -- 298# 299# Test for existance of a given node in a tree. 300# 301# Arguments: 302# name Name of the tree to query. 303# node Node to look for. 304# 305# Results: 306# 1 if the node exists, 0 else. 307 308proc ::struct::tree::_exists {name node} { 309 return [info exists ${name}::parent($node)] 310} 311 312# ::struct::tree::_get -- 313# 314# Get a keyed value from a node in a tree. 315# 316# Arguments: 317# name Name of the tree. 318# node Node to query. 319# flag Optional flag specifier; if present, must be "-key". 320# key Optional key to lookup; defaults to data. 321# 322# Results: 323# value Value associated with the key given. 324 325proc ::struct::tree::_get {name node {flag -key} {key data}} { 326 if {![_exists $name $node]} { 327 return -code error "node \"$node\" does not exist in tree \"$name\"" 328 } 329 330 variable ${name}::attribute 331 if {![info exists attribute($node)]} { 332 # No attribute data for this node, 333 # except for the default key 'data'. 334 335 if {[string equal $key data]} { 336 return "" 337 } 338 return -code error "invalid key \"$key\" for node \"$node\"" 339 } 340 341 upvar ${name}::$attribute($node) data 342 if {![info exists data($key)]} { 343 return -code error "invalid key \"$key\" for node \"$node\"" 344 } 345 return $data($key) 346} 347 348# ::struct::tree::_getall -- 349# 350# Get a serialized list of key/value pairs from a node in a tree. 351# 352# Arguments: 353# name Name of the tree. 354# node Node to query. 355# 356# Results: 357# value A serialized list of key/value pairs. 358 359proc ::struct::tree::_getall {name node args} { 360 if {![_exists $name $node]} { 361 return -code error "node \"$node\" does not exist in tree \"$name\"" 362 } 363 if {[llength $args]} { 364 return -code error "wrong # args: should be \"$name getall $node\"" 365 } 366 367 variable ${name}::attribute 368 if {![info exists attribute($node)]} { 369 # Only default key is present, invisibly. 370 return {data {}} 371 } 372 373 upvar ${name}::$attribute($node) data 374 return [array get data] 375} 376 377# ::struct::tree::_keys -- 378# 379# Get a list of keys from a node in a tree. 380# 381# Arguments: 382# name Name of the tree. 383# node Node to query. 384# 385# Results: 386# value A serialized list of key/value pairs. 387 388proc ::struct::tree::_keys {name node args} { 389 if {![_exists $name $node]} { 390 return -code error "node \"$node\" does not exist in tree \"$name\"" 391 } 392 if {[llength $args]} { 393 return -code error "wrong # args: should be \"$name keys $node\"" 394 } 395 396 variable ${name}::attribute 397 if {![info exists attribute($node)]} { 398 # No attribute data for this node, 399 # except for the default key 'data'. 400 return {data} 401 } 402 403 upvar ${name}::$attribute($node) data 404 return [array names data] 405} 406 407# ::struct::tree::_keyexists -- 408# 409# Test for existance of a given key for a node in a tree. 410# 411# Arguments: 412# name Name of the tree. 413# node Node to query. 414# flag Optional flag specifier; if present, must be "-key". 415# key Optional key to lookup; defaults to data. 416# 417# Results: 418# 1 if the key exists, 0 else. 419 420proc ::struct::tree::_keyexists {name node {flag -key} {key data}} { 421 if {![_exists $name $node]} { 422 return -code error "node \"$node\" does not exist in tree \"$name\"" 423 } 424 if {![string equal $flag "-key"]} { 425 return -code error "invalid option \"$flag\": should be -key" 426 } 427 428 variable ${name}::attribute 429 if {![info exists attribute($node)]} { 430 # No attribute data for this node, 431 # except for the default key 'data'. 432 433 return [string equal $key data] 434 } 435 436 upvar ${name}::$attribute($node) data 437 return [info exists data($key)] 438} 439 440# ::struct::tree::_index -- 441# 442# Determine the index of node with in its parent's list of children. 443# 444# Arguments: 445# name Name of the tree. 446# node Node to look up. 447# 448# Results: 449# index The index of the node in its parent 450 451proc ::struct::tree::_index {name node} { 452 if { [string equal $node "root"] } { 453 # The special root node has no parent, thus no index in it either. 454 return -code error "cannot determine index of root node" 455 } 456 457 if { ![_exists $name $node] } { 458 return -code error "node \"$node\" does not exist in tree \"$name\"" 459 } 460 461 variable ${name}::children 462 variable ${name}::parent 463 464 # Locate the parent and ourself in its list of children 465 set parentNode $parent($node) 466 467 return [lsearch -exact $children($parentNode) $node] 468} 469 470# ::struct::tree::_insert -- 471# 472# Add a node to a tree; if the node(s) specified already exist, they 473# will be moved to the given location. 474# 475# Arguments: 476# name Name of the tree. 477# parentNode Parent to add the node to. 478# index Index at which to insert. 479# args Node(s) to insert. If none is given, the routine 480# will insert a single node with a unique name. 481# 482# Results: 483# nodes List of nodes inserted. 484 485proc ::struct::tree::_insert {name parentNode index args} { 486 if { [llength $args] == 0 } { 487 # No node name was given; generate a unique one 488 set args [list [GenerateUniqueNodeName $name]] 489 } 490 if { ![_exists $name $parentNode] } { 491 return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" 492 } 493 494 variable ${name}::parent 495 variable ${name}::children 496 497 # Make sure the index is numeric 498 if { ![string is integer $index] } { 499 # If the index is not numeric, make it numeric by lsearch'ing for 500 # the value at index, then incrementing index (because "end" means 501 # just past the end for inserts) 502 set val [lindex $children($parentNode) $index] 503 set index [expr {[lsearch -exact $children($parentNode) $val] + 1}] 504 } 505 506 foreach node $args { 507 if {[_exists $name $node] } { 508 # Move the node to its new home 509 if { [string equal $node "root"] } { 510 return -code error "cannot move root node" 511 } 512 513 # Cannot make a node its own descendant (I'm my own grandpaw...) 514 set ancestor $parentNode 515 while { ![string equal $ancestor "root"] } { 516 if { [string equal $ancestor $node] } { 517 return -code error "node \"$node\" cannot be its own descendant" 518 } 519 set ancestor $parent($ancestor) 520 } 521 # Remove this node from its parent's children list 522 set oldParent $parent($node) 523 set ind [lsearch -exact $children($oldParent) $node] 524 set children($oldParent) [lreplace $children($oldParent) $ind $ind] 525 526 # If the node is moving within its parent, and its old location 527 # was before the new location, decrement the new location, so that 528 # it gets put in the right spot 529 if { [string equal $oldParent $parentNode] && $ind < $index } { 530 incr index -1 531 } 532 } else { 533 # Set up the new node 534 set children($node) [list] 535 } 536 537 # Add this node to its parent's children list 538 set children($parentNode) [linsert $children($parentNode) $index $node] 539 540 # Update the parent pointer for this node 541 set parent($node) $parentNode 542 incr index 543 } 544 545 return $args 546} 547 548# ::struct::tree::_isleaf -- 549# 550# Return whether the given node of a tree is a leaf or not. 551# 552# Arguments: 553# name Name of the tree object. 554# node Node to look up. 555# 556# Results: 557# isleaf True if the node is a leaf; false otherwise. 558 559proc ::struct::tree::_isleaf {name node} { 560 if { ![_exists $name $node] } { 561 return -code error "node \"$node\" does not exist in tree \"$name\"" 562 } 563 564 variable ${name}::children 565 return [expr {[llength $children($node)] == 0}] 566} 567 568# ::struct::tree::_move -- 569# 570# Move a node (and all its subnodes) from where ever it is to a new 571# location in the tree. 572# 573# Arguments: 574# name Name of the tree 575# parentNode Parent to add the node to. 576# index Index at which to insert. 577# node Node to move; the node must exist in the tree. 578# args Additional nodes to move; these nodes must exist 579# in the tree. 580# 581# Results: 582# None. 583 584proc ::struct::tree::_move {name parentNode index node args} { 585 set args [linsert $args 0 $node] 586 587 # Can only move a node to a real location in the tree 588 if { ![_exists $name $parentNode] } { 589 return -code error "parent node \"$parentNode\" does not exist in tree \"$name\"" 590 } 591 592 variable ${name}::parent 593 variable ${name}::children 594 595 # Make sure the index is numeric 596 if { ![string is integer $index] } { 597 # If the index is not numeric, make it numeric by lsearch'ing for 598 # the value at index, then incrementing index (because "end" means 599 # just past the end for inserts) 600 set val [lindex $children($parentNode) $index] 601 set index [expr {[lsearch -exact $children($parentNode) $val] + 1}] 602 } 603 604 # Validate all nodes to move before trying to move any. 605 foreach node $args { 606 if { [string equal $node "root"] } { 607 return -code error "cannot move root node" 608 } 609 610 # Can only move real nodes 611 if { ![_exists $name $node] } { 612 return -code error "node \"$node\" does not exist in tree \"$name\"" 613 } 614 615 # Cannot move a node to be a descendant of itself 616 set ancestor $parentNode 617 while { ![string equal $ancestor "root"] } { 618 if { [string equal $ancestor $node] } { 619 return -code error "node \"$node\" cannot be its own descendant" 620 } 621 set ancestor $parent($ancestor) 622 } 623 } 624 625 # Remove all nodes from their current parent's children list 626 foreach node $args { 627 set oldParent $parent($node) 628 set ind [lsearch -exact $children($oldParent) $node] 629 630 set children($oldParent) [lreplace $children($oldParent) $ind $ind] 631 632 # Update the nodes parent value 633 set parent($node) $parentNode 634 } 635 636 # Add all nodes to their new parent's children list 637 set children($parentNode) \ 638 [eval [list linsert $children($parentNode) $index] $args] 639 640 return 641} 642 643# ::struct::tree::_next -- 644# 645# Return the right sibling for a given node of a tree. 646# 647# Arguments: 648# name Name of the tree object. 649# node Node to retrieve right sibling for. 650# 651# Results: 652# sibling The right sibling for the node, or null if node was 653# the rightmost child of its parent. 654 655proc ::struct::tree::_next {name node} { 656 # The 'root' has no siblings. 657 if { [string equal $node "root"] } { 658 return {} 659 } 660 661 if { ![_exists $name $node] } { 662 return -code error "node \"$node\" does not exist in tree \"$name\"" 663 } 664 665 # Locate the parent and our place in its list of children. 666 variable ${name}::parent 667 variable ${name}::children 668 669 set parentNode $parent($node) 670 set index [lsearch -exact $children($parentNode) $node] 671 672 # Go to the node to the right and return its name. 673 return [lindex $children($parentNode) [incr index]] 674} 675 676# ::struct::tree::_numchildren -- 677# 678# Return the number of immediate children for a given node of a tree. 679# 680# Arguments: 681# name Name of the tree object. 682# node Node to look up. 683# 684# Results: 685# numchildren Number of immediate children for the node. 686 687proc ::struct::tree::_numchildren {name node} { 688 if { ![_exists $name $node] } { 689 return -code error "node \"$node\" does not exist in tree \"$name\"" 690 } 691 692 variable ${name}::children 693 return [llength $children($node)] 694} 695 696# ::struct::tree::_parent -- 697# 698# Return the name of the parent node of a node in a tree. 699# 700# Arguments: 701# name Name of the tree. 702# node Node to look up. 703# 704# Results: 705# parent Parent of node $node 706 707proc ::struct::tree::_parent {name node} { 708 if { ![_exists $name $node] } { 709 return -code error "node \"$node\" does not exist in tree \"$name\"" 710 } 711 # FRINK: nocheck 712 return [set ${name}::parent($node)] 713} 714 715# ::struct::tree::_previous -- 716# 717# Return the left sibling for a given node of a tree. 718# 719# Arguments: 720# name Name of the tree object. 721# node Node to look up. 722# 723# Results: 724# sibling The left sibling for the node, or null if node was 725# the leftmost child of its parent. 726 727proc ::struct::tree::_previous {name node} { 728 # The 'root' has no siblings. 729 if { [string equal $node "root"] } { 730 return {} 731 } 732 733 if { ![_exists $name $node] } { 734 return -code error "node \"$node\" does not exist in tree \"$name\"" 735 } 736 737 # Locate the parent and our place in its list of children. 738 variable ${name}::parent 739 variable ${name}::children 740 741 set parentNode $parent($node) 742 set index [lsearch -exact $children($parentNode) $node] 743 744 # Go to the node to the right and return its name. 745 return [lindex $children($parentNode) [incr index -1]] 746} 747 748# ::struct::tree::_serialize -- 749# 750# Serialize a tree object (partially) into a transportable value. 751# 752# Arguments: 753# name Name of the tree. 754# node Root node of the serialized tree. 755# 756# Results: 757# A list structure describing the part of the tree which was serialized. 758 759proc ::struct::tree::_serialize {name {node root}} { 760 if {![_exists $name $node]} { 761 return -code error "node \"$node\" does not exist in tree \"$name\"" 762 } 763 Serialize $name $node tree attr 764 return [list $tree [array get attr]] 765} 766 767# ::struct::tree::_set -- 768# 769# Set or get a value for a node in a tree. 770# 771# Arguments: 772# name Name of the tree. 773# node Node to modify or query. 774# args Optional arguments specifying a key and a value. Format is 775# ?-key key? ?value? 776# If no key is specified, the key "data" is used. 777# 778# Results: 779# val Value associated with the given key of the given node 780 781proc ::struct::tree::_set {name node args} { 782 if {![_exists $name $node]} { 783 return -code error "node \"$node\" does not exist in tree \"$name\"" 784 } 785 if {[llength $args] > 3} { 786 return -code error "wrong # args: should be \"$name set [list $node] ?-key key?\ 787 ?value?\"" 788 } 789 790 # Process the arguments ... 791 792 set key "data" 793 set haveValue 0 794 if {[llength $args] > 1} { 795 foreach {flag key} $args break 796 if {![string match "${flag}*" "-key"]} { 797 return -code error "invalid option \"$flag\": should be key" 798 } 799 if {[llength $args] == 3} { 800 set haveValue 1 801 set value [lindex $args end] 802 } 803 } elseif {[llength $args] == 1} { 804 set haveValue 1 805 set value [lindex $args end] 806 } 807 808 if {$haveValue} { 809 # Setting a value. This may have to create 810 # the attribute array for this particular 811 # node 812 813 variable ${name}::attribute 814 if {![info exists attribute($node)]} { 815 # No attribute data for this node, 816 # so create it as we need it. 817 GenAttributeStorage $name $node 818 } 819 upvar ${name}::$attribute($node) data 820 821 return [set data($key) $value] 822 } else { 823 # Getting a value 824 825 return [_get $name $node -key $key] 826 } 827} 828 829# ::struct::tree::_append -- 830# 831# Append a value for a node in a tree. 832# 833# Arguments: 834# name Name of the tree. 835# node Node to modify or query. 836# args Optional arguments specifying a key and a value. Format is 837# ?-key key? ?value? 838# If no key is specified, the key "data" is used. 839# 840# Results: 841# val Value associated with the given key of the given node 842 843proc ::struct::tree::_append {name node args} { 844 if {![_exists $name $node]} { 845 return -code error "node \"$node\" does not exist in tree \"$name\"" 846 } 847 if { 848 ([llength $args] != 1) && 849 ([llength $args] != 3) 850 } { 851 return -code error "wrong # args: should be \"$name set [list $node] ?-key key?\ 852 value\"" 853 } 854 if {[llength $args] == 3} { 855 foreach {flag key} $args break 856 if {![string equal $flag "-key"]} { 857 return -code error "invalid option \"$flag\": should be -key" 858 } 859 } else { 860 set key "data" 861 } 862 863 set value [lindex $args end] 864 865 variable ${name}::attribute 866 if {![info exists attribute($node)]} { 867 # No attribute data for this node, 868 # so create it as we need it. 869 GenAttributeStorage $name $node 870 } 871 upvar ${name}::$attribute($node) data 872 873 return [append data($key) $value] 874} 875 876# ::struct::tree::_lappend -- 877# 878# lappend a value for a node in a tree. 879# 880# Arguments: 881# name Name of the tree. 882# node Node to modify or query. 883# args Optional arguments specifying a key and a value. Format is 884# ?-key key? ?value? 885# If no key is specified, the key "data" is used. 886# 887# Results: 888# val Value associated with the given key of the given node 889 890proc ::struct::tree::_lappend {name node args} { 891 if {![_exists $name $node]} { 892 return -code error "node \"$node\" does not exist in tree \"$name\"" 893 } 894 if { 895 ([llength $args] != 1) && 896 ([llength $args] != 3) 897 } { 898 return -code error "wrong # args: should be \"$name lappend [list $node] ?-key key?\ 899 value\"" 900 } 901 if {[llength $args] == 3} { 902 foreach {flag key} $args break 903 if {![string equal $flag "-key"]} { 904 return -code error "invalid option \"$flag\": should be -key" 905 } 906 } else { 907 set key "data" 908 } 909 910 set value [lindex $args end] 911 912 variable ${name}::attribute 913 if {![info exists attribute($node)]} { 914 # No attribute data for this node, 915 # so create it as we need it. 916 GenAttributeStorage $name $node 917 } 918 upvar ${name}::$attribute($node) data 919 920 return [lappend data($key) $value] 921} 922 923# ::struct::tree::_size -- 924# 925# Return the number of descendants of a given node. The default node 926# is the special root node. 927# 928# Arguments: 929# name Name of the tree. 930# node Optional node to start counting from (default is root). 931# 932# Results: 933# size Number of descendants of the node. 934 935proc ::struct::tree::_size {name {node root}} { 936 if { ![_exists $name $node] } { 937 return -code error "node \"$node\" does not exist in tree \"$name\"" 938 } 939 940 # If the node is the root, we can do the cheap thing and just count the 941 # number of nodes (excluding the root node) that we have in the tree with 942 # array names 943 if { [string equal $node "root"] } { 944 set size [llength [array names ${name}::parent]] 945 return [expr {$size - 1}] 946 } 947 948 # Otherwise we have to do it the hard way and do a full tree search 949 variable ${name}::children 950 set size 0 951 set st [list ] 952 foreach child $children($node) { 953 lappend st $child 954 } 955 while { [llength $st] > 0 } { 956 set node [lindex $st end] 957 set st [lreplace $st end end] 958 incr size 959 foreach child $children($node) { 960 lappend st $child 961 } 962 } 963 return $size 964} 965 966# ::struct::tree::_splice -- 967# 968# Add a node to a tree, making a range of children from the given 969# parent children of the new node. 970# 971# Arguments: 972# name Name of the tree. 973# parentNode Parent to add the node to. 974# from Index at which to insert. 975# to Optional end of the range of children to replace. 976# Defaults to 'end'. 977# node Optional node name; if given, must be unique. If not 978# given, a unique name will be generated. 979# 980# Results: 981# node Name of the node added to the tree. 982 983proc ::struct::tree::_splice {name parentNode from {to end} args} { 984 if { [llength $args] == 0 } { 985 # No node name given; generate a unique node name 986 set node [GenerateUniqueNodeName $name] 987 } else { 988 set node [lindex $args 0] 989 } 990 991 if { [_exists $name $node] } { 992 return -code error "node \"$node\" already exists in tree \"$name\"" 993 } 994 995 variable ${name}::children 996 variable ${name}::parent 997 998 # Save the list of children that are moving 999 set moveChildren [lrange $children($parentNode) $from $to] 1000 1001 # Remove those children from the parent 1002 set children($parentNode) [lreplace $children($parentNode) $from $to] 1003 1004 # Add the new node 1005 _insert $name $parentNode $from $node 1006 1007 # Move the children 1008 set children($node) $moveChildren 1009 foreach child $moveChildren { 1010 set parent($child) $node 1011 } 1012 1013 return $node 1014} 1015 1016# ::struct::tree::_swap -- 1017# 1018# Swap two nodes in a tree. 1019# 1020# Arguments: 1021# name Name of the tree. 1022# node1 First node to swap. 1023# node2 Second node to swap. 1024# 1025# Results: 1026# None. 1027 1028proc ::struct::tree::_swap {name node1 node2} { 1029 # Can't swap the magic root node 1030 if {[string equal $node1 "root"] || [string equal $node2 "root"]} { 1031 return -code error "cannot swap root node" 1032 } 1033 1034 # Can only swap two real nodes 1035 if {![_exists $name $node1]} { 1036 return -code error "node \"$node1\" does not exist in tree \"$name\"" 1037 } 1038 if {![_exists $name $node2]} { 1039 return -code error "node \"$node2\" does not exist in tree \"$name\"" 1040 } 1041 1042 # Can't swap a node with itself 1043 if {[string equal $node1 $node2]} { 1044 return -code error "cannot swap node \"$node1\" with itself" 1045 } 1046 1047 # Swapping nodes means swapping their labels and values 1048 variable ${name}::children 1049 variable ${name}::parent 1050 1051 set parent1 $parent($node1) 1052 set parent2 $parent($node2) 1053 1054 # Replace node1 with node2 in node1's parent's children list, and 1055 # node2 with node1 in node2's parent's children list 1056 set i1 [lsearch -exact $children($parent1) $node1] 1057 set i2 [lsearch -exact $children($parent2) $node2] 1058 1059 set children($parent1) [lreplace $children($parent1) $i1 $i1 $node2] 1060 set children($parent2) [lreplace $children($parent2) $i2 $i2 $node1] 1061 1062 # Make node1 the parent of node2's children, and vis versa 1063 foreach child $children($node2) { 1064 set parent($child) $node1 1065 } 1066 foreach child $children($node1) { 1067 set parent($child) $node2 1068 } 1069 1070 # Swap the children lists 1071 set children1 $children($node1) 1072 set children($node1) $children($node2) 1073 set children($node2) $children1 1074 1075 if { [string equal $node1 $parent2] } { 1076 set parent($node1) $node2 1077 set parent($node2) $parent1 1078 } elseif { [string equal $node2 $parent1] } { 1079 set parent($node1) $parent2 1080 set parent($node2) $node1 1081 } else { 1082 set parent($node1) $parent2 1083 set parent($node2) $parent1 1084 } 1085 1086 # Swap the values 1087 # More complicated now with the possibility that nodes do not have 1088 # attribute storage associated with them. 1089 1090 variable ${name}::attribute 1091 1092 if { 1093 [set ia [info exists attribute($node1)]] || 1094 [set ib [info exists attribute($node2)]] 1095 } { 1096 # At least one of the nodes has attribute data. We simply swap 1097 # the references to the arrays containing them. No need to 1098 # copy the actual data around. 1099 1100 if {$ia && $ib} { 1101 set tmp $attribute($node1) 1102 set attribute($node1) $attribute($node2) 1103 set attribute($node2) $tmp 1104 } elseif {$ia} { 1105 set attribute($node2) $attribute($node1) 1106 unset attribute($node1) 1107 } elseif {$ib} { 1108 set attribute($node1) $attribute($node2) 1109 unset attribute($node2) 1110 } else { 1111 return -code error "Impossible condition." 1112 } 1113 } ; # else: No attribute storage => Nothing to do {} 1114 1115 return 1116} 1117 1118# ::struct::tree::_unset -- 1119# 1120# Remove a keyed value from a node. 1121# 1122# Arguments: 1123# name Name of the tree. 1124# node Node to modify. 1125# args Optional additional args specifying which key to unset; 1126# if given, must be of the form "-key key". If not given, 1127# the key "data" is unset. 1128# 1129# Results: 1130# None. 1131 1132proc ::struct::tree::_unset {name node {flag -key} {key data}} { 1133 if {![_exists $name $node]} { 1134 return -code error "node \"$node\" does not exist in tree \"$name\"" 1135 } 1136 if {![string match "${flag}*" "-key"]} { 1137 return -code error "invalid option \"$flag\": should be \"$name unset\ 1138 [list $node] ?-key key?\"" 1139 } 1140 1141 variable ${name}::attribute 1142 if {![info exists attribute($node)]} { 1143 # No attribute data for this node, 1144 # except for the default key 'data'. 1145 GenAttributeStorage $name $node 1146 } 1147 upvar ${name}::$attribute($node) data 1148 1149 catch {unset data($key)} 1150 return 1151} 1152 1153# ::struct::tree::_walk -- 1154# 1155# Walk a tree using a pre-order depth or breadth first 1156# search. Pre-order DFS is the default. At each node that is visited, 1157# a command will be called with the name of the tree and the node. 1158# 1159# Arguments: 1160# name Name of the tree. 1161# node Node at which to start. 1162# args Optional additional arguments specifying the type and order of 1163# the tree walk, and the command to execute at each node. 1164# Format is 1165# ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd 1166# 1167# Results: 1168# None. 1169 1170proc ::struct::tree::_walk {name node args} { 1171 set usage "$name walk $node ?-type {bfs|dfs}? ?-order {pre|post|in|both}? -command cmd" 1172 1173 if {[llength $args] > 6 || [llength $args] < 2} { 1174 return -code error "wrong # args: should be \"$usage\"" 1175 } 1176 1177 if { ![_exists $name $node] } { 1178 return -code error "node \"$node\" does not exist in tree \"$name\"" 1179 } 1180 1181 # Set defaults 1182 set type dfs 1183 set order pre 1184 set cmd "" 1185 1186 for {set i 0} {$i < [llength $args]} {incr i} { 1187 set flag [lindex $args $i] 1188 incr i 1189 if { $i >= [llength $args] } { 1190 return -code error "value for \"$flag\" missing: should be \"$usage\"" 1191 } 1192 switch -glob -- $flag { 1193 "-type" { 1194 set type [string tolower [lindex $args $i]] 1195 } 1196 "-order" { 1197 set order [string tolower [lindex $args $i]] 1198 } 1199 "-command" { 1200 set cmd [lindex $args $i] 1201 } 1202 default { 1203 return -code error "unknown option \"$flag\": should be \"$usage\"" 1204 } 1205 } 1206 } 1207 1208 # Make sure we have a command to run, otherwise what's the point? 1209 if { [string equal $cmd ""] } { 1210 return -code error "no command specified: should be \"$usage\"" 1211 } 1212 1213 # Validate that the given type is good 1214 switch -exact -- $type { 1215 "dfs" - "bfs" { 1216 set type $type 1217 } 1218 default { 1219 return -code error "invalid search type \"$type\": should be dfs, or bfs" 1220 } 1221 } 1222 1223 # Validate that the given order is good 1224 switch -exact -- $order { 1225 "pre" - "post" - "in" - "both" { 1226 set order $order 1227 } 1228 default { 1229 return -code error "invalid search order \"$order\":\ 1230 should be pre, post, both, or in" 1231 } 1232 } 1233 1234 if {[string equal $order "in"] && [string equal $type "bfs"]} { 1235 return -code error "unable to do a ${order}-order breadth first walk" 1236 } 1237 1238 # Do the walk 1239 variable ${name}::children 1240 set st [list ] 1241 lappend st $node 1242 1243 # Compute some flags for the possible places of command evaluation 1244 set leave [expr {[string equal $order post] || [string equal $order both]}] 1245 set enter [expr {[string equal $order pre] || [string equal $order both]}] 1246 set touch [string equal $order in] 1247 1248 if {$leave} { 1249 set lvlabel leave 1250 } elseif {$touch} { 1251 # in-order does not provide a sense 1252 # of nesting for the parent, hence 1253 # no enter/leave, just 'visit'. 1254 set lvlabel visit 1255 } 1256 1257 if { [string equal $type "dfs"] } { 1258 # Depth-first walk, several orders of visiting nodes 1259 # (pre, post, both, in) 1260 1261 array set visited {} 1262 1263 while { [llength $st] > 0 } { 1264 set node [lindex $st end] 1265 1266 if {[info exists visited($node)]} { 1267 # Second time we are looking at this 'node'. 1268 # Pop it, then evaluate the command (post, both, in). 1269 1270 set st [lreplace $st end end] 1271 1272 if {$leave || $touch} { 1273 # Evaluate the command at this node 1274 WalkCall $name $node $lvlabel $cmd 1275 } 1276 } else { 1277 # First visit of this 'node'. 1278 # Do *not* pop it from the stack so that we are able 1279 # to visit again after its children 1280 1281 # Remember it. 1282 set visited($node) . 1283 1284 if {$enter} { 1285 # Evaluate the command at this node (pre, both) 1286 WalkCall $name $node "enter" $cmd 1287 } 1288 1289 # Add the children of this node to the stack. 1290 # The exact behaviour depends on the chosen 1291 # order. For pre, post, both-order we just 1292 # have to add them in reverse-order so that 1293 # they will be popped left-to-right. For in-order 1294 # we have rearrange the stack so that the parent 1295 # is revisited immediately after the first child. 1296 # (but only if there is ore than one child,) 1297 1298 set clist $children($node) 1299 set len [llength $clist] 1300 1301 if {$touch && ($len > 1)} { 1302 # Pop node from stack, insert into list of children 1303 set st [lreplace $st end end] 1304 set clist [linsert $clist 1 $node] 1305 incr len 1306 } 1307 1308 for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { 1309 lappend st [lindex $clist $i] 1310 } 1311 } 1312 } 1313 } else { 1314 # Breadth first walk (pre, post, both) 1315 # No in-order possible. Already captured. 1316 1317 if {$leave} { 1318 set backward $st 1319 } 1320 1321 while { [llength $st] > 0 } { 1322 set node [lindex $st 0] 1323 set st [lreplace $st 0 0] 1324 1325 if {$enter} { 1326 # Evaluate the command at this node 1327 WalkCall $name $node "enter" $cmd 1328 } 1329 1330 # Add this node's children 1331 # And create a mirrored version in case of post/both order. 1332 1333 foreach child $children($node) { 1334 lappend st $child 1335 if {$leave} { 1336 set backward [linsert $backward 0 $child] 1337 } 1338 } 1339 } 1340 1341 if {$leave} { 1342 foreach node $backward { 1343 # Evaluate the command at this node 1344 WalkCall $name $node "leave" $cmd 1345 } 1346 } 1347 } 1348 return 1349} 1350 1351# ::struct::tree::WalkCall -- 1352# 1353# Helper command to 'walk' handling the evaluation 1354# of the user-specified command. Information about 1355# the tree, node and current action are substituted 1356# into the command before it evaluation. 1357# 1358# Arguments: 1359# tree Tree we are walking 1360# node Node we are at. 1361# action The current action. 1362# cmd The command to call, already partially substituted. 1363# 1364# Results: 1365# None. 1366 1367proc ::struct::tree::WalkCall {tree node action cmd} { 1368 set subs [list %n [list $node] %a [list $action] %t [list $tree] %% %] 1369 uplevel 2 [string map $subs $cmd] 1370 return 1371} 1372 1373# ::struct::tree::GenerateUniqueNodeName -- 1374# 1375# Generate a unique node name for the given tree. 1376# 1377# Arguments: 1378# name Name of the tree to generate a unique node name for. 1379# 1380# Results: 1381# node Name of a node guaranteed to not exist in the tree. 1382 1383proc ::struct::tree::GenerateUniqueNodeName {name} { 1384 variable ${name}::nextUnusedNode 1385 while {[_exists $name "node${nextUnusedNode}"]} { 1386 incr nextUnusedNode 1387 } 1388 return "node${nextUnusedNode}" 1389} 1390 1391# ::struct::tree::KillNode -- 1392# 1393# Delete all data of a node. 1394# 1395# Arguments: 1396# name Name of the tree containing the node 1397# node Name of the node to delete. 1398# 1399# Results: 1400# none 1401 1402proc ::struct::tree::KillNode {name node} { 1403 variable ${name}::parent 1404 variable ${name}::children 1405 variable ${name}::attribute 1406 1407 # Remove all record of $node 1408 unset parent($node) 1409 unset children($node) 1410 1411 if {[info exists attribute($node)]} { 1412 # FRINK: nocheck 1413 unset ${name}::$attribute($node) 1414 unset attribute($node) 1415 } 1416 return 1417} 1418 1419# ::struct::tree::GenAttributeStorage -- 1420# 1421# Create an array to store the attrributes of a node in. 1422# 1423# Arguments: 1424# name Name of the tree containing the node 1425# node Name of the node which got attributes. 1426# 1427# Results: 1428# none 1429 1430proc ::struct::tree::GenAttributeStorage {name node} { 1431 variable ${name}::nextAttr 1432 variable ${name}::attribute 1433 1434 set attr "a[incr nextAttr]" 1435 set attribute($node) $attr 1436 upvar ${name}::$attr data 1437 set data(data) "" 1438 return 1439} 1440 1441# ::struct::tree::Serialize -- 1442# 1443# Serialize a tree object (partially) into a transportable value. 1444# 1445# Arguments: 1446# name Name of the tree. 1447# node Root node of the serialized tree. 1448# 1449# Results: 1450# None 1451 1452proc ::struct::tree::Serialize {name node tvar avar} { 1453 upvar 1 $tvar tree $avar attr 1454 1455 variable ${name}::children 1456 variable ${name}::attribute 1457 1458 # Store attribute data 1459 if {[info exists attribute($node)]} { 1460 set attr($node) [array get ${name}::$attribute($node)] 1461 } else { 1462 set attr($node) {} 1463 } 1464 1465 # Build tree structure as nested list. 1466 1467 set subtrees [list] 1468 foreach c $children($node) { 1469 Serialize $name $c sub attr 1470 lappend subtrees $sub 1471 } 1472 1473 set tree [list $node $subtrees] 1474 return 1475} 1476 1477# ### ### ### ######### ######### ######### 1478## Ready 1479 1480namespace eval ::struct { 1481 # Get 'tree::tree' into the general structure namespace. 1482 namespace import -force tree::tree 1483 namespace export tree 1484} 1485package provide struct::tree 1.2.2 1486