1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
|
# -*- tcl -*-
# graph.testsupport: Helper commands for the testsuite.
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net>
#
# All rights reserved.
#
# RCS: @(#) $Id: Xsupport,v 1.1 2006/11/16 06:33:13 andreas_kupries Exp $
# -------------------------------------------------------------------------
# Validate a serialization against the graph it was generated from.
proc validate_serial {g serial {nodes {}}} {
# Need a list with length a multiple of 3, plus one.
if {[llength $serial] % 3 != 1} {
return serial/wrong#elements
}
set gattr [lindex $serial end]
if {[llength $gattr] % 2} {
return attr/graph/wrong#elements
}
if {![string equal \
[dictsort $gattr] \
[dictsort [$g getall]]]} {
return attr/graph/data-mismatch
}
# Check node attrs and arcs information
array set an {}
array set ne {}
foreach {node attr arcs} [lrange $serial 0 end-1] {
# Must not list nodes outside of origin
if {![$g node exists $node]} {
return node/$node/unknown
}
# Node structure correct ?
if {[llength $attr] % 2} {
return node/$node/attr/wrong#elements
}
# Node attribues matching ?
if {![string equal \
[dictsort $attr] \
[dictsort [$g node getall $node]]]} {
return node/$node/attr/data-mismatch
}
# Remember nodes for reverse check.
set ne($node) .
# Go through the attached arcs.
foreach a $arcs {
# Structure correct ?
if {[llength $a] != 3} {
return node/$node/arc/wrong#elements
}
# Decode structure
foreach {arc dst aattr} $a break
# Already handled ?
if {[info exists an($arc)]} {
return arc/$arc/duplicate-definition
}
# Must not list arc outside of origin
if {![$g arc exists $arc]} {
return arc/$arc/unknown
}
# Attribute structure correct ?
if {[llength $aattr] % 2} {
return arc/$arc/attr/wrong#elements
}
# Attribute data correct ?
if {![string equal \
[dictsort $aattr] \
[dictsort [$g arc getall $arc]]]} {
return arc/$arc/attr/data-mismatch
}
# Arc information, node reference ok ?
if {![string is integer -strict $dst]} {
return arc/$arc/dst/not-an-integer
}
if {$dst < 0} {
return arc/$arc/dst/out-of-bounds
}
if {$dst >= [llength $serial]} {
return arc/$arc/dts/out-of-bounds
}
# Arc information matching origin ?
if {![string equal $node [$g arc source $arc]]} {
return arc/$arc/src/mismatch/$node/[$g arc source $arc]
}
if {![string equal [lindex $serial $dst] [$g arc target $arc]]} {
return arc/$arc/dst/mismatch/$node/[$g arc target $arc]
}
# Remember for check for multiples
set an($arc) .
}
}
# Nodes ... All must exist in graph ...
# ... Spanning nodes have to be in serialization
if {[llength $nodes] == 0} {
set nodes [lsort [$g nodes]]
} else {
set nodes [lsort $nodes]
}
# Reverse check ...
if {[array size ne] != [llength $nodes]} {
return nodes/mismatch/#nodes
}
if {![string equal [lsort [array names ne]] $nodes]} {
return nodes/mismatch/data
}
# Arcs ... All must exist in graph ...
# ... src / dst has to exist, has to match data in graph.
# ... All arcs between nodes in 'n' have to be in 'a'
foreach k [$g arcs] {
set s [$g arc source $k]
set e [$g arc target $k]
if {[info exists ne($s)] && [info exists ne($e)] && ![info exists an($k)]} {
return arc/$k/missing/should-have-been-listed
}
}
return ok
}
#----------------------------------------------------------------------
proc SETUP {{g mygraph}} {
catch {$g destroy}
graph $g
}
#----------------------------------------------------------------------
proc SETUPx {} {
SETUP
mygraph node insert %0 %1 %2 %3 %4 %5
mygraph node set %0 volume 30
mygraph node set %5 volume 50
mygraph arc insert %0 %1 0 ; mygraph arc set 0 volume 30
mygraph arc insert %0 %2 1
mygraph arc insert %0 %3 2
mygraph arc insert %3 %4 3
mygraph arc insert %4 %5 4
mygraph arc insert %5 %3 5 ; mygraph arc set 5 volume 50
}
#----------------------------------------------------------------------
proc SETUPwalk {} {
SETUP
mygraph node insert i ii iii iv v vi vii viii ix
mygraph arc insert i ii 1
mygraph arc insert ii iii 2
mygraph arc insert ii iii 3
mygraph arc insert ii iii 4
mygraph arc insert iii iv 5
mygraph arc insert iii iv 6
mygraph arc insert iv v 7
mygraph arc insert v vi 8
mygraph arc insert vi viii 9
mygraph arc insert viii i 10
mygraph arc insert i ix 11
mygraph arc insert ix ix 12
mygraph arc insert i vii 13
mygraph arc insert vii vi 14
}
#----------------------------------------------------------------------
# Generators for various error messages generated
# by the implementations.
proc MissingArc {g a} {return "arc \"$a\" does not exist in graph \"$g\""}
proc MissingNode {g n} {return "node \"$n\" does not exist in graph \"$g\""}
proc ExistingArc {g a} {return "arc \"$a\" already exists in graph \"$g\""}
proc ExistingNode {g n} {return "node \"$n\" already exists in graph \"$g\""}
proc MissingKey {e type k} {return "invalid key \"$k\" for $type \"$e\""}
# Fake for graph attribute tests
proc MissingGraph {args} {return {Bogus missing}}
#----------------------------------------------------------------------
|
