1# graph.tcl -- 2# 3# Implementation of a graph data structure for Tcl. 4# 5# Copyright (c) 2000 by Andreas Kupries 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: graph1.tcl,v 1.5 2008/08/13 20:30:58 mic42 Exp $ 11 12# Create the namespace before determining cgraph vs. tcl 13# Otherwise the loading 'struct.tcl' may get into trouble 14# when trying to import commands from them 15 16namespace eval ::struct {} 17namespace eval ::struct::graph {} 18 19# Try to load the cgraph package 20 21if {![catch {package require cgraph 0.6}]} { 22 # the cgraph package takes over, so we can return 23 return 24} 25 26namespace eval ::struct {} 27namespace eval ::struct::graph { 28 # Data storage in the graph module 29 # ------------------------------- 30 # 31 # There's a lot of bits to keep track of for each graph: 32 # nodes 33 # node values 34 # node relationships (arcs) 35 # arc values 36 # 37 # It would quickly become unwieldy to try to keep these in arrays or lists 38 # within the graph namespace itself. Instead, each graph structure will 39 # get its own namespace. Each namespace contains: 40 # node:$node array mapping keys to values for the node $node 41 # arc:$arc array mapping keys to values for the arc $arc 42 # inArcs array mapping nodes to the list of incoming arcs 43 # outArcs array mapping nodes to the list of outgoing arcs 44 # arcNodes array mapping arcs to the two nodes (start & end) 45 46 # counter is used to give a unique name for unnamed graph 47 variable counter 0 48 49 # commands is the list of subcommands recognized by the graph 50 variable commands [list \ 51 "arc" \ 52 "arcs" \ 53 "destroy" \ 54 "get" \ 55 "getall" \ 56 "keys" \ 57 "keyexists" \ 58 "node" \ 59 "nodes" \ 60 "set" \ 61 "swap" \ 62 "unset" \ 63 "walk" \ 64 ] 65 66 variable arcCommands [list \ 67 "append" \ 68 "delete" \ 69 "exists" \ 70 "get" \ 71 "getall" \ 72 "insert" \ 73 "keys" \ 74 "keyexists" \ 75 "lappend" \ 76 "set" \ 77 "source" \ 78 "target" \ 79 "unset" \ 80 ] 81 82 variable nodeCommands [list \ 83 "append" \ 84 "degree" \ 85 "delete" \ 86 "exists" \ 87 "get" \ 88 "getall" \ 89 "insert" \ 90 "keys" \ 91 "keyexists" \ 92 "lappend" \ 93 "opposite" \ 94 "set" \ 95 "unset" \ 96 ] 97 98 # Only export one command, the one used to instantiate a new graph 99 namespace export graph 100} 101 102# ::struct::graph::graph -- 103# 104# Create a new graph with a given name; if no name is given, use 105# graphX, where X is a number. 106# 107# Arguments: 108# name name of the graph; if null, generate one. 109# 110# Results: 111# name name of the graph created 112 113proc ::struct::graph::graph {{name ""}} { 114 variable counter 115 116 if { [llength [info level 0]] == 1 } { 117 incr counter 118 set name "graph${counter}" 119 } 120 121 if { ![string equal [info commands ::$name] ""] } { 122 error "command \"$name\" already exists, unable to create graph" 123 } 124 125 # Set up the namespace 126 namespace eval ::struct::graph::graph$name { 127 128 # Set up the map for values associated with the graph itself 129 variable graphData 130 array set graphData {data ""} 131 132 # Set up the map from nodes to the arcs coming to them 133 variable inArcs 134 array set inArcs {} 135 136 # Set up the map from nodes to the arcs going out from them 137 variable outArcs 138 array set outArcs {} 139 140 # Set up the map from arcs to the nodes they touch. 141 variable arcNodes 142 array set arcNodes {} 143 144 # Set up a value for use in creating unique node names 145 variable nextUnusedNode 146 set nextUnusedNode 1 147 148 # Set up a value for use in creating unique arc names 149 variable nextUnusedArc 150 set nextUnusedArc 1 151 } 152 153 # Create the command to manipulate the graph 154 interp alias {} ::$name {} ::struct::graph::GraphProc $name 155 156 return $name 157} 158 159########################## 160# Private functions follow 161 162# ::struct::graph::GraphProc -- 163# 164# Command that processes all graph object commands. 165# 166# Arguments: 167# name name of the graph object to manipulate. 168# args command name and args for the command 169# 170# Results: 171# Varies based on command to perform 172 173proc ::struct::graph::GraphProc {name {cmd ""} args} { 174 # Do minimal args checks here 175 if { [llength [info level 0]] == 2 } { 176 error "wrong # args: should be \"$name option ?arg arg ...?\"" 177 } 178 179 # Split the args into command and args components 180 if { [llength [info commands ::struct::graph::_$cmd]] == 0 } { 181 variable commands 182 set optlist [join $commands ", "] 183 set optlist [linsert $optlist "end-1" "or"] 184 error "bad option \"$cmd\": must be $optlist" 185 } 186 eval [list ::struct::graph::_$cmd $name] $args 187} 188 189# ::struct::graph::_arc -- 190# 191# Dispatches the invocation of arc methods to the proper handler 192# procedure. 193# 194# Arguments: 195# name name of the graph. 196# cmd arc command to invoke 197# args arguments to propagate to the handler for the arc command 198# 199# Results: 200# As of the invoked handler. 201 202proc ::struct::graph::_arc {name cmd args} { 203 204 # Split the args into command and args components 205 if { [llength [info commands ::struct::graph::__arc_$cmd]] == 0 } { 206 variable arcCommands 207 set optlist [join $arcCommands ", "] 208 set optlist [linsert $optlist "end-1" "or"] 209 error "bad option \"$cmd\": must be $optlist" 210 } 211 212 eval [list ::struct::graph::__arc_$cmd $name] $args 213} 214 215# ::struct::graph::__arc_delete -- 216# 217# Remove an arc from a graph, including all of its values. 218# 219# Arguments: 220# name name of the graph. 221# args list of arcs to delete. 222# 223# Results: 224# None. 225 226proc ::struct::graph::__arc_delete {name args} { 227 228 foreach arc $args { 229 if { ![__arc_exists $name $arc] } { 230 error "arc \"$arc\" does not exist in graph \"$name\"" 231 } 232 } 233 234 upvar ::struct::graph::graph${name}::inArcs inArcs 235 upvar ::struct::graph::graph${name}::outArcs outArcs 236 upvar ::struct::graph::graph${name}::arcNodes arcNodes 237 238 foreach arc $args { 239 foreach {source target} $arcNodes($arc) break ; # lassign 240 241 unset arcNodes($arc) 242 # FRINK: nocheck 243 unset ::struct::graph::graph${name}::arc$arc 244 245 # Remove arc from the arc lists of source and target nodes. 246 247 set index [lsearch -exact $outArcs($source) $arc] 248 set outArcs($source) [lreplace $outArcs($source) $index $index] 249 250 set index [lsearch -exact $inArcs($target) $arc] 251 set inArcs($target) [lreplace $inArcs($target) $index $index] 252 } 253 254 return 255} 256 257# ::struct::graph::__arc_exists -- 258# 259# Test for existance of a given arc in a graph. 260# 261# Arguments: 262# name name of the graph. 263# arc arc to look for. 264# 265# Results: 266# 1 if the arc exists, 0 else. 267 268proc ::struct::graph::__arc_exists {name arc} { 269 return [info exists ::struct::graph::graph${name}::arcNodes($arc)] 270} 271 272# ::struct::graph::__arc_get -- 273# 274# Get a keyed value from an arc in a graph. 275# 276# Arguments: 277# name name of the graph. 278# arc arc to query. 279# flag -key; anything else is an error 280# key key to lookup; defaults to data 281# 282# Results: 283# value value associated with the key given. 284 285proc ::struct::graph::__arc_get {name arc {flag -key} {key data}} { 286 if { ![__arc_exists $name $arc] } { 287 error "arc \"$arc\" does not exist in graph \"$name\"" 288 } 289 290 upvar ::struct::graph::graph${name}::arc${arc} data 291 292 if { ![info exists data($key)] } { 293 error "invalid key \"$key\" for arc \"$arc\"" 294 } 295 296 return $data($key) 297} 298 299# ::struct::graph::__arc_getall -- 300# 301# Get a serialized array of key/value pairs from an arc in a graph. 302# 303# Arguments: 304# name name of the graph. 305# arc arc to query. 306# 307# Results: 308# value serialized array of key/value pairs. 309 310proc ::struct::graph::__arc_getall {name arc args} { 311 if { ![__arc_exists $name $arc] } { 312 error "arc \"$arc\" does not exist in graph \"$name\"" 313 } 314 315 if { [llength $args] } { 316 error "wrong # args: should be none" 317 } 318 319 upvar ::struct::graph::graph${name}::arc${arc} data 320 321 return [array get data] 322} 323 324# ::struct::graph::__arc_keys -- 325# 326# Get a list of keys for an arc in a graph. 327# 328# Arguments: 329# name name of the graph. 330# arc arc to query. 331# 332# Results: 333# value value associated with the key given. 334 335proc ::struct::graph::__arc_keys {name arc args} { 336 if { ![__arc_exists $name $arc] } { 337 error "arc \"$arc\" does not exist in graph \"$name\"" 338 } 339 340 if { [llength $args] } { 341 error "wrong # args: should be none" 342 } 343 344 upvar ::struct::graph::graph${name}::arc${arc} data 345 346 return [array names data] 347} 348 349# ::struct::graph::__arc_keyexists -- 350# 351# Test for existance of a given key for a given arc in a graph. 352# 353# Arguments: 354# name name of the graph. 355# arc arc to query. 356# flag -key; anything else is an error 357# key key to lookup; defaults to data 358# 359# Results: 360# 1 if the key exists, 0 else. 361 362proc ::struct::graph::__arc_keyexists {name arc {flag -key} {key data}} { 363 if { ![__arc_exists $name $arc] } { 364 error "arc \"$arc\" does not exist in graph \"$name\"" 365 } 366 367 if { ![string equal $flag "-key"] } { 368 error "invalid option \"$flag\": should be -key" 369 } 370 371 upvar ::struct::graph::graph${name}::arc${arc} data 372 373 return [info exists data($key)] 374} 375 376# ::struct::graph::__arc_insert -- 377# 378# Add an arc to a graph. 379# 380# Arguments: 381# name name of the graph. 382# source source node of the new arc 383# target target node of the new arc 384# args arc to insert; must be unique. If none is given, 385# the routine will generate a unique node name. 386# 387# Results: 388# arc The name of the new arc. 389 390proc ::struct::graph::__arc_insert {name source target args} { 391 392 if { [llength $args] == 0 } { 393 # No arc name was given; generate a unique one 394 set arc [__generateUniqueArcName $name] 395 } else { 396 set arc [lindex $args 0] 397 } 398 399 if { [__arc_exists $name $arc] } { 400 error "arc \"$arc\" already exists in graph \"$name\"" 401 } 402 403 if { ![__node_exists $name $source] } { 404 error "source node \"$source\" does not exist in graph \"$name\"" 405 } 406 407 if { ![__node_exists $name $target] } { 408 error "target node \"$target\" does not exist in graph \"$name\"" 409 } 410 411 upvar ::struct::graph::graph${name}::inArcs inArcs 412 upvar ::struct::graph::graph${name}::outArcs outArcs 413 upvar ::struct::graph::graph${name}::arcNodes arcNodes 414 upvar ::struct::graph::graph${name}::arc${arc} data 415 416 # Set up the new arc 417 set data(data) "" 418 set arcNodes($arc) [list $source $target] 419 420 # Add this arc to the arc lists of its source resp. target nodes. 421 lappend outArcs($source) $arc 422 lappend inArcs($target) $arc 423 424 return $arc 425} 426 427# ::struct::graph::__arc_set -- 428# 429# Set or get a value for an arc in a graph. 430# 431# Arguments: 432# name name of the graph. 433# arc arc to modify or query. 434# args ?-key key? ?value? 435# 436# Results: 437# val value associated with the given key of the given arc 438 439proc ::struct::graph::__arc_set {name arc args} { 440 if { ![__arc_exists $name $arc] } { 441 error "arc \"$arc\" does not exist in graph \"$name\"" 442 } 443 444 upvar ::struct::graph::graph${name}::arc$arc data 445 446 if { [llength $args] > 3 } { 447 error "wrong # args: should be \"$name arc set $arc ?-key key?\ 448 ?value?\"" 449 } 450 451 set key "data" 452 set haveValue 0 453 if { [llength $args] > 1 } { 454 foreach {flag key} $args break 455 if { ![string match "${flag}*" "-key"] } { 456 error "invalid option \"$flag\": should be key" 457 } 458 if { [llength $args] == 3 } { 459 set haveValue 1 460 set value [lindex $args end] 461 } 462 } elseif { [llength $args] == 1 } { 463 set haveValue 1 464 set value [lindex $args end] 465 } 466 467 if { $haveValue } { 468 # Setting a value 469 return [set data($key) $value] 470 } else { 471 # Getting a value 472 if { ![info exists data($key)] } { 473 error "invalid key \"$key\" for arc \"$arc\"" 474 } 475 return $data($key) 476 } 477} 478 479# ::struct::graph::__arc_append -- 480# 481# Append a value for an arc in a graph. 482# 483# Arguments: 484# name name of the graph. 485# arc arc to modify or query. 486# args ?-key key? value 487# 488# Results: 489# val value associated with the given key of the given arc 490 491proc ::struct::graph::__arc_append {name arc args} { 492 if { ![__arc_exists $name $arc] } { 493 error "arc \"$arc\" does not exist in graph \"$name\"" 494 } 495 496 upvar ::struct::graph::graph${name}::arc$arc data 497 498 if { [llength $args] != 1 && [llength $args] != 3 } { 499 error "wrong # args: should be \"$name arc append $arc ?-key key?\ 500 value\"" 501 } 502 503 if { [llength $args] == 3 } { 504 foreach {flag key} $args break 505 if { ![string equal $flag "-key"] } { 506 error "invalid option \"$flag\": should be -key" 507 } 508 } else { 509 set key "data" 510 } 511 512 set value [lindex $args end] 513 514 return [append data($key) $value] 515} 516 517# ::struct::graph::__arc_lappend -- 518# 519# lappend a value for an arc in a graph. 520# 521# Arguments: 522# name name of the graph. 523# arc arc to modify or query. 524# args ?-key key? value 525# 526# Results: 527# val value associated with the given key of the given arc 528 529proc ::struct::graph::__arc_lappend {name arc args} { 530 if { ![__arc_exists $name $arc] } { 531 error "arc \"$arc\" does not exist in graph \"$name\"" 532 } 533 534 upvar ::struct::graph::graph${name}::arc$arc data 535 536 if { [llength $args] != 1 && [llength $args] != 3 } { 537 error "wrong # args: should be \"$name arc lappend $arc ?-key key?\ 538 value\"" 539 } 540 541 if { [llength $args] == 3 } { 542 foreach {flag key} $args break 543 if { ![string equal $flag "-key"] } { 544 error "invalid option \"$flag\": should be -key" 545 } 546 } else { 547 set key "data" 548 } 549 550 set value [lindex $args end] 551 552 return [lappend data($key) $value] 553} 554 555# ::struct::graph::__arc_source -- 556# 557# Return the node at the beginning of the specified arc. 558# 559# Arguments: 560# name name of the graph object. 561# arc arc to look up. 562# 563# Results: 564# node name of the node. 565 566proc ::struct::graph::__arc_source {name arc} { 567 if { ![__arc_exists $name $arc] } { 568 error "arc \"$arc\" does not exist in graph \"$name\"" 569 } 570 571 upvar ::struct::graph::graph${name}::arcNodes arcNodes 572 return [lindex $arcNodes($arc) 0] 573} 574 575# ::struct::graph::__arc_target -- 576# 577# Return the node at the end of the specified arc. 578# 579# Arguments: 580# name name of the graph object. 581# arc arc to look up. 582# 583# Results: 584# node name of the node. 585 586proc ::struct::graph::__arc_target {name arc} { 587 if { ![__arc_exists $name $arc] } { 588 error "arc \"$arc\" does not exist in graph \"$name\"" 589 } 590 591 upvar ::struct::graph::graph${name}::arcNodes arcNodes 592 return [lindex $arcNodes($arc) 1] 593} 594 595# ::struct::graph::__arc_unset -- 596# 597# Remove a keyed value from a arc. 598# 599# Arguments: 600# name name of the graph. 601# arc arc to modify. 602# args additional args: ?-key key? 603# 604# Results: 605# None. 606 607proc ::struct::graph::__arc_unset {name arc {flag -key} {key data}} { 608 if { ![__arc_exists $name $arc] } { 609 error "arc \"$arc\" does not exist in graph \"$name\"" 610 } 611 612 if { ![string match "${flag}*" "-key"] } { 613 error "invalid option \"$flag\": should be \"$name arc unset\ 614 $arc ?-key key?\"" 615 } 616 617 upvar ::struct::graph::graph${name}::arc${arc} data 618 if { [info exists data($key)] } { 619 unset data($key) 620 } 621 return 622} 623 624# ::struct::graph::_arcs -- 625# 626# Return a list of all arcs in a graph satisfying some 627# node based restriction. 628# 629# Arguments: 630# name name of the graph. 631# 632# Results: 633# arcs list of arcs 634 635proc ::struct::graph::_arcs {name args} { 636 637 # Discriminate between conditions and nodes 638 639 set haveCond 0 640 set haveKey 0 641 set haveValue 0 642 set cond "none" 643 set condNodes [list] 644 645 for {set i 0} {$i < [llength $args]} {incr i} { 646 set arg [lindex $args $i] 647 switch -glob -- $arg { 648 -in - 649 -out - 650 -adj - 651 -inner - 652 -embedding { 653 if {$haveCond} { 654 return -code error "invalid restriction:\ 655 illegal multiple use of\ 656 \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"" 657 } 658 659 set haveCond 1 660 set cond [string range $arg 1 end] 661 } 662 -key { 663 if {$haveKey} { 664 return -code error {invalid restriction: illegal multiple use of "-key"} 665 } 666 667 incr i 668 set key [lindex $args $i] 669 set haveKey 1 670 } 671 -value { 672 if {$haveValue} { 673 return -code error {invalid restriction: illegal multiple use of "-value"} 674 } 675 676 incr i 677 set value [lindex $args $i] 678 set haveValue 1 679 } 680 -* { 681 error "invalid restriction \"$arg\": should be -in, -out,\ 682 -adj, -inner, -embedding, -key or -value" 683 } 684 default { 685 lappend condNodes $arg 686 } 687 } 688 } 689 690 # Validate that there are nodes to use in the restriction. 691 # otherwise what's the point? 692 if {$haveCond} { 693 if {[llength $condNodes] == 0} { 694 set usage "$name arcs ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?" 695 error "no nodes specified: should be \"$usage\"" 696 } 697 698 # Make sure that the specified nodes exist! 699 foreach node $condNodes { 700 if { ![__node_exists $name $node] } { 701 error "node \"$node\" does not exist in graph \"$name\"" 702 } 703 } 704 } 705 706 # Now we are able to go to work 707 upvar ::struct::graph::graph${name}::inArcs inArcs 708 upvar ::struct::graph::graph${name}::outArcs outArcs 709 upvar ::struct::graph::graph${name}::arcNodes arcNodes 710 711 set arcs [list] 712 713 switch -exact -- $cond { 714 in { 715 # Result is all arcs going to at least one node 716 # in the list of arguments. 717 718 foreach node $condNodes { 719 foreach e $inArcs($node) { 720 # As an arc has only one destination, i.e. is the 721 # in-arc of exactly one node it is impossible to 722 # count an arc twice. IOW the [info exists] below 723 # is never true. Found through coverage analysis 724 # and then trying to think up a testcase invoking 725 # the continue. 726 # if {[info exists coll($e)]} {continue} 727 lappend arcs $e 728 #set coll($e) . 729 } 730 } 731 } 732 out { 733 # Result is all arcs coming from at least one node 734 # in the list of arguments. 735 736 foreach node $condNodes { 737 foreach e $outArcs($node) { 738 # See above 'in', same reasoning, one source per arc. 739 # if {[info exists coll($e)]} {continue} 740 lappend arcs $e 741 #set coll($e) . 742 } 743 } 744 } 745 adj { 746 # Result is all arcs coming from or going to at 747 # least one node in the list of arguments. 748 749 array set coll {} 750 # Here we do need 'coll' as each might be an in- and 751 # out-arc for one or two nodes in the list of arguments. 752 753 foreach node $condNodes { 754 foreach e $inArcs($node) { 755 if {[info exists coll($e)]} {continue} 756 lappend arcs $e 757 set coll($e) . 758 } 759 foreach e $outArcs($node) { 760 if {[info exists coll($e)]} {continue} 761 lappend arcs $e 762 set coll($e) . 763 } 764 } 765 } 766 inner { 767 # Result is all arcs running between nodes in the list. 768 769 array set coll {} 770 # Here we do need 'coll' as each might be an in- and 771 # out-arc for one or two nodes in the list of arguments. 772 773 array set group {} 774 foreach node $condNodes { 775 set group($node) . 776 } 777 778 foreach node $condNodes { 779 foreach e $inArcs($node) { 780 set n [lindex $arcNodes($e) 0] 781 if {![info exists group($n)]} {continue} 782 if { [info exists coll($e)]} {continue} 783 lappend arcs $e 784 set coll($e) . 785 } 786 foreach e $outArcs($node) { 787 set n [lindex $arcNodes($e) 1] 788 if {![info exists group($n)]} {continue} 789 if { [info exists coll($e)]} {continue} 790 lappend arcs $e 791 set coll($e) . 792 } 793 } 794 } 795 embedding { 796 # Result is all arcs from -adj minus the arcs from -inner. 797 # IOW all arcs going from a node in the list to a node 798 # which is *not* in the list 799 800 # This also means that no arc can be counted twice as it 801 # is either going to a node, or coming from a node in the 802 # list, but it can't do both, because then it is part of 803 # -inner, which was excluded! 804 805 array set group {} 806 foreach node $condNodes { 807 set group($node) . 808 } 809 810 foreach node $condNodes { 811 foreach e $inArcs($node) { 812 set n [lindex $arcNodes($e) 0] 813 if {[info exists group($n)]} {continue} 814 # if {[info exists coll($e)]} {continue} 815 lappend arcs $e 816 # set coll($e) . 817 } 818 foreach e $outArcs($node) { 819 set n [lindex $arcNodes($e) 1] 820 if {[info exists group($n)]} {continue} 821 # if {[info exists coll($e)]} {continue} 822 lappend arcs $e 823 # set coll($e) . 824 } 825 } 826 } 827 none { 828 set arcs [array names arcNodes] 829 } 830 default {error "Can't happen, panic"} 831 } 832 833 # 834 # We have a list of arcs that match the relation to the nodes. 835 # Now filter according to -key and -value. 836 # 837 838 set filteredArcs [list] 839 840 if {$haveKey} { 841 foreach arc $arcs { 842 catch { 843 set aval [__arc_get $name $arc -key $key] 844 if {$haveValue} { 845 if {$aval == $value} { 846 lappend filteredArcs $arc 847 } 848 } else { 849 lappend filteredArcs $arc 850 } 851 } 852 } 853 } else { 854 set filteredArcs $arcs 855 } 856 857 return $filteredArcs 858} 859 860# ::struct::graph::_destroy -- 861# 862# Destroy a graph, including its associated command and data storage. 863# 864# Arguments: 865# name name of the graph. 866# 867# Results: 868# None. 869 870proc ::struct::graph::_destroy {name} { 871 namespace delete ::struct::graph::graph$name 872 interp alias {} ::$name {} 873} 874 875# ::struct::graph::__generateUniqueArcName -- 876# 877# Generate a unique arc name for the given graph. 878# 879# Arguments: 880# name name of the graph. 881# 882# Results: 883# arc name of a arc guaranteed to not exist in the graph. 884 885proc ::struct::graph::__generateUniqueArcName {name} { 886 upvar ::struct::graph::graph${name}::nextUnusedArc nextUnusedArc 887 while {[__arc_exists $name "arc${nextUnusedArc}"]} { 888 incr nextUnusedArc 889 } 890 return "arc${nextUnusedArc}" 891} 892 893# ::struct::graph::__generateUniqueNodeName -- 894# 895# Generate a unique node name for the given graph. 896# 897# Arguments: 898# name name of the graph. 899# 900# Results: 901# node name of a node guaranteed to not exist in the graph. 902 903proc ::struct::graph::__generateUniqueNodeName {name} { 904 upvar ::struct::graph::graph${name}::nextUnusedNode nextUnusedNode 905 while {[__node_exists $name "node${nextUnusedNode}"]} { 906 incr nextUnusedNode 907 } 908 return "node${nextUnusedNode}" 909} 910 911# ::struct::graph::_get -- 912# 913# Get a keyed value from the graph itself 914# 915# Arguments: 916# name name of the graph. 917# flag -key; anything else is an error 918# key key to lookup; defaults to data 919# 920# Results: 921# value value associated with the key given. 922 923proc ::struct::graph::_get {name {flag -key} {key data}} { 924 upvar ::struct::graph::graph${name}::graphData data 925 926 if { ![info exists data($key)] } { 927 error "invalid key \"$key\" for graph \"$name\"" 928 } 929 930 return $data($key) 931} 932 933# ::struct::graph::_getall -- 934# 935# Get a serialized list of key/value pairs from a graph. 936# 937# Arguments: 938# name name of the graph. 939# 940# Results: 941# value value associated with the key given. 942 943proc ::struct::graph::_getall {name args} { 944 if { [llength $args] } { 945 error "wrong # args: should be none" 946 } 947 948 upvar ::struct::graph::graph${name}::graphData data 949 return [array get data] 950} 951 952# ::struct::graph::_keys -- 953# 954# Get a list of keys from a graph. 955# 956# Arguments: 957# name name of the graph. 958# 959# Results: 960# value list of known keys 961 962proc ::struct::graph::_keys {name args} { 963 if { [llength $args] } { 964 error "wrong # args: should be none" 965 } 966 967 upvar ::struct::graph::graph${name}::graphData data 968 return [array names data] 969} 970 971# ::struct::graph::_keyexists -- 972# 973# Test for existance of a given key in a graph. 974# 975# Arguments: 976# name name of the graph. 977# flag -key; anything else is an error 978# key key to lookup; defaults to data 979# 980# Results: 981# 1 if the key exists, 0 else. 982 983proc ::struct::graph::_keyexists {name {flag -key} {key data}} { 984 if { ![string equal $flag "-key"] } { 985 error "invalid option \"$flag\": should be -key" 986 } 987 988 upvar ::struct::graph::graph${name}::graphData data 989 return [info exists data($key)] 990} 991 992# ::struct::graph::_node -- 993# 994# Dispatches the invocation of node methods to the proper handler 995# procedure. 996# 997# Arguments: 998# name name of the graph. 999# cmd node command to invoke 1000# args arguments to propagate to the handler for the node command 1001# 1002# Results: 1003# As of the the invoked handler. 1004 1005proc ::struct::graph::_node {name cmd args} { 1006 1007 # Split the args into command and args components 1008 if { [llength [info commands ::struct::graph::__node_$cmd]] == 0 } { 1009 variable nodeCommands 1010 set optlist [join $nodeCommands ", "] 1011 set optlist [linsert $optlist "end-1" "or"] 1012 error "bad option \"$cmd\": must be $optlist" 1013 } 1014 1015 eval [list ::struct::graph::__node_$cmd $name] $args 1016} 1017 1018# ::struct::graph::__node_degree -- 1019# 1020# Return the number of arcs adjacent to the specified node. 1021# If one of the restrictions -in or -out is given only 1022# incoming resp. outgoing arcs are counted. 1023# 1024# Arguments: 1025# name name of the graph. 1026# args option, followed by the node. 1027# 1028# Results: 1029# None. 1030 1031proc ::struct::graph::__node_degree {name args} { 1032 1033 if {([llength $args] < 1) || ([llength $args] > 2)} { 1034 error "wrong # args: should be \"$name node degree ?-in|-out? node\"" 1035 } 1036 1037 switch -exact -- [llength $args] { 1038 1 { 1039 set opt {} 1040 set node [lindex $args 0] 1041 } 1042 2 { 1043 set opt [lindex $args 0] 1044 set node [lindex $args 1] 1045 } 1046 default {error "Can't happen, panic"} 1047 } 1048 1049 # Validate the option. 1050 1051 switch -exact -- $opt { 1052 {} - 1053 -in - 1054 -out {} 1055 default { 1056 error "invalid option \"$opt\": should be -in or -out" 1057 } 1058 } 1059 1060 # Validate the node 1061 1062 if { ![__node_exists $name $node] } { 1063 error "node \"$node\" does not exist in graph \"$name\"" 1064 } 1065 1066 upvar ::struct::graph::graph${name}::inArcs inArcs 1067 upvar ::struct::graph::graph${name}::outArcs outArcs 1068 1069 switch -exact -- $opt { 1070 -in { 1071 set result [llength $inArcs($node)] 1072 } 1073 -out { 1074 set result [llength $outArcs($node)] 1075 } 1076 {} { 1077 set result [expr {[llength $inArcs($node)] \ 1078 + [llength $outArcs($node)]}] 1079 1080 # loops count twice, don't do <set> arithmetics, i.e. no union! 1081 if {0} { 1082 array set coll {} 1083 set result [llength $inArcs($node)] 1084 1085 foreach e $inArcs($node) { 1086 set coll($e) . 1087 } 1088 foreach e $outArcs($node) { 1089 if {[info exists coll($e)]} {continue} 1090 incr result 1091 set coll($e) . 1092 } 1093 } 1094 } 1095 default {error "Can't happen, panic"} 1096 } 1097 1098 return $result 1099} 1100 1101# ::struct::graph::__node_delete -- 1102# 1103# Remove a node from a graph, including all of its values. 1104# Additionally removes the arcs connected to this node. 1105# 1106# Arguments: 1107# name name of the graph. 1108# args list of the nodes to delete. 1109# 1110# Results: 1111# None. 1112 1113proc ::struct::graph::__node_delete {name args} { 1114 1115 foreach node $args { 1116 if { ![__node_exists $name $node] } { 1117 error "node \"$node\" does not exist in graph \"$name\"" 1118 } 1119 } 1120 1121 upvar ::struct::graph::graph${name}::inArcs inArcs 1122 upvar ::struct::graph::graph${name}::outArcs outArcs 1123 1124 foreach node $args { 1125 # Remove all the arcs connected to this node 1126 foreach e $inArcs($node) { 1127 __arc_delete $name $e 1128 } 1129 foreach e $outArcs($node) { 1130 # Check existence to avoid problems with 1131 # loops (they are in and out arcs! at 1132 # the same time and thus already deleted) 1133 if { [__arc_exists $name $e] } { 1134 __arc_delete $name $e 1135 } 1136 } 1137 1138 unset inArcs($node) 1139 unset outArcs($node) 1140 # FRINK: nocheck 1141 unset ::struct::graph::graph${name}::node$node 1142 } 1143 1144 return 1145} 1146 1147# ::struct::graph::__node_exists -- 1148# 1149# Test for existance of a given node in a graph. 1150# 1151# Arguments: 1152# name name of the graph. 1153# node node to look for. 1154# 1155# Results: 1156# 1 if the node exists, 0 else. 1157 1158proc ::struct::graph::__node_exists {name node} { 1159 return [info exists ::struct::graph::graph${name}::inArcs($node)] 1160} 1161 1162# ::struct::graph::__node_get -- 1163# 1164# Get a keyed value from a node in a graph. 1165# 1166# Arguments: 1167# name name of the graph. 1168# node node to query. 1169# flag -key; anything else is an error 1170# key key to lookup; defaults to data 1171# 1172# Results: 1173# value value associated with the key given. 1174 1175proc ::struct::graph::__node_get {name node {flag -key} {key data}} { 1176 if { ![__node_exists $name $node] } { 1177 error "node \"$node\" does not exist in graph \"$name\"" 1178 } 1179 1180 upvar ::struct::graph::graph${name}::node${node} data 1181 1182 if { ![info exists data($key)] } { 1183 error "invalid key \"$key\" for node \"$node\"" 1184 } 1185 1186 return $data($key) 1187} 1188 1189# ::struct::graph::__node_getall -- 1190# 1191# Get a serialized list of key/value pairs from a node in a graph. 1192# 1193# Arguments: 1194# name name of the graph. 1195# node node to query. 1196# 1197# Results: 1198# value value associated with the key given. 1199 1200proc ::struct::graph::__node_getall {name node args} { 1201 if { ![__node_exists $name $node] } { 1202 error "node \"$node\" does not exist in graph \"$name\"" 1203 } 1204 1205 if { [llength $args] } { 1206 error "wrong # args: should be none" 1207 } 1208 1209 upvar ::struct::graph::graph${name}::node${node} data 1210 1211 return [array get data] 1212} 1213 1214# ::struct::graph::__node_keys -- 1215# 1216# Get a list of keys from a node in a graph. 1217# 1218# Arguments: 1219# name name of the graph. 1220# node node to query. 1221# 1222# Results: 1223# value value associated with the key given. 1224 1225proc ::struct::graph::__node_keys {name node args} { 1226 if { ![__node_exists $name $node] } { 1227 error "node \"$node\" does not exist in graph \"$name\"" 1228 } 1229 1230 if { [llength $args] } { 1231 error "wrong # args: should be none" 1232 } 1233 1234 upvar ::struct::graph::graph${name}::node${node} data 1235 1236 return [array names data] 1237} 1238 1239# ::struct::graph::__node_keyexists -- 1240# 1241# Test for existance of a given key for a node in a graph. 1242# 1243# Arguments: 1244# name name of the graph. 1245# node node to query. 1246# flag -key; anything else is an error 1247# key key to lookup; defaults to data 1248# 1249# Results: 1250# 1 if the key exists, 0 else. 1251 1252proc ::struct::graph::__node_keyexists {name node {flag -key} {key data}} { 1253 if { ![__node_exists $name $node] } { 1254 error "node \"$node\" does not exist in graph \"$name\"" 1255 } 1256 1257 if { ![string equal $flag "-key"] } { 1258 error "invalid option \"$flag\": should be -key" 1259 } 1260 1261 upvar ::struct::graph::graph${name}::node${node} data 1262 1263 return [info exists data($key)] 1264} 1265 1266# ::struct::graph::__node_insert -- 1267# 1268# Add a node to a graph. 1269# 1270# Arguments: 1271# name name of the graph. 1272# args node to insert; must be unique. If none is given, 1273# the routine will generate a unique node name. 1274# 1275# Results: 1276# node The namee of the new node. 1277 1278proc ::struct::graph::__node_insert {name args} { 1279 1280 if { [llength $args] == 0 } { 1281 # No node name was given; generate a unique one 1282 set node [__generateUniqueNodeName $name] 1283 } else { 1284 set node [lindex $args 0] 1285 } 1286 1287 if { [__node_exists $name $node] } { 1288 error "node \"$node\" already exists in graph \"$name\"" 1289 } 1290 1291 upvar ::struct::graph::graph${name}::inArcs inArcs 1292 upvar ::struct::graph::graph${name}::outArcs outArcs 1293 upvar ::struct::graph::graph${name}::node${node} data 1294 1295 # Set up the new node 1296 set inArcs($node) [list] 1297 set outArcs($node) [list] 1298 set data(data) "" 1299 1300 return $node 1301} 1302 1303# ::struct::graph::__node_opposite -- 1304# 1305# Retrieve node opposite to the specified one, along the arc. 1306# 1307# Arguments: 1308# name name of the graph. 1309# node node to look up. 1310# arc arc to look up. 1311# 1312# Results: 1313# nodex Node opposite to <node,arc> 1314 1315proc ::struct::graph::__node_opposite {name node arc} { 1316 if {![__node_exists $name $node] } { 1317 error "node \"$node\" does not exist in graph \"$name\"" 1318 } 1319 1320 if {![__arc_exists $name $arc] } { 1321 error "arc \"$arc\" does not exist in graph \"$name\"" 1322 } 1323 1324 upvar ::struct::graph::graph${name}::arcNodes arcNodes 1325 1326 # Node must be connected to at least one end of the arc. 1327 1328 if {[string equal $node [lindex $arcNodes($arc) 0]]} { 1329 set result [lindex $arcNodes($arc) 1] 1330 } elseif {[string equal $node [lindex $arcNodes($arc) 1]]} { 1331 set result [lindex $arcNodes($arc) 0] 1332 } else { 1333 error "node \"$node\" and arc \"$arc\" are not connected\ 1334 in graph \"$name\"" 1335 } 1336 1337 return $result 1338} 1339 1340# ::struct::graph::__node_set -- 1341# 1342# Set or get a value for a node in a graph. 1343# 1344# Arguments: 1345# name name of the graph. 1346# node node to modify or query. 1347# args ?-key key? ?value? 1348# 1349# Results: 1350# val value associated with the given key of the given node 1351 1352proc ::struct::graph::__node_set {name node args} { 1353 if { ![__node_exists $name $node] } { 1354 error "node \"$node\" does not exist in graph \"$name\"" 1355 } 1356 upvar ::struct::graph::graph${name}::node$node data 1357 1358 if { [llength $args] > 3 } { 1359 error "wrong # args: should be \"$name node set $node ?-key key?\ 1360 ?value?\"" 1361 } 1362 1363 set key "data" 1364 set haveValue 0 1365 if { [llength $args] > 1 } { 1366 foreach {flag key} $args break 1367 if { ![string match "${flag}*" "-key"] } { 1368 error "invalid option \"$flag\": should be key" 1369 } 1370 if { [llength $args] == 3 } { 1371 set haveValue 1 1372 set value [lindex $args end] 1373 } 1374 } elseif { [llength $args] == 1 } { 1375 set haveValue 1 1376 set value [lindex $args end] 1377 } 1378 1379 if { $haveValue } { 1380 # Setting a value 1381 return [set data($key) $value] 1382 } else { 1383 # Getting a value 1384 if { ![info exists data($key)] } { 1385 error "invalid key \"$key\" for node \"$node\"" 1386 } 1387 return $data($key) 1388 } 1389} 1390 1391# ::struct::graph::__node_append -- 1392# 1393# Append a value for a node in a graph. 1394# 1395# Arguments: 1396# name name of the graph. 1397# node node to modify or query. 1398# args ?-key key? value 1399# 1400# Results: 1401# val value associated with the given key of the given node 1402 1403proc ::struct::graph::__node_append {name node args} { 1404 if { ![__node_exists $name $node] } { 1405 error "node \"$node\" does not exist in graph \"$name\"" 1406 } 1407 upvar ::struct::graph::graph${name}::node$node data 1408 1409 if { [llength $args] != 1 && [llength $args] != 3 } { 1410 error "wrong # args: should be \"$name node append $node ?-key key?\ 1411 value\"" 1412 } 1413 1414 if { [llength $args] == 3 } { 1415 foreach {flag key} $args break 1416 if { ![string equal $flag "-key"] } { 1417 error "invalid option \"$flag\": should be -key" 1418 } 1419 } else { 1420 set key "data" 1421 } 1422 1423 set value [lindex $args end] 1424 1425 return [append data($key) $value] 1426} 1427 1428# ::struct::graph::__node_lappend -- 1429# 1430# lappend a value for a node in a graph. 1431# 1432# Arguments: 1433# name name of the graph. 1434# node node to modify or query. 1435# args ?-key key? value 1436# 1437# Results: 1438# val value associated with the given key of the given node 1439 1440proc ::struct::graph::__node_lappend {name node args} { 1441 if { ![__node_exists $name $node] } { 1442 error "node \"$node\" does not exist in graph \"$name\"" 1443 } 1444 upvar ::struct::graph::graph${name}::node$node data 1445 1446 if { [llength $args] != 1 && [llength $args] != 3 } { 1447 error "wrong # args: should be \"$name node lappend $node ?-key key?\ 1448 value\"" 1449 } 1450 1451 if { [llength $args] == 3 } { 1452 foreach {flag key} $args break 1453 if { ![string equal $flag "-key"] } { 1454 error "invalid option \"$flag\": should be -key" 1455 } 1456 } else { 1457 set key "data" 1458 } 1459 1460 set value [lindex $args end] 1461 1462 return [lappend data($key) $value] 1463} 1464 1465# ::struct::graph::__node_unset -- 1466# 1467# Remove a keyed value from a node. 1468# 1469# Arguments: 1470# name name of the graph. 1471# node node to modify. 1472# args additional args: ?-key key? 1473# 1474# Results: 1475# None. 1476 1477proc ::struct::graph::__node_unset {name node {flag -key} {key data}} { 1478 if { ![__node_exists $name $node] } { 1479 error "node \"$node\" does not exist in graph \"$name\"" 1480 } 1481 1482 if { ![string match "${flag}*" "-key"] } { 1483 error "invalid option \"$flag\": should be \"$name node unset\ 1484 $node ?-key key?\"" 1485 } 1486 1487 upvar ::struct::graph::graph${name}::node${node} data 1488 if { [info exists data($key)] } { 1489 unset data($key) 1490 } 1491 return 1492} 1493 1494# ::struct::graph::_nodes -- 1495# 1496# Return a list of all nodes in a graph satisfying some restriction. 1497# 1498# Arguments: 1499# name name of the graph. 1500# args list of options and nodes specifying the restriction. 1501# 1502# Results: 1503# nodes list of nodes 1504 1505proc ::struct::graph::_nodes {name args} { 1506 1507 # Discriminate between conditions and nodes 1508 1509 set haveCond 0 1510 set haveKey 0 1511 set haveValue 0 1512 set cond "none" 1513 set condNodes [list] 1514 1515 for {set i 0} {$i < [llength $args]} {incr i} { 1516 set arg [lindex $args $i] 1517 switch -glob -- $arg { 1518 -in - 1519 -out - 1520 -adj - 1521 -inner - 1522 -embedding { 1523 if {$haveCond} { 1524 return -code error "invalid restriction:\ 1525 illegal multiple use of\ 1526 \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"" 1527 } 1528 1529 set haveCond 1 1530 set cond [string range $arg 1 end] 1531 } 1532 -key { 1533 if {$haveKey} { 1534 return -code error {invalid restriction: illegal multiple use of "-key"} 1535 } 1536 1537 incr i 1538 set key [lindex $args $i] 1539 set haveKey 1 1540 } 1541 -value { 1542 if {$haveValue} { 1543 return -code error {invalid restriction: illegal multiple use of "-value"} 1544 } 1545 1546 incr i 1547 set value [lindex $args $i] 1548 set haveValue 1 1549 } 1550 -* { 1551 error "invalid restriction \"$arg\": should be -in, -out,\ 1552 -adj, -inner, -embedding, -key or -value" 1553 } 1554 default { 1555 lappend condNodes $arg 1556 } 1557 } 1558 } 1559 1560 # Validate that there are nodes to use in the restriction. 1561 # otherwise what's the point? 1562 if {$haveCond} { 1563 if {[llength $condNodes] == 0} { 1564 set usage "$name nodes ?-key key? ?-value value? ?-in|-out|-adj|-inner|-embedding node node...?" 1565 error "no nodes specified: should be \"$usage\"" 1566 } 1567 1568 # Make sure that the specified nodes exist! 1569 foreach node $condNodes { 1570 if { ![__node_exists $name $node] } { 1571 error "node \"$node\" does not exist in graph \"$name\"" 1572 } 1573 } 1574 } 1575 1576 # Now we are able to go to work 1577 upvar ::struct::graph::graph${name}::inArcs inArcs 1578 upvar ::struct::graph::graph${name}::outArcs outArcs 1579 upvar ::struct::graph::graph${name}::arcNodes arcNodes 1580 1581 set nodes [list] 1582 array set coll {} 1583 1584 switch -exact -- $cond { 1585 in { 1586 # Result is all nodes with at least one arc going to 1587 # at least one node in the list of arguments. 1588 1589 foreach node $condNodes { 1590 foreach e $inArcs($node) { 1591 set n [lindex $arcNodes($e) 0] 1592 if {[info exists coll($n)]} {continue} 1593 lappend nodes $n 1594 set coll($n) . 1595 } 1596 } 1597 } 1598 out { 1599 # Result is all nodes with at least one arc coming from 1600 # at least one node in the list of arguments. 1601 1602 foreach node $condNodes { 1603 foreach e $outArcs($node) { 1604 set n [lindex $arcNodes($e) 1] 1605 if {[info exists coll($n)]} {continue} 1606 lappend nodes $n 1607 set coll($n) . 1608 } 1609 } 1610 } 1611 adj { 1612 # Result is all nodes with at least one arc coming from 1613 # or going to at least one node in the list of arguments. 1614 1615 foreach node $condNodes { 1616 foreach e $inArcs($node) { 1617 set n [lindex $arcNodes($e) 0] 1618 if {[info exists coll($n)]} {continue} 1619 lappend nodes $n 1620 set coll($n) . 1621 } 1622 foreach e $outArcs($node) { 1623 set n [lindex $arcNodes($e) 1] 1624 if {[info exists coll($n)]} {continue} 1625 lappend nodes $n 1626 set coll($n) . 1627 } 1628 } 1629 } 1630 inner { 1631 # Result is all nodes from the list! with at least one arc 1632 # coming from or going to at least one node in the list of 1633 # arguments. 1634 1635 array set group {} 1636 foreach node $condNodes { 1637 set group($node) . 1638 } 1639 1640 foreach node $condNodes { 1641 foreach e $inArcs($node) { 1642 set n [lindex $arcNodes($e) 0] 1643 if {![info exists group($n)]} {continue} 1644 if { [info exists coll($n)]} {continue} 1645 lappend nodes $n 1646 set coll($n) . 1647 } 1648 foreach e $outArcs($node) { 1649 set n [lindex $arcNodes($e) 1] 1650 if {![info exists group($n)]} {continue} 1651 if { [info exists coll($n)]} {continue} 1652 lappend nodes $n 1653 set coll($n) . 1654 } 1655 } 1656 } 1657 embedding { 1658 # Result is all nodes with at least one arc coming from 1659 # or going to at least one node in the list of arguments, 1660 # but not in the list itself! 1661 1662 array set group {} 1663 foreach node $condNodes { 1664 set group($node) . 1665 } 1666 1667 foreach node $condNodes { 1668 foreach e $inArcs($node) { 1669 set n [lindex $arcNodes($e) 0] 1670 if {[info exists group($n)]} {continue} 1671 if {[info exists coll($n)]} {continue} 1672 lappend nodes $n 1673 set coll($n) . 1674 } 1675 foreach e $outArcs($node) { 1676 set n [lindex $arcNodes($e) 1] 1677 if {[info exists group($n)]} {continue} 1678 if {[info exists coll($n)]} {continue} 1679 lappend nodes $n 1680 set coll($n) . 1681 } 1682 } 1683 } 1684 none { 1685 set nodes [array names inArcs] 1686 } 1687 default {error "Can't happen, panic"} 1688 } 1689 1690 # 1691 # We have a list of nodes that match the relation to the nodes. 1692 # Now filter according to -key and -value. 1693 # 1694 1695 set filteredNodes [list] 1696 1697 if {$haveKey} { 1698 foreach node $nodes { 1699 catch { 1700 set nval [__node_get $name $node -key $key] 1701 if {$haveValue} { 1702 if {$nval == $value} { 1703 lappend filteredNodes $node 1704 } 1705 } else { 1706 lappend filteredNodes $node 1707 } 1708 } 1709 } 1710 } else { 1711 set filteredNodes $nodes 1712 } 1713 1714 return $filteredNodes 1715} 1716 1717# ::struct::graph::_set -- 1718# 1719# Set or get a keyed value from the graph itself 1720# 1721# Arguments: 1722# name name of the graph. 1723# flag -key; anything else is an error 1724# args ?-key key? ?value? 1725# 1726# Results: 1727# value value associated with the key given. 1728 1729proc ::struct::graph::_set {name args} { 1730 upvar ::struct::graph::graph${name}::graphData data 1731 1732 if { [llength $args] > 3 } { 1733 error "wrong # args: should be \"$name set ?-key key?\ 1734 ?value?\"" 1735 } 1736 1737 set key "data" 1738 set haveValue 0 1739 if { [llength $args] > 1 } { 1740 foreach {flag key} $args break 1741 if { ![string match "${flag}*" "-key"] } { 1742 error "invalid option \"$flag\": should be key" 1743 } 1744 if { [llength $args] == 3 } { 1745 set haveValue 1 1746 set value [lindex $args end] 1747 } 1748 } elseif { [llength $args] == 1 } { 1749 set haveValue 1 1750 set value [lindex $args end] 1751 } 1752 1753 if { $haveValue } { 1754 # Setting a value 1755 return [set data($key) $value] 1756 } else { 1757 # Getting a value 1758 if { ![info exists data($key)] } { 1759 error "invalid key \"$key\" for graph \"$name\"" 1760 } 1761 return $data($key) 1762 } 1763} 1764 1765# ::struct::graph::_swap -- 1766# 1767# Swap two nodes in a graph. 1768# 1769# Arguments: 1770# name name of the graph. 1771# node1 first node to swap. 1772# node2 second node to swap. 1773# 1774# Results: 1775# None. 1776 1777proc ::struct::graph::_swap {name node1 node2} { 1778 # Can only swap two real nodes 1779 if { ![__node_exists $name $node1] } { 1780 error "node \"$node1\" does not exist in graph \"$name\"" 1781 } 1782 if { ![__node_exists $name $node2] } { 1783 error "node \"$node2\" does not exist in graph \"$name\"" 1784 } 1785 1786 # Can't swap a node with itself 1787 if { [string equal $node1 $node2] } { 1788 error "cannot swap node \"$node1\" with itself" 1789 } 1790 1791 # Swapping nodes means swapping their labels, values and arcs 1792 upvar ::struct::graph::graph${name}::outArcs outArcs 1793 upvar ::struct::graph::graph${name}::inArcs inArcs 1794 upvar ::struct::graph::graph${name}::arcNodes arcNodes 1795 upvar ::struct::graph::graph${name}::node${node1} node1Vals 1796 upvar ::struct::graph::graph${name}::node${node2} node2Vals 1797 1798 # Redirect arcs to the new nodes. 1799 1800 foreach e $inArcs($node1) { 1801 set arcNodes($e) [lreplace $arcNodes($e) end end $node2] 1802 } 1803 foreach e $inArcs($node2) { 1804 set arcNodes($e) [lreplace $arcNodes($e) end end $node1] 1805 } 1806 foreach e $outArcs($node1) { 1807 set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node2] 1808 } 1809 foreach e $outArcs($node2) { 1810 set arcNodes($e) [lreplace $arcNodes($e) 0 0 $node1] 1811 } 1812 1813 # Swap arc lists 1814 1815 set tmp $inArcs($node1) 1816 set inArcs($node1) $inArcs($node2) 1817 set inArcs($node2) $tmp 1818 1819 set tmp $outArcs($node1) 1820 set outArcs($node1) $outArcs($node2) 1821 set outArcs($node2) $tmp 1822 1823 # Swap the values 1824 set value1 [array get node1Vals] 1825 unset node1Vals 1826 array set node1Vals [array get node2Vals] 1827 unset node2Vals 1828 array set node2Vals $value1 1829 1830 return 1831} 1832 1833# ::struct::graph::_unset -- 1834# 1835# Remove a keyed value from the graph itself 1836# 1837# Arguments: 1838# name name of the graph. 1839# flag -key; anything else is an error 1840# args additional args: ?-key key? 1841# 1842# Results: 1843# None. 1844 1845proc ::struct::graph::_unset {name {flag -key} {key data}} { 1846 upvar ::struct::graph::graph${name}::graphData data 1847 1848 if { ![string match "${flag}*" "-key"] } { 1849 error "invalid option \"$flag\": should be \"$name unset\ 1850 ?-key key?\"" 1851 } 1852 1853 if { [info exists data($key)] } { 1854 unset data($key) 1855 } 1856 1857 return 1858} 1859 1860# ::struct::graph::_walk -- 1861# 1862# Walk a graph using a pre-order depth or breadth first 1863# search. Pre-order DFS is the default. At each node that is visited, 1864# a command will be called with the name of the graph and the node. 1865# 1866# Arguments: 1867# name name of the graph. 1868# node node at which to start. 1869# args additional args: ?-order pre|post|both? ?-type {bfs|dfs}? 1870# -command cmd 1871# 1872# Results: 1873# None. 1874 1875proc ::struct::graph::_walk {name node args} { 1876 set usage "$name walk $node ?-dir forward|backward?\ 1877 ?-order pre|post|both? ?-type {bfs|dfs}? -command cmd" 1878 1879 if {[llength $args] > 8 || [llength $args] < 2} { 1880 error "wrong # args: should be \"$usage\"" 1881 } 1882 1883 if { ![__node_exists $name $node] } { 1884 error "node \"$node\" does not exist in graph \"$name\"" 1885 } 1886 1887 # Set defaults 1888 set type dfs 1889 set order pre 1890 set cmd "" 1891 set dir forward 1892 1893 # Process specified options 1894 for {set i 0} {$i < [llength $args]} {incr i} { 1895 set flag [lindex $args $i] 1896 incr i 1897 if { $i >= [llength $args] } { 1898 error "value for \"$flag\" missing: should be \"$usage\"" 1899 } 1900 switch -glob -- $flag { 1901 "-type" { 1902 set type [string tolower [lindex $args $i]] 1903 } 1904 "-order" { 1905 set order [string tolower [lindex $args $i]] 1906 } 1907 "-command" { 1908 set cmd [lindex $args $i] 1909 } 1910 "-dir" { 1911 set dir [string tolower [lindex $args $i]] 1912 } 1913 default { 1914 error "unknown option \"$flag\": should be \"$usage\"" 1915 } 1916 } 1917 } 1918 1919 # Make sure we have a command to run, otherwise what's the point? 1920 if { [string equal $cmd ""] } { 1921 error "no command specified: should be \"$usage\"" 1922 } 1923 1924 # Validate that the given type is good 1925 switch -glob -- $type { 1926 "dfs" { 1927 set type "dfs" 1928 } 1929 "bfs" { 1930 set type "bfs" 1931 } 1932 default { 1933 error "invalid search type \"$type\": should be dfs, or bfs" 1934 } 1935 } 1936 1937 # Validate that the given order is good 1938 switch -glob -- $order { 1939 "both" { 1940 set order both 1941 } 1942 "pre" { 1943 set order pre 1944 } 1945 "post" { 1946 set order post 1947 } 1948 default { 1949 error "invalid search order \"$order\": should be both,\ 1950 pre or post" 1951 } 1952 } 1953 1954 # Validate that the given direction is good 1955 switch -glob -- $dir { 1956 "forward" { 1957 set dir -out 1958 } 1959 "backward" { 1960 set dir -in 1961 } 1962 default { 1963 error "invalid search direction \"$dir\": should be\ 1964 forward or backward" 1965 } 1966 } 1967 1968 # Do the walk 1969 1970 set st [list ] 1971 lappend st $node 1972 array set visited {} 1973 1974 if { [string equal $type "dfs"] } { 1975 if { [string equal $order "pre"] } { 1976 # Pre-order Depth-first search 1977 1978 while { [llength $st] > 0 } { 1979 set node [lindex $st end] 1980 set st [lreplace $st end end] 1981 1982 # Evaluate the command at this node 1983 set cmdcpy $cmd 1984 lappend cmdcpy enter $name $node 1985 uplevel 2 $cmdcpy 1986 1987 set visited($node) . 1988 1989 # Add this node's neighbours (according to direction) 1990 # Have to add them in reverse order 1991 # so that they will be popped left-to-right 1992 1993 set next [_nodes $name $dir $node] 1994 set len [llength $next] 1995 1996 for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { 1997 set nextnode [lindex $next $i] 1998 if {[info exists visited($nextnode)]} { 1999 # Skip nodes already visited 2000 continue 2001 } 2002 lappend st $nextnode 2003 } 2004 } 2005 } elseif { [string equal $order "post"] } { 2006 # Post-order Depth-first search 2007 2008 while { [llength $st] > 0 } { 2009 set node [lindex $st end] 2010 2011 if {[info exists visited($node)]} { 2012 # Second time we are here, pop it, 2013 # then evaluate the command. 2014 2015 set st [lreplace $st end end] 2016 2017 # Evaluate the command at this node 2018 set cmdcpy $cmd 2019 lappend cmdcpy leave $name $node 2020 uplevel 2 $cmdcpy 2021 } else { 2022 # First visit. Remember it. 2023 set visited($node) . 2024 2025 # Add this node's neighbours. 2026 set next [_nodes $name $dir $node] 2027 set len [llength $next] 2028 2029 for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { 2030 set nextnode [lindex $next $i] 2031 if {[info exists visited($nextnode)]} { 2032 # Skip nodes already visited 2033 continue 2034 } 2035 lappend st $nextnode 2036 } 2037 } 2038 } 2039 } else { 2040 # Both-order Depth-first search 2041 2042 while { [llength $st] > 0 } { 2043 set node [lindex $st end] 2044 2045 if {[info exists visited($node)]} { 2046 # Second time we are here, pop it, 2047 # then evaluate the command. 2048 2049 set st [lreplace $st end end] 2050 2051 # Evaluate the command at this node 2052 set cmdcpy $cmd 2053 lappend cmdcpy leave $name $node 2054 uplevel 2 $cmdcpy 2055 } else { 2056 # First visit. Remember it. 2057 set visited($node) . 2058 2059 # Evaluate the command at this node 2060 set cmdcpy $cmd 2061 lappend cmdcpy enter $name $node 2062 uplevel 2 $cmdcpy 2063 2064 # Add this node's neighbours. 2065 set next [_nodes $name $dir $node] 2066 set len [llength $next] 2067 2068 for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { 2069 set nextnode [lindex $next $i] 2070 if {[info exists visited($nextnode)]} { 2071 # Skip nodes already visited 2072 continue 2073 } 2074 lappend st $nextnode 2075 } 2076 } 2077 } 2078 } 2079 2080 } else { 2081 if { [string equal $order "pre"] } { 2082 # Pre-order Breadth first search 2083 while { [llength $st] > 0 } { 2084 set node [lindex $st 0] 2085 set st [lreplace $st 0 0] 2086 # Evaluate the command at this node 2087 set cmdcpy $cmd 2088 lappend cmdcpy enter $name $node 2089 uplevel 2 $cmdcpy 2090 2091 set visited($node) . 2092 2093 # Add this node's neighbours. 2094 foreach child [_nodes $name $dir $node] { 2095 if {[info exists visited($child)]} { 2096 # Skip nodes already visited 2097 continue 2098 } 2099 lappend st $child 2100 } 2101 } 2102 } else { 2103 # Post-order Breadth first search 2104 # Both-order Breadth first search 2105 # Haven't found anything in Knuth 2106 # and unable to define something 2107 # consistent for myself. Leave it 2108 # out. 2109 2110 error "unable to do a ${order}-order breadth first walk" 2111 } 2112 } 2113 return 2114} 2115 2116# ::struct::graph::Union -- 2117# 2118# Return a list which is the union of the elements 2119# in the specified lists. 2120# 2121# Arguments: 2122# args list of lists representing sets. 2123# 2124# Results: 2125# set list representing the union of the argument lists. 2126 2127proc ::struct::graph::Union {args} { 2128 switch -- [llength $args] { 2129 0 { 2130 return {} 2131 } 2132 1 { 2133 return [lindex $args 0] 2134 } 2135 default { 2136 foreach set $args { 2137 foreach e $set { 2138 set tmp($e) . 2139 } 2140 } 2141 return [array names tmp] 2142 } 2143 } 2144} 2145 2146# ### ### ### ######### ######### ######### 2147## Ready 2148 2149namespace eval ::struct { 2150 # Get 'graph::graph' into the general structure namespace. 2151 namespace import -force graph::graph 2152 namespace export graph 2153} 2154package provide struct::graph 1.2.1 2155