1# graph_tcl.tcl -- 2# 3# Implementation of a graph data structure for Tcl. 4# 5# Copyright (c) 2000-2009 by Andreas Kupries <andreas_kupries@users.sourceforge.net> 6# Copyright (c) 2008 by Alejandro Paz <vidriloco@gmail.com> 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: graph_tcl.tcl,v 1.5 2009/11/26 04:42:16 andreas_kupries Exp $ 12 13package require Tcl 8.4 14package require struct::list 15package require struct::set 16 17namespace eval ::struct::graph { 18 # Data storage in the graph module 19 # ------------------------------- 20 # 21 # There's a lot of bits to keep track of for each graph: 22 # nodes 23 # node values 24 # node relationships (arcs) 25 # arc values 26 # 27 # It would quickly become unwieldy to try to keep these in arrays or lists 28 # within the graph namespace itself. Instead, each graph structure will 29 # get its own namespace. Each namespace contains: 30 # node:$node array mapping keys to values for the node $node 31 # arc:$arc array mapping keys to values for the arc $arc 32 # inArcs array mapping nodes to the list of incoming arcs 33 # outArcs array mapping nodes to the list of outgoing arcs 34 # arcNodes array mapping arcs to the two nodes (start & end) 35 36 # counter is used to give a unique name for unnamed graph 37 variable counter 0 38 39 # Only export one command, the one used to instantiate a new graph 40 namespace export graph_tcl 41} 42 43# ::struct::graph::graph_tcl -- 44# 45# Create a new graph with a given name; if no name is given, use 46# graphX, where X is a number. 47# 48# Arguments: 49# name name of the graph; if null, generate one. 50# 51# Results: 52# name name of the graph created 53 54proc ::struct::graph::graph_tcl {args} { 55 variable counter 56 57 set src {} 58 set srctype {} 59 60 switch -exact -- [llength [info level 0]] { 61 1 { 62 # Missing name, generate one. 63 incr counter 64 set name "graph${counter}" 65 } 66 2 { 67 # Standard call. New empty graph. 68 set name [lindex $args 0] 69 } 70 4 { 71 # Copy construction. 72 foreach {name as src} $args break 73 switch -exact -- $as { 74 = - := - as { 75 set srctype graph 76 } 77 deserialize { 78 set srctype serial 79 } 80 default { 81 return -code error \ 82 "wrong # args: should be \"struct::graph ?name ?=|:=|as|deserialize source??\"" 83 } 84 } 85 } 86 default { 87 # Error. 88 return -code error \ 89 "wrong # args: should be \"struct::graph ?name ?=|:=|as|deserialize source??\"" 90 } 91 } 92 93 # FIRST, qualify the name. 94 if {![string match "::*" $name]} { 95 # Get caller's namespace; append :: if not global namespace. 96 set ns [uplevel 1 [list namespace current]] 97 if {"::" != $ns} { 98 append ns "::" 99 } 100 101 set name "$ns$name" 102 } 103 if {[llength [info commands $name]]} { 104 return -code error "command \"$name\" already exists, unable to create graph" 105 } 106 107 # Set up the namespace 108 namespace eval $name { 109 110 # Set up the map for values associated with the graph itself 111 variable graphAttr 112 array set graphAttr {} 113 114 # Set up the node attribute mapping 115 variable nodeAttr 116 array set nodeAttr {} 117 118 # Set up the arc attribute mapping 119 variable arcAttr 120 array set arcAttr {} 121 122 # Set up the map from nodes to the arcs coming to them 123 variable inArcs 124 array set inArcs {} 125 126 # Set up the map from nodes to the arcs going out from them 127 variable outArcs 128 array set outArcs {} 129 130 # Set up the map from arcs to the nodes they touch. 131 variable arcNodes 132 array set arcNodes {} 133 134 # Set up a value for use in creating unique node names 135 variable nextUnusedNode 136 set nextUnusedNode 1 137 138 # Set up a value for use in creating unique arc names 139 variable nextUnusedArc 140 set nextUnusedArc 1 141 142 # Set up a counter for use in creating attribute arrays. 143 variable nextAttr 144 set nextAttr 0 145 146 # Set up a map from arcs to their weights. Note: Only arcs 147 # which actually have a weight are recorded in the map, to 148 # keep memory usage down. 149 variable arcWeight 150 array set arcWeight {} 151 } 152 153 # Create the command to manipulate the graph 154 interp alias {} $name {} ::struct::graph::GraphProc $name 155 156 # Automatic execution of assignment if a source 157 # is present. 158 if {$src != {}} { 159 switch -exact -- $srctype { 160 graph {_= $name $src} 161 serial {_deserialize $name $src} 162 default { 163 return -code error \ 164 "Internal error, illegal srctype \"$srctype\"" 165 } 166 } 167 } 168 169 return $name 170} 171 172########################## 173# Private functions follow 174 175# ::struct::graph::GraphProc -- 176# 177# Command that processes all graph object commands. 178# 179# Arguments: 180# name name of the graph object to manipulate. 181# args command name and args for the command 182# 183# Results: 184# Varies based on command to perform 185 186proc ::struct::graph::GraphProc {name {cmd ""} args} { 187 # Do minimal args checks here 188 if { [llength [info level 0]] == 2 } { 189 return -code error "wrong # args: should be \"$name option ?arg arg ...?\"" 190 } 191 192 # Split the args into command and args components 193 set sub _$cmd 194 if { [llength [info commands ::struct::graph::$sub]] == 0 } { 195 set optlist [lsort [info commands ::struct::graph::_*]] 196 set xlist {} 197 foreach p $optlist { 198 set p [namespace tail $p] 199 if {[string match __* $p]} {continue} 200 lappend xlist [string range $p 1 end] 201 } 202 set optlist [linsert [join $xlist ", "] "end-1" "or"] 203 return -code error \ 204 "bad option \"$cmd\": must be $optlist" 205 } 206 uplevel 1 [linsert $args 0 ::struct::graph::$sub $name] 207} 208 209# ::struct::graph::_= -- 210# 211# Assignment operator. Copies the source graph into the 212# destination, destroying the original information. 213# 214# Arguments: 215# name Name of the graph object we are copying into. 216# source Name of the graph object providing us with the 217# data to copy. 218# 219# Results: 220# Nothing. 221 222proc ::struct::graph::_= {name source} { 223 _deserialize $name [$source serialize] 224 return 225} 226 227# ::struct::graph::_--> -- 228# 229# Reverse assignment operator. Copies this graph into the 230# destination, destroying the original information. 231# 232# Arguments: 233# name Name of the graph object to copy 234# dest Name of the graph object we are copying to. 235# 236# Results: 237# Nothing. 238 239proc ::struct::graph::_--> {name dest} { 240 $dest deserialize [_serialize $name] 241 return 242} 243 244# ::struct::graph::_append -- 245# 246# Append a value for an attribute in a graph. 247# 248# Arguments: 249# name name of the graph. 250# args key value 251# 252# Results: 253# val value associated with the given key of the given arc 254 255proc ::struct::graph::_append {name key value} { 256 variable ${name}::graphAttr 257 return [append graphAttr($key) $value] 258} 259 260# ::struct::graph::_lappend -- 261# 262# lappend a value for an attribute in a graph. 263# 264# Arguments: 265# name name of the graph. 266# args key value 267# 268# Results: 269# val value associated with the given key of the given arc 270 271proc ::struct::graph::_lappend {name key value} { 272 variable ${name}::graphAttr 273 return [lappend graphAttr($key) $value] 274} 275 276# ::struct::graph::_arc -- 277# 278# Dispatches the invocation of arc methods to the proper handler 279# procedure. 280# 281# Arguments: 282# name name of the graph. 283# cmd arc command to invoke 284# args arguments to propagate to the handler for the arc command 285# 286# Results: 287# As of the invoked handler. 288 289proc ::struct::graph::_arc {name cmd args} { 290 # Split the args into command and args components 291 292 set sub __arc_$cmd 293 if { [llength [info commands ::struct::graph::$sub]] == 0 } { 294 set optlist [lsort [info commands ::struct::graph::__arc_*]] 295 set xlist {} 296 foreach p $optlist { 297 set p [namespace tail $p] 298 lappend xlist [string range $p 6 end] 299 } 300 set optlist [linsert [join $xlist ", "] "end-1" "or"] 301 return -code error \ 302 "bad option \"$cmd\": must be $optlist" 303 } 304 uplevel 1 [linsert $args 0 ::struct::graph::$sub $name] 305} 306 307# ::struct::graph::__arc_delete -- 308# 309# Remove an arc from a graph, including all of its values. 310# 311# Arguments: 312# name name of the graph. 313# args list of arcs to delete. 314# 315# Results: 316# None. 317 318proc ::struct::graph::__arc_delete {name args} { 319 if {![llength $args]} { 320 return {wrong # args: should be "::struct::graph::__arc_delete name arc arc..."} 321 } 322 323 foreach arc $args {CheckMissingArc $name $arc} 324 325 variable ${name}::inArcs 326 variable ${name}::outArcs 327 variable ${name}::arcNodes 328 variable ${name}::arcAttr 329 variable ${name}::arcWeight 330 331 foreach arc $args { 332 foreach {source target} $arcNodes($arc) break ; # lassign 333 334 unset arcNodes($arc) 335 336 if {[info exists arcAttr($arc)]} { 337 unset ${name}::$arcAttr($arc) ;# Note the double indirection here 338 unset arcAttr($arc) 339 } 340 if {[info exists arcWeight($arc)]} { 341 unset arcWeight($arc) 342 } 343 344 # Remove arc from the arc lists of source and target nodes. 345 346 set index [lsearch -exact $outArcs($source) $arc] 347 ldelete outArcs($source) $index 348 349 set index [lsearch -exact $inArcs($target) $arc] 350 ldelete inArcs($target) $index 351 } 352 353 return 354} 355 356# ::struct::graph::__arc_exists -- 357# 358# Test for existence of a given arc in a graph. 359# 360# Arguments: 361# name name of the graph. 362# arc arc to look for. 363# 364# Results: 365# 1 if the arc exists, 0 else. 366 367proc ::struct::graph::__arc_exists {name arc} { 368 return [info exists ${name}::arcNodes($arc)] 369} 370 371# ::struct::graph::__arc_flip -- 372# 373# Exchanges origin and destination node of the specified arc. 374# 375# Arguments: 376# name name of the graph object. 377# arc arc to change. 378# 379# Results: 380# None 381 382proc ::struct::graph::__arc_flip {name arc} { 383 CheckMissingArc $name $arc 384 385 variable ${name}::arcNodes 386 variable ${name}::outArcs 387 variable ${name}::inArcs 388 389 set oldsource [lindex $arcNodes($arc) 0] 390 set oldtarget [lindex $arcNodes($arc) 1] 391 392 if {[string equal $oldsource $oldtarget]} return 393 394 set newtarget $oldsource 395 set newsource $oldtarget 396 397 set arcNodes($arc) [lreplace $arcNodes($arc) 0 0 $newsource] 398 lappend outArcs($newsource) $arc 399 ldelete outArcs($oldsource) [lsearch -exact $outArcs($oldsource) $arc] 400 401 set arcNodes($arc) [lreplace $arcNodes($arc) 1 1 $newtarget] 402 lappend inArcs($newtarget) $arc 403 ldelete inArcs($oldtarget) [lsearch -exact $inArcs($oldtarget) $arc] 404 return 405} 406 407# ::struct::graph::__arc_get -- 408# 409# Get a keyed value from an arc in a graph. 410# 411# Arguments: 412# name name of the graph. 413# arc arc to query. 414# key key to lookup 415# 416# Results: 417# value value associated with the key given. 418 419proc ::struct::graph::__arc_get {name arc key} { 420 CheckMissingArc $name $arc 421 422 variable ${name}::arcAttr 423 if {![info exists arcAttr($arc)]} { 424 # No attribute data for this arc, key has to be invalid. 425 return -code error "invalid key \"$key\" for arc \"$arc\"" 426 } 427 428 upvar ${name}::$arcAttr($arc) data 429 if { ![info exists data($key)] } { 430 return -code error "invalid key \"$key\" for arc \"$arc\"" 431 } 432 return $data($key) 433} 434 435# ::struct::graph::__arc_getall -- 436# 437# Get a serialized array of key/value pairs from an arc in a graph. 438# 439# Arguments: 440# name name of the graph. 441# arc arc to query. 442# pattern optional glob pattern to restrict retrieval 443# 444# Results: 445# value serialized array of key/value pairs. 446 447proc ::struct::graph::__arc_getall {name arc {pattern *}} { 448 CheckMissingArc $name $arc 449 450 variable ${name}::arcAttr 451 if {![info exists arcAttr($arc)]} { 452 # No attributes ... 453 return {} 454 } 455 456 upvar ${name}::$arcAttr($arc) data 457 return [array get data $pattern] 458} 459 460# ::struct::graph::__arc_keys -- 461# 462# Get a list of keys for an arc in a graph. 463# 464# Arguments: 465# name name of the graph. 466# arc arc to query. 467# pattern optional glob pattern to restrict retrieval 468# 469# Results: 470# value value associated with the key given. 471 472proc ::struct::graph::__arc_keys {name arc {pattern *}} { 473 CheckMissingArc $name $arc 474 475 variable ${name}::arcAttr 476 if {![info exists arcAttr($arc)]} { 477 # No attributes ... 478 return {} 479 } 480 481 upvar ${name}::$arcAttr($arc) data 482 return [array names data $pattern] 483} 484 485# ::struct::graph::__arc_keyexists -- 486# 487# Test for existence of a given key for a given arc in a graph. 488# 489# Arguments: 490# name name of the graph. 491# arc arc to query. 492# key key to lookup 493# 494# Results: 495# 1 if the key exists, 0 else. 496 497proc ::struct::graph::__arc_keyexists {name arc key} { 498 CheckMissingArc $name $arc 499 500 variable ${name}::arcAttr 501 if {![info exists arcAttr($arc)]} { 502 # No attribute data for this arc, key cannot exist. 503 return 0 504 } 505 506 upvar ${name}::$arcAttr($arc) data 507 return [info exists data($key)] 508} 509 510# ::struct::graph::__arc_insert -- 511# 512# Add an arc to a graph. 513# 514# Arguments: 515# name name of the graph. 516# source source node of the new arc 517# target target node of the new arc 518# args arc to insert; must be unique. If none is given, 519# the routine will generate a unique node name. 520# 521# Results: 522# arc The name of the new arc. 523 524proc ::struct::graph::__arc_insert {name source target args} { 525 526 if { [llength $args] == 0 } { 527 # No arc name was given; generate a unique one 528 set arc [__generateUniqueArcName $name] 529 } elseif { [llength $args] > 1 } { 530 return {wrong # args: should be "::struct::graph::__arc_insert name source target ?arc?"} 531 } else { 532 set arc [lindex $args 0] 533 } 534 535 CheckDuplicateArc $name $arc 536 CheckMissingNode $name $source {source } 537 CheckMissingNode $name $target {target } 538 539 variable ${name}::inArcs 540 variable ${name}::outArcs 541 variable ${name}::arcNodes 542 543 # Set up the new arc 544 set arcNodes($arc) [list $source $target] 545 546 # Add this arc to the arc lists of its source resp. target nodes. 547 lappend outArcs($source) $arc 548 lappend inArcs($target) $arc 549 550 return $arc 551} 552 553# ::struct::graph::__arc_rename -- 554# 555# Rename a arc in place. 556# 557# Arguments: 558# name name of the graph. 559# arc Name of the arc to rename 560# newname The new name of the arc. 561# 562# Results: 563# The new name of the arc. 564 565proc ::struct::graph::__arc_rename {name arc newname} { 566 CheckMissingArc $name $arc 567 CheckDuplicateArc $name $newname 568 569 set oldname $arc 570 571 # Perform the rename in the internal 572 # data structures. 573 574 # - graphAttr - not required, arc independent. 575 # - nodeAttr - not required, arc independent. 576 # - counters - not required 577 578 variable ${name}::arcAttr 579 variable ${name}::inArcs 580 variable ${name}::outArcs 581 variable ${name}::arcNodes 582 variable ${name}::arcWeight 583 584 # Arc relocation 585 586 set arcNodes($newname) [set nodes $arcNodes($oldname)] 587 unset arcNodes($oldname) 588 589 # Update the two nodes ... 590 foreach {start end} $nodes break 591 592 set pos [lsearch -exact $inArcs($end) $oldname] 593 lset inArcs($end) $pos $newname 594 595 set pos [lsearch -exact $outArcs($start) $oldname] 596 lset outArcs($start) $pos $newname 597 598 if {[info exists arcAttr($oldname)]} { 599 set arcAttr($newname) $arcAttr($oldname) 600 unset arcAttr($oldname) 601 } 602 603 if {[info exists arcWeight($oldname)]} { 604 set arcWeight($newname) $arcWeight($oldname) 605 unset arcWeight($oldname) 606 } 607 608 return $newname 609} 610 611# ::struct::graph::__arc_set -- 612# 613# Set or get a value for an arc in a graph. 614# 615# Arguments: 616# name name of the graph. 617# arc arc to modify or query. 618# key attribute to modify or query 619# args ?value? 620# 621# Results: 622# val value associated with the given key of the given arc 623 624proc ::struct::graph::__arc_set {name arc key args} { 625 if { [llength $args] > 1 } { 626 return -code error "wrong # args: should be \"$name arc set arc key ?value?\"" 627 } 628 CheckMissingArc $name $arc 629 630 if { [llength $args] > 0 } { 631 # Setting the value. This may have to create 632 # the attribute array for this particular 633 # node 634 635 variable ${name}::arcAttr 636 if {![info exists arcAttr($arc)]} { 637 # No attribute data for this node, 638 # so create it as we need it now. 639 GenAttributeStorage $name arc $arc 640 } 641 642 upvar ${name}::$arcAttr($arc) data 643 return [set data($key) [lindex $args end]] 644 } else { 645 # Getting a value 646 return [__arc_get $name $arc $key] 647 } 648} 649 650# ::struct::graph::__arc_append -- 651# 652# Append a value for an arc in a graph. 653# 654# Arguments: 655# name name of the graph. 656# arc arc to modify or query. 657# args key value 658# 659# Results: 660# val value associated with the given key of the given arc 661 662proc ::struct::graph::__arc_append {name arc key value} { 663 CheckMissingArc $name $arc 664 665 variable ${name}::arcAttr 666 if {![info exists arcAttr($arc)]} { 667 # No attribute data for this arc, 668 # so create it as we need it. 669 GenAttributeStorage $name arc $arc 670 } 671 672 upvar ${name}::$arcAttr($arc) data 673 return [append data($key) $value] 674} 675 676# ::struct::graph::__arc_attr -- 677# 678# Return attribute data for one key and multiple arcs, possibly all. 679# 680# Arguments: 681# name Name of the graph object. 682# key Name of the attribute to retrieve. 683# 684# Results: 685# children Dictionary mapping arcs to attribute data. 686 687proc ::struct::graph::__arc_attr {name key args} { 688 # Syntax: 689 # 690 # t attr key 691 # t attr key -arcs {arclist} 692 # t attr key -glob arcpattern 693 # t attr key -regexp arcpattern 694 695 variable ${name}::arcAttr 696 697 set usage "wrong # args: should be \"[list $name] arc attr key ?-arcs list|-glob pattern|-regexp pattern?\"" 698 if {([llength $args] != 0) && ([llength $args] != 2)} { 699 return -code error $usage 700 } elseif {[llength $args] == 0} { 701 # This automatically restricts the list 702 # to arcs which can have the attribute 703 # in question. 704 705 set arcs [array names arcAttr] 706 } else { 707 # Determine a list of arcs to look at 708 # based on the chosen restriction. 709 710 foreach {mode value} $args break 711 switch -exact -- $mode { 712 -arcs { 713 # This is the only branch where we have to 714 # perform an explicit restriction to the 715 # arcs which have attributes. 716 set arcs {} 717 foreach n $value { 718 if {![info exists arcAttr($n)]} continue 719 lappend arcs $n 720 } 721 } 722 -glob { 723 set arcs [array names arcAttr $value] 724 } 725 -regexp { 726 set arcs {} 727 foreach n [array names arcAttr] { 728 if {![regexp -- $value $n]} continue 729 lappend arcs $n 730 } 731 } 732 default { 733 return -code error "bad type \"$mode\": must be -arcs, -glob, or -regexp" 734 } 735 } 736 } 737 738 # Without possibly matching arcs 739 # the result has to be empty. 740 741 if {![llength $arcs]} { 742 return {} 743 } 744 745 # Now locate matching keys and their values. 746 747 set result {} 748 foreach n $arcs { 749 upvar ${name}::$arcAttr($n) data 750 if {[info exists data($key)]} { 751 lappend result $n $data($key) 752 } 753 } 754 755 return $result 756} 757 758# ::struct::graph::__arc_lappend -- 759# 760# lappend a value for an arc in a graph. 761# 762# Arguments: 763# name name of the graph. 764# arc arc to modify or query. 765# args key value 766# 767# Results: 768# val value associated with the given key of the given arc 769 770proc ::struct::graph::__arc_lappend {name arc key value} { 771 CheckMissingArc $name $arc 772 773 variable ${name}::arcAttr 774 if {![info exists arcAttr($arc)]} { 775 # No attribute data for this arc, 776 # so create it as we need it. 777 GenAttributeStorage $name arc $arc 778 } 779 780 upvar ${name}::$arcAttr($arc) data 781 return [lappend data($key) $value] 782} 783 784# ::struct::graph::__arc_source -- 785# 786# Return the node at the beginning of the specified arc. 787# 788# Arguments: 789# name name of the graph object. 790# arc arc to look up. 791# 792# Results: 793# node name of the node. 794 795proc ::struct::graph::__arc_source {name arc} { 796 CheckMissingArc $name $arc 797 798 variable ${name}::arcNodes 799 return [lindex $arcNodes($arc) 0] 800} 801 802# ::struct::graph::__arc_target -- 803# 804# Return the node at the end of the specified arc. 805# 806# Arguments: 807# name name of the graph object. 808# arc arc to look up. 809# 810# Results: 811# node name of the node. 812 813proc ::struct::graph::__arc_target {name arc} { 814 CheckMissingArc $name $arc 815 816 variable ${name}::arcNodes 817 return [lindex $arcNodes($arc) 1] 818} 819 820# ::struct::graph::__arc_nodes -- 821# 822# Return a list containing both source and target nodes of the arc. 823# 824# Arguments: 825# name name of the graph object. 826# arc arc to look up. 827# 828# Results: 829# nodes list containing the names of the connected nodes node. 830# None 831 832proc ::struct::graph::__arc_nodes {name arc} { 833 CheckMissingArc $name $arc 834 835 variable ${name}::arcNodes 836 return $arcNodes($arc) 837} 838 839# ::struct::graph::__arc_move-target -- 840# 841# Change the destination node of the specified arc. 842# The arc is rotated around its origin to a different 843# node. 844# 845# Arguments: 846# name name of the graph object. 847# arc arc to change. 848# newtarget new destination/target of the arc. 849# 850# Results: 851# None 852 853proc ::struct::graph::__arc_move-target {name arc newtarget} { 854 CheckMissingArc $name $arc 855 CheckMissingNode $name $newtarget 856 857 variable ${name}::arcNodes 858 variable ${name}::inArcs 859 860 set oldtarget [lindex $arcNodes($arc) 1] 861 if {[string equal $oldtarget $newtarget]} return 862 863 set arcNodes($arc) [lreplace $arcNodes($arc) 1 1 $newtarget] 864 865 lappend inArcs($newtarget) $arc 866 ldelete inArcs($oldtarget) [lsearch -exact $inArcs($oldtarget) $arc] 867 return 868} 869 870# ::struct::graph::__arc_move-source -- 871# 872# Change the origin node of the specified arc. 873# The arc is rotated around its destination to a different 874# node. 875# 876# Arguments: 877# name name of the graph object. 878# arc arc to change. 879# newsource new origin/source of the arc. 880# 881# Results: 882# None 883 884proc ::struct::graph::__arc_move-source {name arc newsource} { 885 CheckMissingArc $name $arc 886 CheckMissingNode $name $newsource 887 888 variable ${name}::arcNodes 889 variable ${name}::outArcs 890 891 set oldsource [lindex $arcNodes($arc) 0] 892 if {[string equal $oldsource $newsource]} return 893 894 set arcNodes($arc) [lreplace $arcNodes($arc) 0 0 $newsource] 895 896 lappend outArcs($newsource) $arc 897 ldelete outArcs($oldsource) [lsearch -exact $outArcs($oldsource) $arc] 898 return 899} 900 901# ::struct::graph::__arc_move -- 902# 903# Changes both origin and destination node of the specified arc. 904# 905# Arguments: 906# name name of the graph object. 907# arc arc to change. 908# newsource new origin/source of the arc. 909# newtarget new destination/target of the arc. 910# 911# Results: 912# None 913 914proc ::struct::graph::__arc_move {name arc newsource newtarget} { 915 CheckMissingArc $name $arc 916 CheckMissingNode $name $newsource 917 CheckMissingNode $name $newtarget 918 919 variable ${name}::arcNodes 920 variable ${name}::outArcs 921 variable ${name}::inArcs 922 923 set oldsource [lindex $arcNodes($arc) 0] 924 if {![string equal $oldsource $newsource]} { 925 set arcNodes($arc) [lreplace $arcNodes($arc) 0 0 $newsource] 926 lappend outArcs($newsource) $arc 927 ldelete outArcs($oldsource) [lsearch -exact $outArcs($oldsource) $arc] 928 } 929 930 set oldtarget [lindex $arcNodes($arc) 1] 931 if {![string equal $oldtarget $newtarget]} { 932 set arcNodes($arc) [lreplace $arcNodes($arc) 1 1 $newtarget] 933 lappend inArcs($newtarget) $arc 934 ldelete inArcs($oldtarget) [lsearch -exact $inArcs($oldtarget) $arc] 935 } 936 return 937} 938 939# ::struct::graph::__arc_unset -- 940# 941# Remove a keyed value from a arc. 942# 943# Arguments: 944# name name of the graph. 945# arc arc to modify. 946# key attribute to remove 947# 948# Results: 949# None. 950 951proc ::struct::graph::__arc_unset {name arc key} { 952 CheckMissingArc $name $arc 953 954 variable ${name}::arcAttr 955 if {![info exists arcAttr($arc)]} { 956 # No attribute data for this arc, 957 # nothing to do. 958 return 959 } 960 961 upvar ${name}::$arcAttr($arc) data 962 catch {unset data($key)} 963 964 if {[array size data] == 0} { 965 # No attributes stored for this arc, squash the whole array. 966 unset arcAttr($arc) 967 unset data 968 } 969 return 970} 971 972# ::struct::graph::__arc_getunweighted -- 973# 974# Return the arcs which have no weight defined. 975# 976# Arguments: 977# name name of the graph. 978# 979# Results: 980# arcs list of arcs without weights. 981 982proc ::struct::graph::__arc_getunweighted {name} { 983 variable ${name}::arcNodes 984 variable ${name}::arcWeight 985 return [struct::set difference \ 986 [array names arcNodes] \ 987 [array names arcWeight]] 988} 989 990# ::struct::graph::__arc_getweight -- 991# 992# Get the weight given to an arc in a graph. 993# Throws an error if the arc has no weight defined for it. 994# 995# Arguments: 996# name name of the graph. 997# arc arc to query. 998# 999# Results: 1000# weight The weight defined for the arc. 1001 1002proc ::struct::graph::__arc_getweight {name arc} { 1003 CheckMissingArc $name $arc 1004 1005 variable ${name}::arcWeight 1006 if {![info exists arcWeight($arc)]} { 1007 return -code error "arc \"$arc\" has no weight" 1008 } 1009 return $arcWeight($arc) 1010} 1011 1012# ::struct::graph::__arc_setunweighted -- 1013# 1014# Define a weight for all arcs which have no weight defined. 1015# After this call no arc will be unweighted. 1016# 1017# Arguments: 1018# name name of the graph. 1019# defval weight to give to all unweighted arcs 1020# 1021# Results: 1022# None 1023 1024proc ::struct::graph::__arc_setunweighted {name {weight 0}} { 1025 variable ${name}::arcWeight 1026 foreach arc [__arc_getunweighted $name] { 1027 set arcWeight($arc) $weight 1028 } 1029 return 1030} 1031 1032# ::struct::graph::__arc_setweight -- 1033# 1034# Define a weight for an arc. 1035# 1036# Arguments: 1037# name name of the graph. 1038# arc arc to modify 1039# weight the weight to set for the arc 1040# 1041# Results: 1042# weight The new weight 1043 1044proc ::struct::graph::__arc_setweight {name arc weight} { 1045 CheckMissingArc $name $arc 1046 1047 variable ${name}::arcWeight 1048 set arcWeight($arc) $weight 1049 return $weight 1050} 1051 1052# ::struct::graph::__arc_unsetweight -- 1053# 1054# Remove the weight for an arc. 1055# 1056# Arguments: 1057# name name of the graph. 1058# arc arc to modify 1059# 1060# Results: 1061# None. 1062 1063proc ::struct::graph::__arc_unsetweight {name arc} { 1064 CheckMissingArc $name $arc 1065 1066 variable ${name}::arcWeight 1067 if {[info exists arcWeight($arc)]} { 1068 unset arcWeight($arc) 1069 } 1070 return 1071} 1072 1073# ::struct::graph::__arc_hasweight -- 1074# 1075# Remove the weight for an arc. 1076# 1077# Arguments: 1078# name name of the graph. 1079# arc arc to modify 1080# 1081# Results: 1082# None. 1083 1084proc ::struct::graph::__arc_hasweight {name arc} { 1085 CheckMissingArc $name $arc 1086 1087 variable ${name}::arcWeight 1088 return [info exists arcWeight($arc)] 1089} 1090 1091# ::struct::graph::__arc_weights -- 1092# 1093# Return the arcs and weights for all arcs which have such. 1094# 1095# Arguments: 1096# name name of the graph. 1097# 1098# Results: 1099# aw dictionary mapping arcs to their weights. 1100 1101proc ::struct::graph::__arc_weights {name} { 1102 variable ${name}::arcWeight 1103 return [array get arcWeight] 1104} 1105 1106# ::struct::graph::_arcs -- 1107# 1108# Return a list of all arcs in a graph satisfying some 1109# node based restriction. 1110# 1111# Arguments: 1112# name name of the graph. 1113# 1114# Results: 1115# arcs list of arcs 1116 1117proc ::struct::graph::_arcs {name args} { 1118 1119 CheckE $name arcs $args 1120 1121 switch -exact -- $cond { 1122 none {set arcs [ArcsNONE $name]} 1123 in {set arcs [ArcsIN $name $condNodes]} 1124 out {set arcs [ArcsOUT $name $condNodes]} 1125 adj {set arcs [ArcsADJ $name $condNodes]} 1126 inner {set arcs [ArcsINN $name $condNodes]} 1127 embedding {set arcs [ArcsEMB $name $condNodes]} 1128 default {return -code error "Can't happen, panic"} 1129 } 1130 1131 # 1132 # We have a list of arcs that match the relation to the nodes. 1133 # Now filter according to -key and -value. 1134 # 1135 1136 if {$haveKey && $haveValue} { 1137 set arcs [ArcsKV $name $key $value $arcs] 1138 } elseif {$haveKey} { 1139 set arcs [ArcsK $name $key $arcs] 1140 } 1141 1142 # 1143 # Apply the general filter command, if specified. 1144 # 1145 1146 if {$haveFilter} { 1147 lappend fcmd $name 1148 set arcs [uplevel 1 [list ::struct::list filter $arcs $fcmd]] 1149 } 1150 1151 return $arcs 1152} 1153 1154proc ::struct::graph::ArcsIN {name cn} { 1155 # arcs -in. "Arcs going into the node set" 1156 # 1157 # ARC/in (NS) := { a | target(a) in NS } 1158 1159 # The result is all arcs going to at least one node in the set 1160 # 'cn' of nodes. 1161 1162 # As an arc has only one destination, i.e. is the 1163 # in-arc of exactly one node it is impossible to 1164 # count an arc twice. Therefore there is no need 1165 # to keep track of arcs to avoid duplicates. 1166 1167 variable ${name}::inArcs 1168 1169 set arcs {} 1170 foreach node $cn { 1171 foreach e $inArcs($node) { 1172 lappend arcs $e 1173 } 1174 } 1175 1176 return $arcs 1177} 1178 1179proc ::struct::graph::ArcsOUT {name cn} { 1180 # arcs -out. "Arcs coming from the node set" 1181 # 1182 # ARC/out (NS) := { a | source(a) in NS } 1183 1184 # The result is all arcs coming from at least one node in the list 1185 # of arguments. 1186 1187 variable ${name}::outArcs 1188 1189 set arcs {} 1190 foreach node $cn { 1191 foreach e $outArcs($node) { 1192 lappend arcs $e 1193 } 1194 } 1195 1196 return $arcs 1197} 1198 1199proc ::struct::graph::ArcsADJ {name cn} { 1200 # arcs -adj. "Arcs adjacent to the node set" 1201 # 1202 # ARC/adj (NS) := ARC/in (NS) + ARC/out (NS) 1203 1204 # Result is all arcs coming from or going to at 1205 # least one node in the list of arguments. 1206 1207 return [struct::set union \ 1208 [ArcsIN $name $cn] \ 1209 [ArcsOUT $name $cn]] 1210 if 0 { 1211 # Alternate implementation using arrays, 1212 # implementing the set union directly, 1213 # intertwined with the data retrieval. 1214 1215 array set coll {} 1216 foreach node $condNodes { 1217 foreach e $inArcs($node) { 1218 if {[info exists coll($e)]} {continue} 1219 lappend arcs $e 1220 set coll($e) . 1221 } 1222 foreach e $outArcs($node) { 1223 if {[info exists coll($e)]} {continue} 1224 lappend arcs $e 1225 set coll($e) . 1226 } 1227 } 1228 } 1229} 1230 1231proc ::struct::graph::ArcsINN {name cn} { 1232 # arcs -adj. "Arcs inside the node set" 1233 # 1234 # ARC/inner (NS) := ARC/in (NS) * ARC/out (NS) 1235 1236 # Result is all arcs running between nodes 1237 # in the list. 1238 1239 return [struct::set intersect \ 1240 [ArcsIN $name $cn] \ 1241 [ArcsOUT $name $cn]] 1242 if 0 { 1243 # Alternate implementation using arrays, 1244 # implementing the set intersection 1245 # directly, intertwined with the data 1246 # retrieval. 1247 1248 array set coll {} 1249 # Here we do need 'coll' as each might be an in- and 1250 # out-arc for one or two nodes in the list of arguments. 1251 1252 array set group {} 1253 foreach node $condNodes { 1254 set group($node) . 1255 } 1256 1257 foreach node $condNodes { 1258 foreach e $inArcs($node) { 1259 set n [lindex $arcNodes($e) 0] 1260 if {![info exists group($n)]} {continue} 1261 if { [info exists coll($e)]} {continue} 1262 lappend arcs $e 1263 set coll($e) . 1264 } 1265 # Second iteration over outgoing arcs not 1266 # required. Any arc found above would be found here as 1267 # well, and arcs not recognized above can't be 1268 # recognized by the out loop either. 1269 } 1270 } 1271} 1272 1273proc ::struct::graph::ArcsEMB {name cn} { 1274 # arcs -adj. "Arcs bordering the node set" 1275 # 1276 # ARC/emb (NS) := ARC/inner (NS) - ARC/adj (NS) 1277 # <=> (ARC/in + ARC/out) - (ARC/in * ARC/out) 1278 # <=> (ARC/in - ARC/out) + (ARC/out - ARC/in) 1279 # <=> symmetric difference (ARC/in, ARC/out) 1280 1281 # Result is all arcs from -adj minus the arcs from -inner. 1282 # IOW all arcs going from a node in the list to a node 1283 # which is *not* in the list 1284 1285 return [struct::set symdiff \ 1286 [ArcsIN $name $cn] \ 1287 [ArcsOUT $name $cn]] 1288 if 0 { 1289 # Alternate implementation using arrays, 1290 # implementing the set intersection 1291 # directly, intertwined with the data 1292 # retrieval. 1293 1294 # This also means that no arc can be counted twice as it 1295 # is either going to a node, or coming from a node in the 1296 # list, but it can't do both, because then it is part of 1297 # -inner, which was excluded! 1298 1299 array set group {} 1300 foreach node $condNodes { 1301 set group($node) . 1302 } 1303 1304 foreach node $condNodes { 1305 foreach e $inArcs($node) { 1306 set n [lindex $arcNodes($e) 0] 1307 if {[info exists group($n)]} {continue} 1308 # if {[info exists coll($e)]} {continue} 1309 lappend arcs $e 1310 # set coll($e) . 1311 } 1312 foreach e $outArcs($node) { 1313 set n [lindex $arcNodes($e) 1] 1314 if {[info exists group($n)]} {continue} 1315 # if {[info exists coll($e)]} {continue} 1316 lappend arcs $e 1317 # set coll($e) . 1318 } 1319 } 1320 } 1321} 1322 1323proc ::struct::graph::ArcsNONE {name} { 1324 variable ${name}::arcNodes 1325 return [array names arcNodes] 1326} 1327 1328proc ::struct::graph::ArcsKV {name key value arcs} { 1329 set filteredArcs {} 1330 foreach arc $arcs { 1331 catch { 1332 set aval [__arc_get $name $arc $key] 1333 if {$aval == $value} { 1334 lappend filteredArcs $arc 1335 } 1336 } 1337 } 1338 return $filteredArcs 1339} 1340 1341proc ::struct::graph::ArcsK {name key arcs} { 1342 set filteredArcs {} 1343 foreach arc $arcs { 1344 catch { 1345 __arc_get $name $arc $key 1346 lappend filteredArcs $arc 1347 } 1348 } 1349 return $filteredArcs 1350} 1351 1352# ::struct::graph::_deserialize -- 1353# 1354# Assignment operator. Copies a serialization into the 1355# destination, destroying the original information. 1356# 1357# Arguments: 1358# name Name of the graph object we are copying into. 1359# serial Serialized graph to copy from. 1360# 1361# Results: 1362# Nothing. 1363 1364proc ::struct::graph::_deserialize {name serial} { 1365 # As we destroy the original graph as part of 1366 # the copying process we don't have to deal 1367 # with issues like node names from the new graph 1368 # interfering with the old ... 1369 1370 # I. Get the serialization of the source graph 1371 # and check it for validity. 1372 1373 CheckSerialization $serial \ 1374 gattr nattr aattr ina outa arcn arcw 1375 1376 # Get all the relevant data into the scope 1377 1378 variable ${name}::graphAttr 1379 variable ${name}::nodeAttr 1380 variable ${name}::arcAttr 1381 variable ${name}::inArcs 1382 variable ${name}::outArcs 1383 variable ${name}::arcNodes 1384 variable ${name}::nextAttr 1385 variable ${name}::arcWeight 1386 1387 # Kill the existing information and insert the new 1388 # data in their place. 1389 1390 array unset inArcs * 1391 array unset outArcs * 1392 array set inArcs [array get ina] 1393 array set outArcs [array get outa] 1394 unset ina outa 1395 1396 array unset arcNodes * 1397 array set arcNodes [array get arcn] 1398 unset arcn 1399 1400 array unset arcWeight * 1401 array set arcWeight [array get arcw] 1402 unset arcw 1403 1404 set nextAttr 0 1405 foreach a [array names nodeAttr] { 1406 unset ${name}::$nodeAttr($a) 1407 } 1408 foreach a [array names arcAttr] { 1409 unset ${name}::$arcAttr($a) 1410 } 1411 foreach n [array names nattr] { 1412 GenAttributeStorage $name node $n 1413 array set ${name}::$nodeAttr($n) $nattr($n) 1414 } 1415 foreach a [array names aattr] { 1416 GenAttributeStorage $name arc $a 1417 array set ${name}::$arcAttr($a) $aattr($a) 1418 } 1419 1420 array unset graphAttr * 1421 array set graphAttr $gattr 1422 1423 ## Debug ## Dump internals ... 1424 if {0} { 1425 puts "___________________________________ $name" 1426 parray inArcs 1427 parray outArcs 1428 parray arcNodes 1429 parray nodeAttr 1430 parray arcAttr 1431 parray graphAttr 1432 parray arcWeight 1433 puts ___________________________________ 1434 } 1435 return 1436} 1437 1438# ::struct::graph::_destroy -- 1439# 1440# Destroy a graph, including its associated command and data storage. 1441# 1442# Arguments: 1443# name name of the graph. 1444# 1445# Results: 1446# None. 1447 1448proc ::struct::graph::_destroy {name} { 1449 namespace delete $name 1450 interp alias {} $name {} 1451} 1452 1453# ::struct::graph::__generateUniqueArcName -- 1454# 1455# Generate a unique arc name for the given graph. 1456# 1457# Arguments: 1458# name name of the graph. 1459# 1460# Results: 1461# arc name of a arc guaranteed to not exist in the graph. 1462 1463proc ::struct::graph::__generateUniqueArcName {name} { 1464 variable ${name}::nextUnusedArc 1465 while {[__arc_exists $name "arc${nextUnusedArc}"]} { 1466 incr nextUnusedArc 1467 } 1468 return "arc${nextUnusedArc}" 1469} 1470 1471# ::struct::graph::__generateUniqueNodeName -- 1472# 1473# Generate a unique node name for the given graph. 1474# 1475# Arguments: 1476# name name of the graph. 1477# 1478# Results: 1479# node name of a node guaranteed to not exist in the graph. 1480 1481proc ::struct::graph::__generateUniqueNodeName {name} { 1482 variable ${name}::nextUnusedNode 1483 while {[__node_exists $name "node${nextUnusedNode}"]} { 1484 incr nextUnusedNode 1485 } 1486 return "node${nextUnusedNode}" 1487} 1488 1489# ::struct::graph::_get -- 1490# 1491# Get a keyed value from the graph itself 1492# 1493# Arguments: 1494# name name of the graph. 1495# key key to lookup 1496# 1497# Results: 1498# value value associated with the key given. 1499 1500proc ::struct::graph::_get {name key} { 1501 variable ${name}::graphAttr 1502 if { ![info exists graphAttr($key)] } { 1503 return -code error "invalid key \"$key\" for graph \"$name\"" 1504 } 1505 return $graphAttr($key) 1506} 1507 1508# ::struct::graph::_getall -- 1509# 1510# Get an attribute dictionary from a graph. 1511# 1512# Arguments: 1513# name name of the graph. 1514# pattern optional, glob pattern 1515# 1516# Results: 1517# value value associated with the key given. 1518 1519proc ::struct::graph::_getall {name {pattern *}} { 1520 variable ${name}::graphAttr 1521 return [array get graphAttr $pattern] 1522} 1523 1524# ::struct::graph::_keys -- 1525# 1526# Get a list of keys from a graph. 1527# 1528# Arguments: 1529# name name of the graph. 1530# pattern optional, glob pattern 1531# 1532# Results: 1533# value list of known keys 1534 1535proc ::struct::graph::_keys {name {pattern *}} { 1536 variable ${name}::graphAttr 1537 return [array names graphAttr $pattern] 1538} 1539 1540# ::struct::graph::_keyexists -- 1541# 1542# Test for existence of a given key in a graph. 1543# 1544# Arguments: 1545# name name of the graph. 1546# key key to lookup 1547# 1548# Results: 1549# 1 if the key exists, 0 else. 1550 1551proc ::struct::graph::_keyexists {name key} { 1552 variable ${name}::graphAttr 1553 return [info exists graphAttr($key)] 1554} 1555 1556# ::struct::graph::_node -- 1557# 1558# Dispatches the invocation of node methods to the proper handler 1559# procedure. 1560# 1561# Arguments: 1562# name name of the graph. 1563# cmd node command to invoke 1564# args arguments to propagate to the handler for the node command 1565# 1566# Results: 1567# As of the the invoked handler. 1568 1569proc ::struct::graph::_node {name cmd args} { 1570 # Split the args into command and args components 1571 set sub __node_$cmd 1572 if { [llength [info commands ::struct::graph::$sub]] == 0 } { 1573 set optlist [lsort [info commands ::struct::graph::__node_*]] 1574 set xlist {} 1575 foreach p $optlist { 1576 set p [namespace tail $p] 1577 lappend xlist [string range $p 7 end] 1578 } 1579 set optlist [linsert [join $xlist ", "] "end-1" "or"] 1580 return -code error \ 1581 "bad option \"$cmd\": must be $optlist" 1582 } 1583 uplevel 1 [linsert $args 0 ::struct::graph::$sub $name] 1584} 1585 1586# ::struct::graph::__node_degree -- 1587# 1588# Return the number of arcs adjacent to the specified node. 1589# If one of the restrictions -in or -out is given only 1590# incoming resp. outgoing arcs are counted. 1591# 1592# Arguments: 1593# name name of the graph. 1594# args option, followed by the node. 1595# 1596# Results: 1597# None. 1598 1599proc ::struct::graph::__node_degree {name args} { 1600 1601 if {([llength $args] < 1) || ([llength $args] > 2)} { 1602 return -code error "wrong # args: should be \"$name node degree ?-in|-out? node\"" 1603 } 1604 1605 switch -exact -- [llength $args] { 1606 1 { 1607 set opt {} 1608 set node [lindex $args 0] 1609 } 1610 2 { 1611 set opt [lindex $args 0] 1612 set node [lindex $args 1] 1613 } 1614 default {return -code error "Can't happen, panic"} 1615 } 1616 1617 # Validate the option. 1618 1619 switch -exact -- $opt { 1620 {} - 1621 -in - 1622 -out {} 1623 default { 1624 return -code error "bad option \"$opt\": must be -in or -out" 1625 } 1626 } 1627 1628 # Validate the node 1629 1630 CheckMissingNode $name $node 1631 1632 variable ${name}::inArcs 1633 variable ${name}::outArcs 1634 1635 switch -exact -- $opt { 1636 -in { 1637 set result [llength $inArcs($node)] 1638 } 1639 -out { 1640 set result [llength $outArcs($node)] 1641 } 1642 {} { 1643 set result [expr {[llength $inArcs($node)] \ 1644 + [llength $outArcs($node)]}] 1645 1646 # loops count twice, don't do <set> arithmetics, i.e. no union! 1647 if {0} { 1648 array set coll {} 1649 set result [llength $inArcs($node)] 1650 1651 foreach e $inArcs($node) { 1652 set coll($e) . 1653 } 1654 foreach e $outArcs($node) { 1655 if {[info exists coll($e)]} {continue} 1656 incr result 1657 set coll($e) . 1658 } 1659 } 1660 } 1661 default {return -code error "Can't happen, panic"} 1662 } 1663 1664 return $result 1665} 1666 1667# ::struct::graph::__node_delete -- 1668# 1669# Remove a node from a graph, including all of its values. 1670# Additionally removes the arcs connected to this node. 1671# 1672# Arguments: 1673# name name of the graph. 1674# args list of the nodes to delete. 1675# 1676# Results: 1677# None. 1678 1679proc ::struct::graph::__node_delete {name args} { 1680 if {![llength $args]} { 1681 return {wrong # args: should be "::struct::graph::__node_delete name node node..."} 1682 } 1683 foreach node $args {CheckMissingNode $name $node} 1684 1685 variable ${name}::inArcs 1686 variable ${name}::outArcs 1687 variable ${name}::nodeAttr 1688 1689 foreach node $args { 1690 # Remove all the arcs connected to this node 1691 foreach e $inArcs($node) { 1692 __arc_delete $name $e 1693 } 1694 foreach e $outArcs($node) { 1695 # Check existence to avoid problems with 1696 # loops (they are in and out arcs! at 1697 # the same time and thus already deleted) 1698 if { [__arc_exists $name $e] } { 1699 __arc_delete $name $e 1700 } 1701 } 1702 1703 unset inArcs($node) 1704 unset outArcs($node) 1705 1706 if {[info exists nodeAttr($node)]} { 1707 unset ${name}::$nodeAttr($node) 1708 unset nodeAttr($node) 1709 } 1710 } 1711 1712 return 1713} 1714 1715# ::struct::graph::__node_exists -- 1716# 1717# Test for existence of a given node in a graph. 1718# 1719# Arguments: 1720# name name of the graph. 1721# node node to look for. 1722# 1723# Results: 1724# 1 if the node exists, 0 else. 1725 1726proc ::struct::graph::__node_exists {name node} { 1727 return [info exists ${name}::inArcs($node)] 1728} 1729 1730# ::struct::graph::__node_get -- 1731# 1732# Get a keyed value from a node in a graph. 1733# 1734# Arguments: 1735# name name of the graph. 1736# node node to query. 1737# key key to lookup 1738# 1739# Results: 1740# value value associated with the key given. 1741 1742proc ::struct::graph::__node_get {name node key} { 1743 CheckMissingNode $name $node 1744 1745 variable ${name}::nodeAttr 1746 if {![info exists nodeAttr($node)]} { 1747 # No attribute data for this node, key has to be invalid. 1748 return -code error "invalid key \"$key\" for node \"$node\"" 1749 } 1750 1751 upvar ${name}::$nodeAttr($node) data 1752 if { ![info exists data($key)] } { 1753 return -code error "invalid key \"$key\" for node \"$node\"" 1754 } 1755 return $data($key) 1756} 1757 1758# ::struct::graph::__node_getall -- 1759# 1760# Get a serialized list of key/value pairs from a node in a graph. 1761# 1762# Arguments: 1763# name name of the graph. 1764# node node to query. 1765# pattern optional glob pattern to restrict retrieval 1766# 1767# Results: 1768# value value associated with the key given. 1769 1770proc ::struct::graph::__node_getall {name node {pattern *}} { 1771 CheckMissingNode $name $node 1772 1773 variable ${name}::nodeAttr 1774 if {![info exists nodeAttr($node)]} { 1775 # No attributes ... 1776 return {} 1777 } 1778 1779 upvar ${name}::$nodeAttr($node) data 1780 return [array get data $pattern] 1781} 1782 1783# ::struct::graph::__node_keys -- 1784# 1785# Get a list of keys from a node in a graph. 1786# 1787# Arguments: 1788# name name of the graph. 1789# node node to query. 1790# pattern optional glob pattern to restrict retrieval 1791# 1792# Results: 1793# value value associated with the key given. 1794 1795proc ::struct::graph::__node_keys {name node {pattern *}} { 1796 CheckMissingNode $name $node 1797 1798 variable ${name}::nodeAttr 1799 if {![info exists nodeAttr($node)]} { 1800 # No attributes ... 1801 return {} 1802 } 1803 1804 upvar ${name}::$nodeAttr($node) data 1805 return [array names data $pattern] 1806} 1807 1808# ::struct::graph::__node_keyexists -- 1809# 1810# Test for existence of a given key for a node in a graph. 1811# 1812# Arguments: 1813# name name of the graph. 1814# node node to query. 1815# key key to lookup 1816# 1817# Results: 1818# 1 if the key exists, 0 else. 1819 1820proc ::struct::graph::__node_keyexists {name node key} { 1821 CheckMissingNode $name $node 1822 1823 variable ${name}::nodeAttr 1824 if {![info exists nodeAttr($node)]} { 1825 # No attribute data for this node, key cannot exist. 1826 return 0 1827 } 1828 1829 upvar ${name}::$nodeAttr($node) data 1830 return [info exists data($key)] 1831} 1832 1833# ::struct::graph::__node_insert -- 1834# 1835# Add a node to a graph. 1836# 1837# Arguments: 1838# name name of the graph. 1839# args node to insert; must be unique. If none is given, 1840# the routine will generate a unique node name. 1841# 1842# Results: 1843# node The name of the new node. 1844 1845proc ::struct::graph::__node_insert {name args} { 1846 if {[llength $args] == 0} { 1847 # No node name was given; generate a unique one 1848 set args [list [__generateUniqueNodeName $name]] 1849 } else { 1850 foreach node $args {CheckDuplicateNode $name $node} 1851 } 1852 1853 variable ${name}::inArcs 1854 variable ${name}::outArcs 1855 1856 foreach node $args { 1857 # Set up the new node 1858 set inArcs($node) {} 1859 set outArcs($node) {} 1860 } 1861 1862 return $args 1863} 1864 1865# ::struct::graph::__node_opposite -- 1866# 1867# Retrieve node opposite to the specified one, along the arc. 1868# 1869# Arguments: 1870# name name of the graph. 1871# node node to look up. 1872# arc arc to look up. 1873# 1874# Results: 1875# nodex Node opposite to <node,arc> 1876 1877proc ::struct::graph::__node_opposite {name node arc} { 1878 CheckMissingNode $name $node 1879 CheckMissingArc $name $arc 1880 1881 variable ${name}::arcNodes 1882 1883 # Node must be connected to at least one end of the arc. 1884 1885 if {[string equal $node [lindex $arcNodes($arc) 0]]} { 1886 set result [lindex $arcNodes($arc) 1] 1887 } elseif {[string equal $node [lindex $arcNodes($arc) 1]]} { 1888 set result [lindex $arcNodes($arc) 0] 1889 } else { 1890 return -code error "node \"$node\" and arc \"$arc\" are not connected\ 1891 in graph \"$name\"" 1892 } 1893 1894 return $result 1895} 1896 1897# ::struct::graph::__node_set -- 1898# 1899# Set or get a value for a node in a graph. 1900# 1901# Arguments: 1902# name name of the graph. 1903# node node to modify or query. 1904# key attribute to modify or query 1905# args ?value? 1906# 1907# Results: 1908# val value associated with the given key of the given node 1909 1910proc ::struct::graph::__node_set {name node key args} { 1911 if { [llength $args] > 1 } { 1912 return -code error "wrong # args: should be \"$name node set node key ?value?\"" 1913 } 1914 CheckMissingNode $name $node 1915 1916 if { [llength $args] > 0 } { 1917 # Setting the value. This may have to create 1918 # the attribute array for this particular 1919 # node 1920 1921 variable ${name}::nodeAttr 1922 if {![info exists nodeAttr($node)]} { 1923 # No attribute data for this node, 1924 # so create it as we need it now. 1925 GenAttributeStorage $name node $node 1926 } 1927 upvar ${name}::$nodeAttr($node) data 1928 1929 return [set data($key) [lindex $args end]] 1930 } else { 1931 # Getting a value 1932 return [__node_get $name $node $key] 1933 } 1934} 1935 1936# ::struct::graph::__node_append -- 1937# 1938# Append a value for a node in a graph. 1939# 1940# Arguments: 1941# name name of the graph. 1942# node node to modify or query. 1943# args key value 1944# 1945# Results: 1946# val value associated with the given key of the given node 1947 1948proc ::struct::graph::__node_append {name node key value} { 1949 CheckMissingNode $name $node 1950 1951 variable ${name}::nodeAttr 1952 if {![info exists nodeAttr($node)]} { 1953 # No attribute data for this node, 1954 # so create it as we need it. 1955 GenAttributeStorage $name node $node 1956 } 1957 1958 upvar ${name}::$nodeAttr($node) data 1959 return [append data($key) $value] 1960} 1961 1962# ::struct::graph::__node_attr -- 1963# 1964# Return attribute data for one key and multiple nodes, possibly all. 1965# 1966# Arguments: 1967# name Name of the graph object. 1968# key Name of the attribute to retrieve. 1969# 1970# Results: 1971# children Dictionary mapping nodes to attribute data. 1972 1973proc ::struct::graph::__node_attr {name key args} { 1974 # Syntax: 1975 # 1976 # t attr key 1977 # t attr key -nodes {nodelist} 1978 # t attr key -glob nodepattern 1979 # t attr key -regexp nodepattern 1980 1981 variable ${name}::nodeAttr 1982 1983 set usage "wrong # args: should be \"[list $name] node attr key ?-nodes list|-glob pattern|-regexp pattern?\"" 1984 if {([llength $args] != 0) && ([llength $args] != 2)} { 1985 return -code error $usage 1986 } elseif {[llength $args] == 0} { 1987 # This automatically restricts the list 1988 # to nodes which can have the attribute 1989 # in question. 1990 1991 set nodes [array names nodeAttr] 1992 } else { 1993 # Determine a list of nodes to look at 1994 # based on the chosen restriction. 1995 1996 foreach {mode value} $args break 1997 switch -exact -- $mode { 1998 -nodes { 1999 # This is the only branch where we have to 2000 # perform an explicit restriction to the 2001 # nodes which have attributes. 2002 set nodes {} 2003 foreach n $value { 2004 if {![info exists nodeAttr($n)]} continue 2005 lappend nodes $n 2006 } 2007 } 2008 -glob { 2009 set nodes [array names nodeAttr $value] 2010 } 2011 -regexp { 2012 set nodes {} 2013 foreach n [array names nodeAttr] { 2014 if {![regexp -- $value $n]} continue 2015 lappend nodes $n 2016 } 2017 } 2018 default { 2019 return -code error "bad type \"$mode\": must be -glob, -nodes, or -regexp" 2020 } 2021 } 2022 } 2023 2024 # Without possibly matching nodes 2025 # the result has to be empty. 2026 2027 if {![llength $nodes]} { 2028 return {} 2029 } 2030 2031 # Now locate matching keys and their values. 2032 2033 set result {} 2034 foreach n $nodes { 2035 upvar ${name}::$nodeAttr($n) data 2036 if {[info exists data($key)]} { 2037 lappend result $n $data($key) 2038 } 2039 } 2040 2041 return $result 2042} 2043 2044# ::struct::graph::__node_lappend -- 2045# 2046# lappend a value for a node in a graph. 2047# 2048# Arguments: 2049# name name of the graph. 2050# node node to modify or query. 2051# args key value 2052# 2053# Results: 2054# val value associated with the given key of the given node 2055 2056proc ::struct::graph::__node_lappend {name node key value} { 2057 CheckMissingNode $name $node 2058 2059 variable ${name}::nodeAttr 2060 if {![info exists nodeAttr($node)]} { 2061 # No attribute data for this node, 2062 # so create it as we need it. 2063 GenAttributeStorage $name node $node 2064 } 2065 2066 upvar ${name}::$nodeAttr($node) data 2067 return [lappend data($key) $value] 2068} 2069 2070# ::struct::graph::__node_unset -- 2071# 2072# Remove a keyed value from a node. 2073# 2074# Arguments: 2075# name name of the graph. 2076# node node to modify. 2077# key attribute to remove 2078# 2079# Results: 2080# None. 2081 2082proc ::struct::graph::__node_unset {name node key} { 2083 CheckMissingNode $name $node 2084 2085 variable ${name}::nodeAttr 2086 if {![info exists nodeAttr($node)]} { 2087 # No attribute data for this node, 2088 # nothing to do. 2089 return 2090 } 2091 2092 upvar ${name}::$nodeAttr($node) data 2093 catch {unset data($key)} 2094 2095 if {[array size data] == 0} { 2096 # No attributes stored for this node, squash the whole array. 2097 unset nodeAttr($node) 2098 unset data 2099 } 2100 return 2101} 2102 2103# ::struct::graph::_nodes -- 2104# 2105# Return a list of all nodes in a graph satisfying some restriction. 2106# 2107# Arguments: 2108# name name of the graph. 2109# args list of options and nodes specifying the restriction. 2110# 2111# Results: 2112# nodes list of nodes 2113 2114proc ::struct::graph::_nodes {name args} { 2115 2116 CheckE $name nodes $args 2117 2118 switch -exact -- $cond { 2119 none {set nodes [NodesNONE $name]} 2120 in {set nodes [NodesIN $name $condNodes]} 2121 out {set nodes [NodesOUT $name $condNodes]} 2122 adj {set nodes [NodesADJ $name $condNodes]} 2123 inner {set nodes [NodesINN $name $condNodes]} 2124 embedding {set nodes [NodesEMB $name $condNodes]} 2125 default {return -code error "Can't happen, panic"} 2126 } 2127 2128 # 2129 # We have a list of nodes that match the relation to the nodes. 2130 # Now filter according to -key and -value. 2131 # 2132 2133 if {$haveKey && $haveValue} { 2134 set nodes [NodesKV $name $key $value $nodes] 2135 } elseif {$haveKey} { 2136 set nodes [NodesK $name $key $nodes] 2137 } 2138 2139 # 2140 # Apply the general filter command, if specified. 2141 # 2142 2143 if {$haveFilter} { 2144 lappend fcmd $name 2145 set nodes [uplevel 1 [list ::struct::list filter $nodes $fcmd]] 2146 } 2147 2148 return $nodes 2149} 2150 2151proc ::struct::graph::NodesIN {name cn} { 2152 # nodes -in. 2153 # "Neighbours with arcs going into the node set" 2154 # 2155 # NODES/in (NS) := { source(a) | a in ARC/in (NS) } 2156 2157 # Result is all nodes with at least one arc going to 2158 # at least one node in the list of arguments. 2159 2160 variable ${name}::inArcs 2161 variable ${name}::arcNodes 2162 2163 set nodes {} 2164 array set coll {} 2165 2166 foreach node $cn { 2167 foreach e $inArcs($node) { 2168 set n [lindex $arcNodes($e) 0] 2169 if {[info exists coll($n)]} {continue} 2170 lappend nodes $n 2171 set coll($n) . 2172 } 2173 } 2174 return $nodes 2175} 2176 2177proc ::struct::graph::NodesOUT {name cn} { 2178 # nodes -out. 2179 # "Neighbours with arcs coming from the node set" 2180 # 2181 # NODES/out (NS) := { target(a) | a in ARC/out (NS) } 2182 2183 # Result is all nodes with at least one arc coming from 2184 # at least one node in the list of arguments. 2185 2186 variable ${name}::outArcs 2187 variable ${name}::arcNodes 2188 2189 set nodes {} 2190 array set coll {} 2191 2192 foreach node $cn { 2193 foreach e $outArcs($node) { 2194 set n [lindex $arcNodes($e) 1] 2195 if {[info exists coll($n)]} {continue} 2196 lappend nodes $n 2197 set coll($n) . 2198 } 2199 } 2200 return $nodes 2201} 2202 2203proc ::struct::graph::NodesADJ {name cn} { 2204 # nodes -adj. 2205 # "Neighbours of the node set" 2206 # 2207 # NODES/adj (NS) := NODES/in (NS) + NODES/out (NS) 2208 2209 # Result is all nodes with at least one arc coming from 2210 # or going to at least one node in the list of arguments. 2211 2212 return [struct::set union \ 2213 [NodesIN $name $cn] \ 2214 [NodesOUT $name $cn]] 2215 if 0 { 2216 # Alternate implementation using arrays, 2217 # implementing the set union directly, 2218 # intertwined with the data retrieval. 2219 2220 foreach node $cn { 2221 foreach e $inArcs($node) { 2222 set n [lindex $arcNodes($e) 0] 2223 if {[info exists coll($n)]} {continue} 2224 lappend nodes $n 2225 set coll($n) . 2226 } 2227 foreach e $outArcs($node) { 2228 set n [lindex $arcNodes($e) 1] 2229 if {[info exists coll($n)]} {continue} 2230 lappend nodes $n 2231 set coll($n) . 2232 } 2233 } 2234 } 2235} 2236 2237proc ::struct::graph::NodesINN {name cn} { 2238 # nodes -adj. 2239 # "Inner node of the node set" 2240 # 2241 # NODES/inner (NS) := NODES/adj (NS) * NS 2242 2243 # Result is all nodes from the set with at least one arc coming 2244 # from or going to at least one node in the set. 2245 # 2246 # I.e the adjacent nodes also in the set. 2247 2248 return [struct::set intersect \ 2249 [NodesADJ $name $cn] $cn] 2250 2251 if 0 { 2252 # Alternate implementation using arrays, 2253 # implementing the set intersect/union 2254 # directly, intertwined with the data retrieval. 2255 2256 array set group {} 2257 foreach node $cn { 2258 set group($node) . 2259 } 2260 2261 foreach node $cn { 2262 foreach e $inArcs($node) { 2263 set n [lindex $arcNodes($e) 0] 2264 if {![info exists group($n)]} {continue} 2265 if { [info exists coll($n)]} {continue} 2266 lappend nodes $n 2267 set coll($n) . 2268 } 2269 foreach e $outArcs($node) { 2270 set n [lindex $arcNodes($e) 1] 2271 if {![info exists group($n)]} {continue} 2272 if { [info exists coll($n)]} {continue} 2273 lappend nodes $n 2274 set coll($n) . 2275 } 2276 } 2277 } 2278} 2279 2280proc ::struct::graph::NodesEMB {name cn} { 2281 # nodes -embedding. 2282 # "Embedding nodes for the node set" 2283 # 2284 # NODES/emb (NS) := NODES/adj (NS) - NS 2285 2286 # Result is all nodes with at least one arc coming from or going 2287 # to at least one node in the set, but not in the set itself 2288 # 2289 # I.e the adjacent nodes not in the set. 2290 2291 # Result is all nodes from the set with at least one arc coming 2292 # from or going to at least one node in the set. 2293 # I.e the adjacent nodes still in the set. 2294 2295 return [struct::set difference \ 2296 [NodesADJ $name $cn] $cn] 2297 2298 if 0 { 2299 # Alternate implementation using arrays, 2300 # implementing the set diff/union directly, 2301 # intertwined with the data retrieval. 2302 2303 array set group {} 2304 foreach node $cn { 2305 set group($node) . 2306 } 2307 2308 foreach node $cn { 2309 foreach e $inArcs($node) { 2310 set n [lindex $arcNodes($e) 0] 2311 if {[info exists group($n)]} {continue} 2312 if {[info exists coll($n)]} {continue} 2313 lappend nodes $n 2314 set coll($n) . 2315 } 2316 foreach e $outArcs($node) { 2317 set n [lindex $arcNodes($e) 1] 2318 if {[info exists group($n)]} {continue} 2319 if {[info exists coll($n)]} {continue} 2320 lappend nodes $n 2321 set coll($n) . 2322 } 2323 } 2324 } 2325} 2326 2327proc ::struct::graph::NodesNONE {name} { 2328 variable ${name}::inArcs 2329 return [array names inArcs] 2330} 2331 2332proc ::struct::graph::NodesKV {name key value nodes} { 2333 set filteredNodes {} 2334 foreach node $nodes { 2335 catch { 2336 set nval [__node_get $name $node $key] 2337 if {$nval == $value} { 2338 lappend filteredNodes $node 2339 } 2340 } 2341 } 2342 return $filteredNodes 2343} 2344 2345proc ::struct::graph::NodesK {name key nodes} { 2346 set filteredNodes {} 2347 foreach node $nodes { 2348 catch { 2349 __node_get $name $node $key 2350 lappend filteredNodes $node 2351 } 2352 } 2353 return $filteredNodes 2354} 2355 2356# ::struct::graph::__node_rename -- 2357# 2358# Rename a node in place. 2359# 2360# Arguments: 2361# name name of the graph. 2362# node Name of the node to rename 2363# newname The new name of the node. 2364# 2365# Results: 2366# The new name of the node. 2367 2368proc ::struct::graph::__node_rename {name node newname} { 2369 CheckMissingNode $name $node 2370 CheckDuplicateNode $name $newname 2371 2372 set oldname $node 2373 2374 # Perform the rename in the internal 2375 # data structures. 2376 2377 # - graphAttr - not required, node independent. 2378 # - arcAttr - not required, node independent. 2379 # - counters - not required 2380 2381 variable ${name}::nodeAttr 2382 variable ${name}::inArcs 2383 variable ${name}::outArcs 2384 variable ${name}::arcNodes 2385 2386 # Node relocation 2387 2388 set inArcs($newname) [set in $inArcs($oldname)] 2389 unset inArcs($oldname) 2390 set outArcs($newname) [set out $outArcs($oldname)] 2391 unset outArcs($oldname) 2392 2393 if {[info exists nodeAttr($oldname)]} { 2394 set nodeAttr($newname) $nodeAttr($oldname) 2395 unset nodeAttr($oldname) 2396 } 2397 2398 # Update all relevant arcs. 2399 # 8.4: lset ... 2400 2401 foreach a $in { 2402 set arcNodes($a) [list [lindex $arcNodes($a) 0] $newname] 2403 } 2404 foreach a $out { 2405 set arcNodes($a) [list $newname [lindex $arcNodes($a) 1]] 2406 } 2407 2408 return $newname 2409} 2410 2411# ::struct::graph::_serialize -- 2412# 2413# Serialize a graph object (partially) into a transportable value. 2414# If only a subset of nodes is serialized the result will be a sub- 2415# graph in the mathematical sense of the word: These nodes and all 2416# arcs which are only between these nodes. No arcs to modes outside 2417# of the listed set. 2418# 2419# Arguments: 2420# name Name of the graph. 2421# args list of nodes to place into the serialized graph 2422# 2423# Results: 2424# A list structure describing the part of the graph which was serialized. 2425 2426proc ::struct::graph::_serialize {name args} { 2427 2428 # all - boolean flag - set if and only if the all nodes of the 2429 # graph are chosen for serialization. Because if that is true we 2430 # can skip the step finding the relevant arcs and simply take all 2431 # arcs. 2432 2433 variable ${name}::arcNodes 2434 variable ${name}::arcWeight 2435 variable ${name}::inArcs 2436 2437 set all 0 2438 if {[llength $args] > 0} { 2439 set nodes [luniq $args] 2440 foreach n $nodes {CheckMissingNode $name $n} 2441 if {[llength $nodes] == [array size inArcs]} { 2442 set all 1 2443 } 2444 } else { 2445 set nodes [array names inArcs] 2446 set all 1 2447 } 2448 2449 if {$all} { 2450 set arcs [array names arcNodes] 2451 } else { 2452 set arcs [eval [linsert $nodes 0 _arcs $name -inner]] 2453 } 2454 2455 variable ${name}::nodeAttr 2456 variable ${name}::arcAttr 2457 variable ${name}::graphAttr 2458 2459 set na {} 2460 set aa {} 2461 array set np {} 2462 2463 # node indices, attribute data ... 2464 set i 0 2465 foreach n $nodes { 2466 set np($n) [list $i] 2467 incr i 3 2468 2469 if {[info exists nodeAttr($n)]} { 2470 upvar ${name}::$nodeAttr($n) data 2471 lappend np($n) [array get data] 2472 } else { 2473 lappend np($n) {} 2474 } 2475 } 2476 2477 # arc dictionary 2478 set arcdata {} 2479 foreach a $arcs { 2480 foreach {src dst} $arcNodes($a) break 2481 # Arc information 2482 2483 set arc [list $a] 2484 lappend arc [lindex $np($dst) 0] 2485 if {[info exists arcAttr($a)]} { 2486 upvar ${name}::$arcAttr($a) data 2487 lappend arc [array get data] 2488 } else { 2489 lappend arc {} 2490 } 2491 2492 # Add weight information, if there is any. 2493 2494 if {[info exists arcWeight($a)]} { 2495 lappend arc $arcWeight($a) 2496 } 2497 2498 # Add the information to the node 2499 # indices ... 2500 2501 lappend np($src) $arc 2502 } 2503 2504 # Combine the transient data into one result. 2505 2506 set result [list] 2507 foreach n $nodes { 2508 lappend result $n 2509 lappend result [lindex $np($n) 1] 2510 lappend result [lrange $np($n) 2 end] 2511 } 2512 lappend result [array get graphAttr] 2513 2514 return $result 2515} 2516 2517# ::struct::graph::_set -- 2518# 2519# Set or get a keyed value from the graph itself 2520# 2521# Arguments: 2522# name name of the graph. 2523# key attribute to modify or query 2524# args ?value? 2525# 2526# Results: 2527# value value associated with the key given. 2528 2529proc ::struct::graph::_set {name key args} { 2530 if { [llength $args] > 1 } { 2531 return -code error "wrong # args: should be \"$name set key ?value?\"" 2532 } 2533 if { [llength $args] > 0 } { 2534 variable ${name}::graphAttr 2535 return [set graphAttr($key) [lindex $args end]] 2536 } else { 2537 # Getting a value 2538 return [_get $name $key] 2539 } 2540} 2541 2542# ::struct::graph::_swap -- 2543# 2544# Swap two nodes in a graph. 2545# 2546# Arguments: 2547# name name of the graph. 2548# node1 first node to swap. 2549# node2 second node to swap. 2550# 2551# Results: 2552# None. 2553 2554proc ::struct::graph::_swap {name node1 node2} { 2555 # Can only swap two real nodes 2556 CheckMissingNode $name $node1 2557 CheckMissingNode $name $node2 2558 2559 # Can't swap a node with itself 2560 if { [string equal $node1 $node2] } { 2561 return -code error "cannot swap node \"$node1\" with itself" 2562 } 2563 2564 # Swapping nodes means swapping their labels, values and arcs 2565 variable ${name}::outArcs 2566 variable ${name}::inArcs 2567 variable ${name}::arcNodes 2568 variable ${name}::nodeAttr 2569 2570 # Redirect arcs to the new nodes. 2571 2572 foreach e $inArcs($node1) {lset arcNodes($e) end $node2} 2573 foreach e $inArcs($node2) {lset arcNodes($e) end $node1} 2574 foreach e $outArcs($node1) {lset arcNodes($e) 0 $node2} 2575 foreach e $outArcs($node2) {lset arcNodes($e) 0 $node1} 2576 2577 # Swap arc lists 2578 2579 set tmp $inArcs($node1) 2580 set inArcs($node1) $inArcs($node2) 2581 set inArcs($node2) $tmp 2582 2583 set tmp $outArcs($node1) 2584 set outArcs($node1) $outArcs($node2) 2585 set outArcs($node2) $tmp 2586 2587 # Swap the values 2588 # More complicated now with the possibility that nodes do not have 2589 # attribute storage associated with them. But also 2590 # simpler as we just have to swap/move the array 2591 # reference 2592 2593 if { 2594 [set ia [info exists nodeAttr($node1)]] || 2595 [set ib [info exists nodeAttr($node2)]] 2596 } { 2597 # At least one of the nodes has attribute data. We simply swap 2598 # the references to the arrays containing them. No need to 2599 # copy the actual data around. 2600 2601 if {$ia && $ib} { 2602 set tmp $nodeAttr($node1) 2603 set nodeAttr($node1) $nodeAttr($node2) 2604 set nodeAttr($node2) $tmp 2605 } elseif {$ia} { 2606 set nodeAttr($node2) $nodeAttr($node1) 2607 unset nodeAttr($node1) 2608 } elseif {$ib} { 2609 set nodeAttr($node1) $nodeAttr($node2) 2610 unset nodeAttr($node2) 2611 } else { 2612 return -code error "Impossible condition." 2613 } 2614 } ; # else: No attribute storage => Nothing to do {} 2615 2616 return 2617} 2618 2619# ::struct::graph::_unset -- 2620# 2621# Remove a keyed value from the graph itself 2622# 2623# Arguments: 2624# name name of the graph. 2625# key attribute to remove 2626# 2627# Results: 2628# None. 2629 2630proc ::struct::graph::_unset {name key} { 2631 variable ${name}::graphAttr 2632 if {[info exists graphAttr($key)]} { 2633 unset graphAttr($key) 2634 } 2635 return 2636} 2637 2638# ::struct::graph::_walk -- 2639# 2640# Walk a graph using a pre-order depth or breadth first 2641# search. Pre-order DFS is the default. At each node that is visited, 2642# a command will be called with the name of the graph and the node. 2643# 2644# Arguments: 2645# name name of the graph. 2646# node node at which to start. 2647# args additional args: ?-order pre|post|both? ?-type {bfs|dfs}? 2648# -command cmd 2649# 2650# Results: 2651# None. 2652 2653proc ::struct::graph::_walk {name node args} { 2654 set usage "$name walk node ?-dir forward|backward?\ 2655 ?-order pre|post|both? ?-type bfs|dfs? -command cmd" 2656 2657 if {[llength $args] < 2} { 2658 return -code error "wrong # args: should be \"$usage\"" 2659 } 2660 2661 CheckMissingNode $name $node 2662 2663 # Set defaults 2664 set type dfs 2665 set order pre 2666 set cmd "" 2667 set dir forward 2668 2669 # Process specified options 2670 for {set i 0} {$i < [llength $args]} {incr i} { 2671 set flag [lindex $args $i] 2672 switch -glob -- $flag { 2673 "-type" { 2674 incr i 2675 if { $i >= [llength $args] } { 2676 return -code error "value for \"$flag\" missing: should be \"$usage\"" 2677 } 2678 set type [string tolower [lindex $args $i]] 2679 } 2680 "-order" { 2681 incr i 2682 if { $i >= [llength $args] } { 2683 return -code error "value for \"$flag\" missing: should be \"$usage\"" 2684 } 2685 set order [string tolower [lindex $args $i]] 2686 } 2687 "-command" { 2688 incr i 2689 if { $i >= [llength $args] } { 2690 return -code error "value for \"$flag\" missing: should be \"$usage\"" 2691 } 2692 set cmd [lindex $args $i] 2693 } 2694 "-dir" { 2695 incr i 2696 if { $i >= [llength $args] } { 2697 return -code error "value for \"$flag\" missing: should be \"$usage\"" 2698 } 2699 set dir [string tolower [lindex $args $i]] 2700 } 2701 default { 2702 return -code error "unknown option \"$flag\": should be \"$usage\"" 2703 } 2704 } 2705 } 2706 2707 # Make sure we have a command to run, otherwise what's the point? 2708 if { [string equal $cmd ""] } { 2709 return -code error "no command specified: should be \"$usage\"" 2710 } 2711 2712 # Validate that the given type is good 2713 switch -glob -- $type { 2714 "dfs" { 2715 set type "dfs" 2716 } 2717 "bfs" { 2718 set type "bfs" 2719 } 2720 default { 2721 return -code error "bad search type \"$type\": must be bfs or dfs" 2722 } 2723 } 2724 2725 # Validate that the given order is good 2726 switch -glob -- $order { 2727 "both" { 2728 set order both 2729 } 2730 "pre" { 2731 set order pre 2732 } 2733 "post" { 2734 set order post 2735 } 2736 default { 2737 return -code error "bad search order \"$order\": must be both,\ 2738 pre, or post" 2739 } 2740 } 2741 2742 # Validate that the given direction is good 2743 switch -glob -- $dir { 2744 "forward" { 2745 set dir -out 2746 } 2747 "backward" { 2748 set dir -in 2749 } 2750 default { 2751 return -code error "bad search direction \"$dir\": must be\ 2752 backward or forward" 2753 } 2754 } 2755 2756 # Do the walk 2757 2758 set st [list ] 2759 lappend st $node 2760 array set visited {} 2761 2762 if { [string equal $type "dfs"] } { 2763 if { [string equal $order "pre"] } { 2764 # Pre-order Depth-first search 2765 2766 while { [llength $st] > 0 } { 2767 set node [lindex $st end] 2768 ldelete st end 2769 2770 # Skip all nodes already visited via some other path 2771 # through the graph. 2772 if {[info exists visited($node)]} continue 2773 2774 # Evaluate the command at this node 2775 set cmdcpy $cmd 2776 lappend cmdcpy enter $name $node 2777 uplevel 1 $cmdcpy 2778 2779 set visited($node) . 2780 2781 # Add this node's neighbours (according to direction) 2782 # Have to add them in reverse order 2783 # so that they will be popped left-to-right 2784 2785 set next [_nodes $name $dir $node] 2786 set len [llength $next] 2787 2788 for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { 2789 set nextnode [lindex $next $i] 2790 if {[info exists visited($nextnode)]} { 2791 # Skip nodes already visited 2792 continue 2793 } 2794 lappend st $nextnode 2795 } 2796 } 2797 } elseif { [string equal $order "post"] } { 2798 # Post-order Depth-first search 2799 2800 while { [llength $st] > 0 } { 2801 set node [lindex $st end] 2802 2803 if {[info exists visited($node)]} { 2804 # Second time we are here, pop it, 2805 # then evaluate the command. 2806 2807 ldelete st end 2808 # Bug 2420330. Note: The visited node may be 2809 # multiple times on the stack (neighbour of more 2810 # than one node). Remove all occurences. 2811 while {[set index [lsearch -exact $st $node]] != -1} { 2812 set st [lreplace $st $index $index] 2813 } 2814 2815 # Evaluate the command at this node 2816 set cmdcpy $cmd 2817 lappend cmdcpy leave $name $node 2818 uplevel 1 $cmdcpy 2819 } else { 2820 # First visit. Remember it. 2821 set visited($node) . 2822 2823 # Add this node's neighbours. 2824 set next [_nodes $name $dir $node] 2825 set len [llength $next] 2826 2827 for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { 2828 set nextnode [lindex $next $i] 2829 if {[info exists visited($nextnode)]} { 2830 # Skip nodes already visited 2831 continue 2832 } 2833 lappend st $nextnode 2834 } 2835 } 2836 } 2837 } else { 2838 # Both-order Depth-first search 2839 2840 while { [llength $st] > 0 } { 2841 set node [lindex $st end] 2842 2843 if {[info exists visited($node)]} { 2844 # Second time we are here, pop it, 2845 # then evaluate the command. 2846 2847 ldelete st end 2848 2849 # Evaluate the command at this node 2850 set cmdcpy $cmd 2851 lappend cmdcpy leave $name $node 2852 uplevel 1 $cmdcpy 2853 } else { 2854 # First visit. Remember it. 2855 set visited($node) . 2856 2857 # Evaluate the command at this node 2858 set cmdcpy $cmd 2859 lappend cmdcpy enter $name $node 2860 uplevel 1 $cmdcpy 2861 2862 # Add this node's neighbours. 2863 set next [_nodes $name $dir $node] 2864 set len [llength $next] 2865 2866 for {set i [expr {$len - 1}]} {$i >= 0} {incr i -1} { 2867 set nextnode [lindex $next $i] 2868 if {[info exists visited($nextnode)]} { 2869 # Skip nodes already visited 2870 continue 2871 } 2872 lappend st $nextnode 2873 } 2874 } 2875 } 2876 } 2877 2878 } else { 2879 if { [string equal $order "pre"] } { 2880 # Pre-order Breadth first search 2881 while { [llength $st] > 0 } { 2882 set node [lindex $st 0] 2883 ldelete st 0 2884 # Evaluate the command at this node 2885 set cmdcpy $cmd 2886 lappend cmdcpy enter $name $node 2887 uplevel 1 $cmdcpy 2888 2889 set visited($node) . 2890 2891 # Add this node's neighbours. 2892 foreach child [_nodes $name $dir $node] { 2893 if {[info exists visited($child)]} { 2894 # Skip nodes already visited 2895 continue 2896 } 2897 lappend st $child 2898 } 2899 } 2900 } else { 2901 # Post-order Breadth first search 2902 # Both-order Breadth first search 2903 # Haven't found anything in Knuth 2904 # and unable to define something 2905 # consistent for myself. Leave it 2906 # out. 2907 2908 return -code error "unable to do a ${order}-order breadth first walk" 2909 } 2910 } 2911 return 2912} 2913 2914# ::struct::graph::Union -- 2915# 2916# Return a list which is the union of the elements 2917# in the specified lists. 2918# 2919# Arguments: 2920# args list of lists representing sets. 2921# 2922# Results: 2923# set list representing the union of the argument lists. 2924 2925proc ::struct::graph::Union {args} { 2926 switch -- [llength $args] { 2927 0 { 2928 return {} 2929 } 2930 1 { 2931 return [lindex $args 0] 2932 } 2933 default { 2934 foreach set $args { 2935 foreach e $set { 2936 set tmp($e) . 2937 } 2938 } 2939 return [array names tmp] 2940 } 2941 } 2942} 2943 2944# ::struct::graph::GenAttributeStorage -- 2945# 2946# Create an array to store the attributes of a node in. 2947# 2948# Arguments: 2949# name Name of the graph containing the node 2950# type Type of object for the attribute 2951# obj Name of the node or arc which got attributes. 2952# 2953# Results: 2954# none 2955 2956proc ::struct::graph::GenAttributeStorage {name type obj} { 2957 variable ${name}::nextAttr 2958 upvar ${name}::${type}Attr attribute 2959 2960 set attr "a[incr nextAttr]" 2961 set attribute($obj) $attr 2962 return 2963} 2964 2965proc ::struct::graph::CheckMissingArc {name arc} { 2966 if {![__arc_exists $name $arc]} { 2967 return -code error "arc \"$arc\" does not exist in graph \"$name\"" 2968 } 2969} 2970 2971proc ::struct::graph::CheckMissingNode {name node {prefix {}}} { 2972 if {![__node_exists $name $node]} { 2973 return -code error "${prefix}node \"$node\" does not exist in graph \"$name\"" 2974 } 2975} 2976 2977proc ::struct::graph::CheckDuplicateArc {name arc} { 2978 if {[__arc_exists $name $arc]} { 2979 return -code error "arc \"$arc\" already exists in graph \"$name\"" 2980 } 2981} 2982 2983proc ::struct::graph::CheckDuplicateNode {name node} { 2984 if {[__node_exists $name $node]} { 2985 return -code error "node \"$node\" already exists in graph \"$name\"" 2986 } 2987} 2988 2989proc ::struct::graph::CheckE {name what arguments} { 2990 2991 # Discriminate between conditions and nodes 2992 2993 upvar 1 haveCond haveCond ; set haveCond 0 2994 upvar 1 haveKey haveKey ; set haveKey 0 2995 upvar 1 key key ; set key {} 2996 upvar 1 haveValue haveValue ; set haveValue 0 2997 upvar 1 value value ; set value {} 2998 upvar 1 haveFilter haveFilter ; set haveFilter 0 2999 upvar 1 fcmd fcmd ; set fcmd {} 3000 upvar 1 cond cond ; set cond "none" 3001 upvar 1 condNodes condNodes ; set condNodes {} 3002 3003 set wa_usage "wrong # args: should be \"$name $what ?-key key? ?-value value? ?-filter cmd? ?-in|-out|-adj|-inner|-embedding node node...?\"" 3004 3005 for {set i 0} {$i < [llength $arguments]} {incr i} { 3006 set arg [lindex $arguments $i] 3007 switch -glob -- $arg { 3008 -in - 3009 -out - 3010 -adj - 3011 -inner - 3012 -embedding { 3013 if {$haveCond} { 3014 return -code error "invalid restriction:\ 3015 illegal multiple use of\ 3016 \"-in\"|\"-out\"|\"-adj\"|\"-inner\"|\"-embedding\"" 3017 } 3018 3019 set haveCond 1 3020 set cond [string range $arg 1 end] 3021 } 3022 -key { 3023 if {($i + 1) == [llength $arguments]} { 3024 return -code error $wa_usage 3025 } 3026 if {$haveKey} { 3027 return -code error {invalid restriction: illegal multiple use of "-key"} 3028 } 3029 3030 incr i 3031 set key [lindex $arguments $i] 3032 set haveKey 1 3033 } 3034 -value { 3035 if {($i + 1) == [llength $arguments]} { 3036 return -code error $wa_usage 3037 } 3038 if {$haveValue} { 3039 return -code error {invalid restriction: illegal multiple use of "-value"} 3040 } 3041 3042 incr i 3043 set value [lindex $arguments $i] 3044 set haveValue 1 3045 } 3046 -filter { 3047 if {($i + 1) == [llength $arguments]} { 3048 return -code error $wa_usage 3049 } 3050 if {$haveFilter} { 3051 return -code error {invalid restriction: illegal multiple use of "-filter"} 3052 } 3053 3054 incr i 3055 set fcmd [lindex $arguments $i] 3056 set haveFilter 1 3057 } 3058 -* { 3059 return -code error "bad restriction \"$arg\": must be -adj, -embedding,\ 3060 -filter, -in, -inner, -key, -out, or -value" 3061 } 3062 default { 3063 lappend condNodes $arg 3064 } 3065 } 3066 } 3067 3068 # Validate that there are nodes to use in the restriction. 3069 # otherwise what's the point? 3070 if {$haveCond} { 3071 if {[llength $condNodes] == 0} { 3072 return -code error $wa_usage 3073 } 3074 3075 # Remove duplicates. Note: lsort -unique is not present in Tcl 3076 # 8.2, thus not usable here. 3077 3078 array set nx {} 3079 foreach c $condNodes {set nx($c) .} 3080 set condNodes [array names nx] 3081 unset nx 3082 3083 # Make sure that the specified nodes exist! 3084 foreach node $condNodes {CheckMissingNode $name $node} 3085 } 3086 3087 if {$haveValue && !$haveKey} { 3088 return -code error {invalid restriction: use of "-value" without "-key"} 3089 } 3090 3091 return 3092} 3093 3094proc ::struct::graph::CheckSerialization {ser gavar navar aavar inavar outavar arcnvar arcwvar} { 3095 upvar 1 \ 3096 $gavar graphAttr \ 3097 $navar nodeAttr \ 3098 $aavar arcAttr \ 3099 $inavar inArcs \ 3100 $outavar outArcs \ 3101 $arcnvar arcNodes \ 3102 $arcwvar arcWeight 3103 3104 array set nodeAttr {} 3105 array set arcAttr {} 3106 array set inArcs {} 3107 array set outArcs {} 3108 array set arcNodes {} 3109 array set arcWeight {} 3110 3111 # Overall length ok ? 3112 if {[llength $ser] % 3 != 1} { 3113 return -code error \ 3114 "error in serialization: list length not 1 mod 3." 3115 } 3116 3117 # Attribute length ok ? Dictionary! 3118 set graphAttr [lindex $ser end] 3119 if {[llength $graphAttr] % 2} { 3120 return -code error \ 3121 "error in serialization: malformed graph attribute dictionary." 3122 } 3123 3124 # Basic decoder pass 3125 3126 foreach {node attr narcs} [lrange $ser 0 end-1] { 3127 if {![info exists inArcs($node)]} { 3128 set inArcs($node) [list] 3129 } 3130 set outArcs($node) [list] 3131 3132 # Attribute length ok ? Dictionary! 3133 if {[llength $attr] % 2} { 3134 return -code error \ 3135 "error in serialization: malformed node attribute dictionary." 3136 } 3137 # Remember attribute data only for non-empty nodes 3138 if {[llength $attr]} { 3139 set nodeAttr($node) $attr 3140 } 3141 3142 foreach arcd $narcs { 3143 if { 3144 ([llength $arcd] != 3) && 3145 ([llength $arcd] != 4) 3146 } { 3147 return -code error \ 3148 "error in serialization: arc information length not 3 or 4." 3149 } 3150 3151 foreach {arc dst aattr} $arcd break 3152 3153 if {[info exists arcNodes($arc)]} { 3154 return -code error \ 3155 "error in serialization: duplicate definition of arc \"$arc\"." 3156 } 3157 3158 # Attribute length ok ? Dictionary! 3159 if {[llength $aattr] % 2} { 3160 return -code error \ 3161 "error in serialization: malformed arc attribute dictionary." 3162 } 3163 # Remember attribute data only for non-empty nodes 3164 if {[llength $aattr]} { 3165 set arcAttr($arc) $aattr 3166 } 3167 3168 # Remember weight data if it was specified. 3169 if {[llength $arcd] == 4} { 3170 set arcWeight($arc) [lindex $arcd 3] 3171 } 3172 3173 # Destination reference ok ? 3174 if { 3175 ![string is integer -strict $dst] || 3176 ($dst % 3) || 3177 ($dst < 0) || 3178 ($dst >= [llength $ser]) 3179 } { 3180 return -code error \ 3181 "error in serialization: bad arc destination reference \"$dst\"." 3182 } 3183 3184 # Get destination and reconstruct the 3185 # various relationships. 3186 3187 set dstnode [lindex $ser $dst] 3188 3189 set arcNodes($arc) [list $node $dstnode] 3190 lappend inArcs($dstnode) $arc 3191 lappend outArcs($node) $arc 3192 } 3193 } 3194 3195 # Duplicate node names ? 3196 3197 if {[array size outArcs] < ([llength $ser] / 3)} { 3198 return -code error \ 3199 "error in serialization: duplicate node names." 3200 } 3201 3202 # Ok. The data is now ready for the caller. 3203 return 3204} 3205 3206########################## 3207# Private functions follow 3208# 3209# Do a compatibility version of [lset] for pre-8.4 versions of Tcl. 3210# This version does not do multi-arg [lset]! 3211 3212proc ::struct::graph::K { x y } { set x } 3213 3214if { [package vcompare [package provide Tcl] 8.4] < 0 } { 3215 proc ::struct::graph::lset { var index arg } { 3216 upvar 1 $var list 3217 set list [::lreplace [K $list [set list {}]] $index $index $arg] 3218 } 3219} 3220 3221proc ::struct::graph::ldelete {var index {end {}}} { 3222 upvar 1 $var list 3223 if {$end == {}} {set end $index} 3224 set list [lreplace [K $list [set list {}]] $index $end] 3225 return 3226} 3227 3228proc ::struct::graph::luniq {list} { 3229 array set _ {} 3230 set result [list] 3231 foreach e $list { 3232 if {[info exists _($e)]} {continue} 3233 lappend result $e 3234 set _($e) . 3235 } 3236 return $result 3237} 3238 3239# ### ### ### ######### ######### ######### 3240## Ready 3241 3242namespace eval ::struct { 3243 # Put 'graph::graph' into the general structure namespace 3244 # for pickup by the main management. 3245 3246 namespace import -force graph::graph_tcl 3247} 3248 3249