1# tree.tcl -- 2# 3# Package that defines the menubar::Tree class. This class is a 4# privite class used by the menubar class. 5# 6# Copyright (c) 2009 Tom Krehbiel <tomk@users.sourceforge.net> 7# 8# See the file "license.terms" for information on usage and redistribution 9# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10# 11# RCS: @(#) $Id: tree.tcl,v 1.5 2010/01/06 20:55:54 tomk Exp $ 12 13package require TclOO 14package require menubar::node 15 16package provide menubar::tree 0.5 17 18# -------------------------------------------------- 19# 20# menubar::Tree class - used by menubar class 21# 22# -------------------------------------------------- 23 24# -- 25# 26# nid - integer value used to create unique node names 27# root - name of tree's root node 28# nodes - index of node names and node instances 29# 30oo::class create ::menubar::tree { 31 32 self export varname 33 34 constructor { } { 35 variable root 36 variable nodes 37 38 my eval upvar [[self class] varname nid] nid 39 set nid 0 40 set root "root" 41 set nodes [dict create "root" [::menubar::node new ""]] 42 } 43 44 destructor { 45 variable nodes 46 dict for {name node} ${nodes} { 47 ${node} destroy 48 } 49 } 50 51 ##### PRIVITE ############################## 52 53 # -- 54 # used by debugging utility 55 method DumpSubtree { parent {indent 0} } { 56 set pnode [my Name2Node ${parent}] 57 puts "[format "%-12s" ${pnode}]- [string repeat { } ${indent}]${parent}" 58 incr indent 59 foreach child [${pnode} children] { 60 my DumpSubtree [my Node2Name ${child}] ${indent} 61 } 62 } 63 64 # -- 65 # check args for a node that exists and return its name 66 # else return "" 67 method NotUsed { args } { 68 variable nodes 69 foreach name ${args} { 70 if { [dict exists ${nodes} ${name}] } { 71 return ${name} 72 } 73 } 74 return "" 75 } 76 77 # -- 78 # return a node instance given a node name 79 method Name2Node { name } { 80 variable nodes 81 return [dict get ${nodes} ${name}] 82 } 83 84 # -- 85 # return a node name given a node instance 86 method Node2Name { node } { 87 variable nodes 88 dict for {name node} [dict filter ${nodes} value ${node}] { 89 return ${name} 90 } 91 error "node (${node}) - not found" 92 } 93 94 # -- 95 # return a list of node instances given a list of node names 96 method Names2NodeList { args } { 97 set nlist {} 98 foreach name ${args} { 99 lappend nlist [my Name2Node ${name}] 100 } 101 return ${nlist} 102 } 103 104 # -- 105 # return a list of node names given a list of node instances 106 method Nodes2NameList { args } { 107 set nlist {} 108 foreach node ${args} { 109 lappend nlist [my Node2Name ${node}] 110 } 111 return ${nlist} 112 } 113 114 # -- 115 # return the list of all nodes below parent node 116 # optionaly filter nodes useing procedure 'filter' 117 method GetSubtree { parent {filter ""} } { 118 variable nodes 119 set pnode [my Name2Node ${parent}] 120 set children [my Nodes2NameList {*}[${pnode} children]] 121 set subtree "" 122 foreach child ${children} { 123 if { ${filter} eq "" || [eval [list ${filter} [self object] ${child}]] == 0 } { 124 lappend subtree ${child} 125 lappend subtree {*}[my GetSubtree ${child} ${filter}] 126 } 127 } 128 return ${subtree} 129 } 130 131 # -- 132 # completely delete one node 133 method DeleteNode { name } { 134 variable root 135 variable nodes 136 set node [my Name2Node ${name}] 137 # delete node from index 138 set nodes [dict remove ${nodes} ${name}] 139 # create a new root node if it was deleted 140 if { ${name} eq ${root} } { 141 dict set nodes ${name} [::menubar::node new ""] 142 } 143 ${node} destroy 144 } 145 146 # -- 147 # replace the child entry for 'name' in its parent 148 # with 0 or more new children 149 method ReplaceParentLink { name args } { 150 set cnode [my Name2Node ${name}] 151 set pnode [${cnode} parent] 152 if { ${pnode} eq "" } { return } 153 set children [${pnode} children] 154 set idx [lsearch -exact ${children} ${cnode}] 155 if { ${idx} < 0 } { 156 error "node (${name}) - not found" 157 } 158 if { [llength ${args}] == 0 } { 159 set children [lreplace ${children} ${idx} ${idx}] 160 } else { 161 set nlist [my Names2NodeList {*}${args}] 162 set children [lreplace ${children} ${idx} ${idx} {*}${nlist}] 163 } 164 ${pnode} children ${children} -force 165 } 166 167 # -- 168 # Serialize a node and add it to stream. 169 # 170 # The result is a 3 element list haveing the following entries. 171 # 172 # 1) node name 173 # 2) the node's attributes in dictionary form 174 # 3) a recursive serialization of all children of the node 175 # 176 method SerializeNode { stream name {isroot 0}} { 177 variable root 178 variable nodes 179 # serialize the children 180 set children {} 181 foreach child [my children ${name}] { 182 lappend children {*}[my SerializeNode ${stream} ${child}] 183 } 184 set node [my Name2Node ${name}] 185 lappend stream ${name} [${node} attrs.filter] ${children} 186 return ${stream} 187 } 188 189 # -- 190 # Unlink a list of nodes from their parents. Note that a node 191 # may be in the subtree of a node that is being unlinked. 192 method UnlinkNodes { args } { 193 set notfound [my exists {*}${args}] 194 if { ${notfound} ne "" } { 195 error "node (${notfound}) - not found" 196 } 197 # Break the links to the parents 198 foreach name ${args} { 199 my ReplaceParentLink ${name} 200 set pnode [my Name2Node ${name}] 201 ${pnode} parent "" 202 } 203 } 204 205 # -- Pstream 206 # Pretty print a node from a serialization stream. 207 method Pstream { name attrs children indent } { 208 set pad [string repeat " " ${indent}] 209 puts "${pad}${name}" 210 puts "${pad} ${attrs}" 211 incr indent 212 foreach {n a c} ${children} { 213 my Pstream ${n} ${a} ${c} ${indent} 214 } 215 } 216 217 # -- 218 # pnode - parent node 219 # name - name of new node 220 # attrs - attribure dict for new node 221 # children - recursive list of child node serializations 222 method DeserializeNode { pnode name attrs children } { 223 variable nodes 224 # create the a node and set it's parent 225 set cnode [::menubar::node new ${pnode}] 226 # add the node to the index 227 dict set nodes ${name} ${cnode} 228 # set the node's attributes 229 ${cnode} attrs ${attrs} -force 230 # create all the children for the node 231 set cnodes {} 232 foreach {n a c} ${children} { 233 lappend cnodes [my DeserializeNode ${cnode} ${n} ${a} ${c}] 234 } 235 ${cnode} children ${cnodes} -force 236 return ${cnode} 237 } 238 239 ##### PUBLIC ############################## 240 241 242 # -- 243 # 244 method ancestors { child } { 245 if { [my exists ${child}] ne "" } { 246 error "node (${child}) - not found" 247 } 248 set ancestors {} 249 while { true } { 250 set ancestor [my parent ${child}] 251 if { ${ancestor} eq "" } { 252 break 253 } else { 254 lappend ancestors ${ancestor} 255 set child ${ancestor} 256 } 257 } 258 return ${ancestors} 259 } 260 261 # -- 262 # 263 method children { parent } { 264 variable nodes 265 if { [my exists ${parent}] ne "" } { 266 error "node (${parent}) - not found" 267 } 268 set pnode [my Name2Node ${parent}] 269 set children [${pnode} children] 270 return [my Nodes2NameList {*}${children}] 271 } 272 273 # -- 274 # Remove a node from the tree and move its 275 # children into the parent. Ignore cut on 276 # the root node. 277 method cut { name {opt ""} } { 278 variable nodes 279 if { ${name} eq [my rootname] } { return } 280 if { [my exists ${name}] ne "" } { 281 error "node (${name}) - not found" 282 } 283 # get the children for the node 284 set children [my children ${name}] 285 # replace the node with its childer in the parent 286 my ReplaceParentLink ${name} {*}${children} 287 if { ${opt} eq "-delete" } { 288 # delete the node 289 set node [my Name2Node ${name}] 290 dict unset nodes ${name} 291 ${node} destroy 292 } 293 return 294 } 295 296 # -- 297 # 298 method delete { args } { 299 set notfound [my exists {*}${args}] 300 if { ${notfound} ne "" } { 301 error "node (${notfound}) - not found" 302 } 303 # Remove all the subtree nodes. 304 # This code accounts for the possibility that 305 # one of the args is in the subtree of another arg. 306 set names {} 307 foreach name ${args} { 308 lappend names {*}[my descendants ${name}] 309 } 310 foreach name [lsort -unique ${names}] { 311 my DeleteNode ${name} 312 } 313 # Now remove the nodes themselves and their child 314 # entry in their parent 315 foreach name ${args} { 316 my ReplaceParentLink ${name} 317 my DeleteNode ${name} 318 } 319 return 320 } 321 322 # -- 323 # 324 method depth { name } { 325 return [llength [my ancestors ${name}]] 326 } 327 328 # -- 329 # 330 method descendants { parent {opt ""} {arg ""} } { 331 variable nodes 332 if { [my exists ${parent}] ne "" } { 333 error "node (${parent}) - not found" 334 } 335 if { ${opt} eq "-filter" } { 336 set filter ${arg} 337 return [my GetSubtree ${parent} ${filter}] 338 } else { 339 return [my GetSubtree ${parent}] 340 } 341 } 342 343 # -- 344 # Replace the attribute and subtree definitions of node 345 # 'lname' with the definitions found in 'stream'. The 'lname' 346 # node must be a leaf node unless the '-force' option is is 347 # used. 348 method deserialize { lname stream {opt ""} } { 349 variable root 350 variable nodes 351 if { [my exists ${lname}] ne "" } { 352 error "node (${lname}) - not found" 353 } 354 if { ${opt} eq "-force" } { 355 # force lname to be a leaf 356 set parent [my parent ${lname}] 357 my delete ${lname} 358 set node [::menubar::node new [my Name2Node ${parent}]] 359 dict set nodes ${lname} ${node} 360 } 361 if { ![my isleaf ${lname}] } { 362 error "node (${lname}) - is not a leaf node" 363 } 364 # get the leaf node 365 set lnode [my Name2Node ${lname}] 366 # get the root of the serialization 367 lassign ${stream} rname attrs children 368 # put attributes in the leaf node 369 ${lnode} attrs ${attrs} -force 370 # deserialize all the children into the leaf node 371 set cnodes {} 372 foreach {n a c} ${children} { 373 lappend cnodes [my DeserializeNode ${lnode} ${n} ${a} ${c}] 374 } 375 ${lnode} children ${cnodes} -force 376 return 377 } 378 379 # -- 380 # return "" if all exist else return name that isn't found 381 method exists { args } { 382 variable nodes 383 foreach name ${args} { 384 if { ![dict exists ${nodes} ${name}] } { 385 return ${name} 386 } 387 } 388 return "" 389 } 390 391 # -- 392 # 393 method index { name } { 394 if { [my exists ${name}] ne "" } { 395 error "node (${name}) - not found" 396 } 397 set cnode [my Name2Node ${name}] 398 set pnode [${cnode} parent] 399 set children [${pnode} children] 400 return [lsearch -exact ${children} ${cnode}] 401 } 402 403 # -- 404 # 405 method insert { parent index args } { 406 variable nid 407 variable nodes 408 if { [llength ${args}] == 0 } { 409 incr nid 410 set args "node${nid}" 411 } else { 412 if { ${parent} in ${args} } { 413 error "parent (${parent}) - found in insert list" 414 } 415 } 416 set pnode [my Name2Node ${parent}] 417 set nlist "" 418 foreach name ${args} { 419 if { [my exists ${name}] ne "" } { 420 # create a new child that references the parent 421 set node [::menubar::node new ${pnode}] 422 # add the node to the index 423 dict set nodes ${name} ${node} 424 } else { 425 # child already exists so it must be cut from its 426 # current location 427 my UnlinkNodes ${name} 428 set node [my Name2Node ${name}] 429 ${node} parent ${pnode} 430 } 431 lappend nlist ${node} 432 } 433 # insert the list of child nodes into the 434 # parent's list of children 435 if { [llength ${nlist}] > 0 } { 436 ${pnode} insert ${index} {*}${nlist} 437 } 438 return ${args} 439 } 440 441 # -- 442 # 443 method isleaf { name } { 444 if { [my exists ${name}] ne "" } { 445 error "node (${name}) - not found" 446 } 447 set node [my Name2Node ${name}] 448 return [expr ( [llength [${node} children]] > 0 ) ? 0 : 1] 449 } 450 451 # -- 452 # 453 method keys { {name ""} {gpat ""} } { 454 if { ${name} eq "" } { 455 set nlist [my nodes] 456 } else { 457 set nlist ${name} 458 } 459 set result {} 460 foreach name ${nlist} { 461 set node [my Name2Node ${name}] 462 if { ${gpat} eq "" } { 463 lappend result {*}[${node} attr.keys] 464 } else { 465 set d [dict create {*}[${node} attrs.filter ${gpat}]] 466 lappend result {*}[dict keys ${d}] 467 } 468 } 469 return [lsort -unique ${result}] 470 } 471 472 # -- 473 # 474 method key.append { name key value } { 475 if { [my exists ${name}] ne "" } { 476 error "node (${name}) - not found" 477 } 478 set node [my Name2Node ${name}] 479 ${node} attr.append ${key} ${value} 480 return 481 } 482 483 # -- 484 # 485 method key.exists { name key } { 486 if { [my exists ${name}] ne "" } { 487 error "node (${name}) - not found" 488 } 489 set node [my Name2Node ${name}] 490 return [${node} attr.exists ${key}] 491 } 492 493 # -- 494 # 495 method key.get { name key } { 496 if { [my exists ${name}] ne "" } { 497 error "node (${name}) - not found" 498 } 499 set node [my Name2Node ${name}] 500 return [${node} attr.get ${key}] 501 } 502 503 # -- 504 # 505 method key.getall { name {globpat ""} } { 506 if { [my exists ${name}] ne "" } { 507 error "node (${name}) - not found" 508 } 509 set node [my Name2Node ${name}] 510 return [${node} attrs.filter ${globpat}] 511 } 512 513 # -- 514 # 515 method key.lappend { name key value } { 516 if { [my exists ${name}] ne "" } { 517 error "node (${name}) - not found" 518 } 519 set node [my Name2Node ${name}] 520 ${node} attr.lappend ${key} ${value} 521 return [${node} attr.get ${key}] 522 } 523 524 # -- 525 # 526 method key.nodes { key {flag ""} {arg ""} } { 527 set result {} 528 set names [my nodes] 529 switch -exact ${flag} { 530 "-nodes" { 531 set names ${arg} 532 } 533 "-glob" { 534 set nlist {} 535 set gpat ${arg} 536 foreach name ${names} { 537 if { [string match ${gpat} ${name}] == 1 } { 538 lappend nlist ${name} 539 } 540 } 541 set names ${nlist} 542 } 543 "-regexp" { 544 set nlist {} 545 set rpat ${arg} 546 foreach name ${names} { 547 if { [regexp ${rpat} ${name}] == 1 } { 548 lappend nlist ${name} 549 } 550 } 551 set names ${nlist} 552 } 553 default { 554 }} 555 foreach name ${names} { 556 if { [my key.exists ${name} ${key}] } { 557 lappend result ${name} [my key.get ${name} ${key}] 558 } 559 } 560 return ${result} 561 } 562 563 # -- 564 # 565 method key.set { name key args } { 566 if { [my exists ${name}] ne "" } { 567 error "node (${name}) - not found" 568 } 569 set node [my Name2Node ${name}] 570 if { [llength ${args}] == 1 } { 571 ${node} attr.set ${key} [lindex ${args} 0] 572 } 573 return [${node} attr.get ${key}] 574 } 575 576 577 # -- 578 # 579 method key.unset { name key } { 580 if { [my exists ${name}] ne "" } { 581 error "node (${name}) - not found" 582 } 583 set node [my Name2Node ${name}] 584 ${node} attr.unset ${key} 585 } 586 # -- 587 # 588 method leaves { } { 589 set leaves {} 590 foreach name [my nodes] { 591 if { [my isleaf ${name}] == 1 } { 592 lappend leaves ${name} 593 } 594 } 595 return ${leaves} 596 } 597 598 # -- 599 # 600 method move { parent index args } { 601 set pnode [my Name2Node ${parent}] 602 # Make sure the list of nodes doesn't contain an 603 # ancestor of the parent. If this were allowed the 604 # subtree would become disconnected. 605 set alist [my ancestors ${parent}] 606 foreach name ${args} { 607 if { [my exists ${name}] ne "" } { 608 error "node (${name}) - not found" 609 } 610 if { ${name} in ${alist} } { 611 error "node (${name}) is an ancestor of node (${parent})" 612 } 613 } 614 # unlink the nodes 615 set nlist {} 616 foreach name ${args} { 617 my UnlinkNodes ${name} 618 set node [my Name2Node ${name}] 619 ${node} parent ${pnode} 620 lappend nlist ${node} 621 } 622 # link the nodes into the parent at location 'index' 623 set children [${pnode} children] 624 ${pnode} children [linsert ${children} ${index} {*}${nlist}] 625 return 626 } 627 628 # -- 629 # 630 method next { name } { 631 if { [my exists ${name}] ne "" } { 632 error "node (${name}) - not found" 633 } 634 set cnode [my Name2Node ${name}] 635 set pnode [${cnode} parent] 636 set children [${pnode} children] 637 set idx [lsearch -exact ${children} ${cnode}] 638 incr idx 639 if { ${idx} < [llength ${children}] } { 640 return [my Node2Name [lindex ${children} ${idx}]] 641 } else { 642 return "" 643 } 644 } 645 646 # -- 647 # 648 method numchildren { name } { 649 if { [my exists ${name}] ne "" } { 650 error "node (${name}) - not found" 651 } 652 set node [my Name2Node ${name}] 653 return [llength [${node} children]] 654 } 655 656 # -- 657 # 658 method nodes { } { 659 variable nodes 660 return [dict keys ${nodes}] 661 } 662 663 # -- 664 # 665 method parent { child } { 666 variable nodes 667 if { [my exists ${child}] ne "" } { 668 error "node (${child}) - not found" 669 } 670 set cnode [my Name2Node ${child}] 671 set pnode [${cnode} parent] 672 if { ${pnode} eq "" } { 673 return "" 674 } else { 675 return [my Node2Name ${pnode}] 676 } 677 } 678 679 # -- 680 # 681 method previous { name } { 682 if { [my exists ${name}] ne "" } { 683 error "node (${name}) - not found" 684 } 685 set cnode [my Name2Node ${name}] 686 set pnode [${cnode} parent] 687 set children [${pnode} children] 688 set idx [lsearch -exact ${children} ${cnode}] 689 incr idx -1 690 if { ${idx} >= 0 } { 691 return [my Node2Name [lindex ${children} ${idx}]] 692 } else { 693 return "" 694 } 695 } 696 697 # -- 698 # 699 method rename { from to } { 700 variable root 701 variable nodes 702 if { ![dict exists ${nodes} ${from}] } { 703 error "node (${to}) - not found" 704 } 705 if { [dict exists ${nodes} ${to}] } { 706 error "node (${to}) - already exists" 707 } 708 set node [dict get ${nodes} ${from}] 709 set nodes [dict remove ${nodes} ${from}] 710 dict set nodes ${to} ${node} 711 if { ${from} eq ${root} } { 712 set root ${to} 713 } 714 return 715 } 716 717 # -- 718 # 719 method rootname { } { 720 variable root 721 return ${root} 722 } 723 724 # -- 725 # Return a serialization of the subtree starting at 'name'. 726 # 727 # The result is a list containing three element. The elements 728 # are (1) a node name (2) the node's attributes in dictionary 729 # form (3) zero or more additional three element lists that 730 # recursivly serialize the children of the node. 731 # 732 method serialize { name } { 733 variable root 734 variable nodes 735 if { ${name} ne "root" && [my exists ${name}] ne "" } { 736 error "node (${name}) - not found" 737 } 738 # create the null node 739 set stream {} 740 set stream [my SerializeNode ${stream} ${name} 1] 741 return ${stream} 742 } 743 744 # -- 745 # 746 method size { {name ""} } { 747 if { ${name} eq "" } { 748 set name [my rootname] 749 } else { 750 if { [my exists ${name}] ne "" } { 751 error "node (${name}) - not found" 752 } 753 } 754 return [llength [my descendants ${name}]] 755 756 } 757 758 # -- 759 # 760 method splice { parent from {to ""} {child ""} } { 761 variable nid 762 variable nodes 763 if { ${parent} eq "root" } { 764 set parent [my rootname] 765 } else { 766 if { [my exists ${parent}] ne "" } { 767 error "node (${parent}) - not found" 768 } 769 } 770 if { ${to} eq "" } { 771 set to "end" 772 } 773 if { ${child} eq "" } { 774 incr nid 775 set child "node${nid}" 776 } else { 777 if { [my NotUsed ${child}] ne "" } { 778 error "node (${child}) - already exists" 779 } 780 } 781 # get the parent information 782 set pnode [my Name2Node ${parent}] 783 # create the new child 784 set node [::menubar::node new ${pnode}] 785 # add the node to the index 786 dict set nodes ${child} ${node} 787 # get the parents children 788 set children [${pnode} children] 789 # put the range of childern in the new node 790 ${node} children [lrange ${children} ${from} ${to}] -force 791 # remove the range of children from the parent and insert the new node 792 ${pnode} children [lreplace ${children} ${from} ${to} ${node}] -force 793 return ${child} 794 } 795 796 # -- 797 # 798 method swap { name1 name2 } { 799 if { ${name1} eq ${name2} } { return } 800 # make sure the nodes exist 801 if { [my exists ${name1}] ne "" } { 802 error "node (${name1}) - not found" 803 } 804 if { [my exists ${name2}] ne "" } { 805 error "node (${name2}) - not found" 806 } 807 # make sure one node isn't in the the other node's subtree 808 # (this also precludes a swap with 'root') 809 set node1 [my Name2Node ${name1}] 810 set node2 [my Name2Node ${name2}] 811 if { [lsearch -exact [my descendants ${name1}] ${name2}] != -1 } { 812 error "node (${name2}) in subtree of node (${name1})" 813 } 814 if { [lsearch -exact [my descendants ${name2}] ${name1}] != -1 } { 815 error "node (${name1}) in subtree of node (${name2})" 816 } 817 # check to see if the nodes have a common parent 818 set pnode1 [${node1} parent] 819 set pnode2 [${node2} parent] 820 if { ${pnode1} eq ${pnode2} } { 821 # nodes have a common parent node 822 set children [${pnode1} children] 823 set idx1 [lsearch -exact ${children} ${node1}] 824 set idx2 [lsearch -exact ${children} ${node2}] 825 set children [lreplace ${children} ${idx1} ${idx1} ${node2}] 826 set children [lreplace ${children} ${idx2} ${idx2} ${node1}] 827 ${pnode1} children ${children} -force 828 } else { 829 # nodes have different parent nodes 830 set children1 [${pnode1} children] 831 set children2 [${pnode2} children] 832 set idx1 [lsearch -exact ${children1} ${node1}] 833 set idx2 [lsearch -exact ${children2} ${node2}] 834 set children1 [lreplace ${children1} ${idx1} ${idx1} ${node2}] 835 set children2 [lreplace ${children2} ${idx2} ${idx2} ${node1}] 836 ${pnode1} children ${children1} -force 837 ${pnode2} children ${children2} -force 838 ${node1} parent ${pnode2} 839 ${node2} parent ${pnode1} 840 } 841 return 842 } 843 844 ##### WALKPROC CODE (DEPTH FIRST) ############################ 845 846 # -- 847 # 848 method DfsPreOrderWalk { name cmdprefix } { 849 variable nodes 850 if { [catch {${cmdprefix} [self object] ${name} "enter"} bool] || ${bool} != 0 } { 851 #puts "bool: $bool" 852 # shutdown the walk 853 return 1 854 } 855 set node [my Name2Node ${name}] 856 for {set idx 0} { true } {incr idx} { 857 set children [my children ${name}] 858 if { ${idx} >= [llength ${children}] } { 859 break 860 } 861 set child [lindex [my children ${name}] ${idx}] 862 if { [my PreOrderWalk ${child} ${cmdprefix}] != 0 } { 863 return 1 864 } 865 } 866 return 0 867 } 868 869 # -- 870 # 871 method DfsPostOrderWalk { name cmdprefix } { 872 variable nodes 873 variable nodes 874 set node [my Name2Node ${name}] 875 for {set idx 0} { true } {incr idx} { 876 set children [my children ${name}] 877 if { ${idx} >= [llength ${children}] } { 878 break 879 } 880 set child [lindex [my children ${name}] ${idx}] 881 if { [my PostOrderWalk ${child} ${cmdprefix}] != 0 } { 882 return 1 883 } 884 } 885 if { [catch {${cmdprefix} [self object] ${name} "leave"} bool] || ${bool} != 0 } { 886 #puts "bool: $bool" 887 # shutdown the walk 888 return 1 889 } 890 return 0 891 } 892 893 # -- 894 # 895 method DfsBothOrderWalk { name cmdprefix } { 896 variable nodes 897 if { [catch {${cmdprefix} [self object] ${name} "enter"} bool] || ${bool} != 0 } { 898 #puts "bool: $bool" 899 # shutdown the walk 900 return 1 901 } 902 set node [my Name2Node ${name}] 903 for {set idx 0} { true } {incr idx} { 904 set children [my children ${name}] 905 if { ${idx} >= [llength ${children}] } { 906 break 907 } 908 set child [lindex [my children ${name}] ${idx}] 909 if { [my BothOrderWalk ${child} ${cmdprefix}] != 0 } { 910 return 1 911 } 912 } 913 if { [catch {${cmdprefix} [self object] ${name} "leave"} bool] || ${bool} != 0 } { 914 #puts "bool: $bool" 915 # shutdown the walk 916 return 1 917 } 918 return 0 919 } 920 921 # -- 922 # 923 method DfsInOrderWalk { name cmdprefix } { 924 variable nodes 925 set node [my Name2Node ${name}] 926 for {set idx 0} { true } {incr idx} { 927 if { ${idx} == 1 } { 928 if { [catch {${cmdprefix} [self object] ${name} "visit"} bool] || ${bool} != 0 } { 929 #puts "bool: $bool" 930 # shutdown the walk 931 return 1 932 } 933 } 934 set children [my children ${name}] 935 if { ${idx} >= [llength ${children}] } { 936 break 937 } 938 set child [lindex [my children ${name}] ${idx}] 939 if { [my InOrderWalk ${child} ${cmdprefix}] != 0 } { 940 return 1 941 } 942 } 943 if { ${idx} == 0 } { 944 if { [catch {${cmdprefix} [self object] ${name} "visit"} bool] || ${bool} != 0 } { 945 #puts "bool: $bool" 946 # shutdown the walk 947 return 1 948 } 949 } 950 return 0 951 } 952 953 ##### WALKPROC CODE (BREADTH FIRST) ############################ 954 955 # -- 956 # This method takes as input a list of nodes (nlist) and returns 957 # a new list that is the list of all children for the input list. 958 method DecendOneLevelForward { nlist } { 959 set result {} 960 foreach node ${nlist} { 961 lappend result {*}[${node} children] 962 } 963 return ${result} 964 } 965 # -- 966 # This method takes as input a list of nodes (nlist) and returns 967 # a new list that is the list of all children for the input list. 968 method DecendOneLevelBackward { nlist } { 969 set result {} 970 foreach node ${nlist} { 971 lappend result {*}[lreverse [${node} children]] 972 } 973 return ${result} 974 } 975 976 977 # -- 978 # 979 method BfsPreOrderWalk { nlist cmdprefix } { 980 if { [llength ${nlist}] == 0 } { return 0 } 981 foreach node ${nlist} { 982 if { [catch {${cmdprefix} [self object] [my Node2Name ${node}] "enter"} bool] || ${bool} != 0 } { 983 #puts "bool: $bool" 984 # shutdown the walk 985 return 1 986 } 987 } 988 if { [my BfsPreOrderWalk [my DecendOneLevelForward ${nlist}] ${cmdprefix}] != 0 } { 989 return 1 990 } 991 return 0 992 } 993 994 # -- 995 # 996 method BfsPostOrderWalk { nlist cmdprefix } { 997 if { [llength ${nlist}] == 0 } { return 0 } 998 if { [my BfsPostOrderWalk [my DecendOneLevelBackward ${nlist}] ${cmdprefix}] != 0 } { 999 return 1 1000 } 1001 foreach node ${nlist} { 1002 if { [catch {${cmdprefix} [self object] [my Node2Name ${node}] "leave"} bool] || ${bool} != 0 } { 1003 #puts "bool: $bool" 1004 # shutdown the walk 1005 return 1 1006 } 1007 } 1008 return 0 1009 } 1010 1011 # -- 1012 # 1013 method BfsBothOrderWalk { nlist cmdprefix } { 1014 if { [llength ${nlist}] == 0 } { return 0 } 1015 foreach node ${nlist} { 1016 if { [catch {${cmdprefix} [self object] [my Node2Name ${node}] "enter"} bool] || ${bool} != 0 } { 1017 #puts "bool: $bool" 1018 # shutdown the walk 1019 return 1 1020 } 1021 } 1022 my BfsBothOrderWalk [my DecendOneLevelForward ${nlist}] ${cmdprefix} 1023 foreach node [lreverse ${nlist}] { 1024 if { [catch {${cmdprefix} [self object] [my Node2Name ${node}] "leave"} bool] || ${bool} != 0 } { 1025 #puts "bool: $bool" 1026 # shutdown the walk 1027 return 1 1028 } 1029 } 1030 return 0 1031 } 1032 1033 # -- 1034 # 1035 method BfsInOrderWalk { } { 1036 error "unable to do a in-order breadth first walk" 1037 } 1038 1039 1040 # -- 1041 # 1042 method walkproc { name cmdprefix args } { 1043 set types {bfs dfs} 1044 set orders {pre post both in} 1045 set type "dfs" 1046 set order "pre" 1047 if { [my exists ${name}] ne "" } { 1048 error "node (${name}) - not found" 1049 } 1050 foreach {opt val} ${args} { 1051 switch -exact -- ${opt} { 1052 "-order" { 1053 if { ${val} ni ${orders} } { 1054 error "-order ${val} - must be oneof: [join ${orders} {, }]" 1055 } 1056 set order ${val} 1057 } 1058 "-type" { 1059 if { ${val} ni ${types} } { 1060 error "-type ${val} - must be oneof: [join ${types} {, }]" 1061 } 1062 set type ${val} 1063 } 1064 default { 1065 }} 1066 } 1067 1068 if { ${type} eq "dfs" } { 1069 switch -exact -- ${order} { 1070 "post" { 1071 my DfsPostOrderWalk ${name} ${cmdprefix} 1072 } 1073 "both" { 1074 my DfsBothOrderWalk ${name} ${cmdprefix} 1075 } 1076 "in" { 1077 my DfsInOrderWalk ${name} ${cmdprefix} 1078 } 1079 "pre" - 1080 default { 1081 my DfsPreOrderWalk ${name} ${cmdprefix} 1082 }} 1083 } else { 1084 switch -exact -- ${order} { 1085 "post" { 1086 my BfsPostOrderWalk [my Name2Node ${name}] ${cmdprefix} 1087 } 1088 "both" { 1089 my BfsBothOrderWalk [my Name2Node ${name}] ${cmdprefix} 1090 } 1091 "in" { 1092 my BfsInOrderWalk 1093 } 1094 "pre" - 1095 default { 1096 my BfsPreOrderWalk [my Name2Node ${name}] ${cmdprefix} 1097 }} 1098 } 1099 return 1100 } 1101} 1102