source: tol/tolsh/tolsh.vfs/lib/tcllib1.10/struct/graph1.tcl

devel
Last change on this file was 8597867d, checked in by Jorge Pérez <josp.jorge@…>, 16 years ago

closes #976, se incluye tcllib1.10, base64 debe eliminarse del raiz de lib ya que esta incluido en tcllib

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