line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Graph::ModularDecomposition; |
2
|
|
|
|
|
|
|
|
3
|
18
|
|
|
18
|
|
83359
|
use 5.006; |
|
18
|
|
|
|
|
45
|
|
4
|
18
|
|
|
18
|
|
77
|
use strict; |
|
18
|
|
|
|
|
25
|
|
|
18
|
|
|
|
|
378
|
|
5
|
18
|
|
|
18
|
|
61
|
use warnings; |
|
18
|
|
|
|
|
32
|
|
|
18
|
|
|
|
|
968
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
=head1 NAME |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
Graph::ModularDecomposition - Modular decomposition of directed graphs |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
=cut |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
require Exporter; |
14
|
|
|
|
|
|
|
our $VERSION = '0.15'; |
15
|
|
|
|
|
|
|
|
16
|
18
|
|
|
18
|
|
11030
|
use Graph 0.20105; |
|
18
|
|
|
|
|
1634260
|
|
|
18
|
|
|
|
|
1874
|
|
17
|
|
|
|
|
|
|
require Graph::Directed; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
# NB! Exporter must come before Graph::Directed in @ISA |
20
|
|
|
|
|
|
|
our @ISA = qw(Exporter Graph::Directed); |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
# This allows declaration use Graph::ModularDecomposition ':all'; |
23
|
|
|
|
|
|
|
# may want tree_to_string, should move into own Tree::... module some day |
24
|
|
|
|
|
|
|
# other exports are most likely for internal use only |
25
|
|
|
|
|
|
|
# all other functions should be accessed as methods |
26
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( 'all' => [ qw( |
27
|
|
|
|
|
|
|
setminus |
28
|
|
|
|
|
|
|
setunion |
29
|
|
|
|
|
|
|
pairstring_to_graph |
30
|
|
|
|
|
|
|
partition_to_string |
31
|
|
|
|
|
|
|
tree_to_string |
32
|
|
|
|
|
|
|
) ] ); |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
our @EXPORT = qw( |
37
|
|
|
|
|
|
|
); |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
=head1 SYNOPSIS |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
use Graph::ModularDecomposition qw(pairstring_to_graph tree_to_string); |
42
|
|
|
|
|
|
|
my $g = new Graph::ModularDecomposition; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
my $h = $g->pairstring_to_graph( 'ab,ac,bc' ); |
45
|
|
|
|
|
|
|
print "yes\n" if check_transitive( $h ); |
46
|
|
|
|
|
|
|
print "yes\n" if $h->check_transitive; # same thing |
47
|
|
|
|
|
|
|
my $m = $h->modular_decomposition_EGMS; |
48
|
|
|
|
|
|
|
print tree_to_string( $m ); |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
=head1 DESCRIPTION |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
This module extends L by providing |
54
|
|
|
|
|
|
|
new methods related to modular decomposition. |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
The most important new method is modular_decomposition_EGMS(), which |
57
|
|
|
|
|
|
|
for a directed graph with n vertices finds the modular decomposition |
58
|
|
|
|
|
|
|
tree of the graph in O(n^2) time. Method tree_to_string() may be |
59
|
|
|
|
|
|
|
useful to represent the decomposition tree in a friendlier format; |
60
|
|
|
|
|
|
|
this needs to be explicitly imported. |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
If you need to decompose an undirected graph, represent it as a |
63
|
|
|
|
|
|
|
directed graph by adding two directed edges for each undirected edge. |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
The method classify() uses the modular decomposition tree to classify |
66
|
|
|
|
|
|
|
a directed graph as non-transitive, or for transitive digraphs, |
67
|
|
|
|
|
|
|
as series-parallel (linear or parallel modules only), decomposable |
68
|
|
|
|
|
|
|
(not series-parallel, but with at least one non-primitive module), |
69
|
|
|
|
|
|
|
indecomposable (primitive), decomposable but consisting of primitive |
70
|
|
|
|
|
|
|
or series modules only (only applies to graphs of at least 7 vertices), |
71
|
|
|
|
|
|
|
or unclassified (should never apply). |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
=head2 RELATED WORK |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
Several graph algorithms use the modular decomposition tree as a |
76
|
|
|
|
|
|
|
building block. A simple example application of these routines is |
77
|
|
|
|
|
|
|
to construct and search the modular decomposition tree of a directed |
78
|
|
|
|
|
|
|
graph to determine if it is node-series-parallel. |
79
|
|
|
|
|
|
|
Checking if a digraph is series-parallel can also be determined using |
80
|
|
|
|
|
|
|
the O(m+n) Valdes-Tarjan-Lawler algorithm published in 1982, but this |
81
|
|
|
|
|
|
|
only constructs a decomposition tree if the input is series-parallel: |
82
|
|
|
|
|
|
|
other inputs are simply classified as non-series-parallel. |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
The code here is based on algorithm 6.1 for modular decomposition of |
85
|
|
|
|
|
|
|
two-structures, from |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
A. Ehrenfeucht, H. N. Gabow, R. M. McConnell, and S. J. Sullivan, "An |
88
|
|
|
|
|
|
|
O(n^2) Divide-and-Conquer Algorithm for the Prime Tree Decomposition |
89
|
|
|
|
|
|
|
of Two-Structures and Modular Decomposition of Graphs", Journal of |
90
|
|
|
|
|
|
|
Algorithms 16 (1994), pp. 283-294. doi:10.1006/jagm.1994.1013 |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
I am not aware of any other publicly available implementations. |
93
|
|
|
|
|
|
|
Any errors and omissions are of course my fault. Better algorithms |
94
|
|
|
|
|
|
|
are known: O(m+n) run-time can be achieved using sophisticated data |
95
|
|
|
|
|
|
|
structures (where m is the number of edges in the graph), see |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
R. M. McConnell and F. de Montgolfier, "Linear-time modular |
98
|
|
|
|
|
|
|
decomposition of directed graphs", Discrete Applied Mathematics |
99
|
|
|
|
|
|
|
145 (2005), pp. 198-209. doi:10.1016/j.dam.2004.02.017 |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=head2 EXPORT |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
None by default. Methods tree_to_string() and partition_to_string() |
105
|
|
|
|
|
|
|
can be imported. Methods setminus() and setunion() are for internal |
106
|
|
|
|
|
|
|
use but can also be imported. |
107
|
|
|
|
|
|
|
|
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
=head2 METHODS |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
=over 4 |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
=item debug() |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
my $g = new Graph::ModularDecomposition; |
116
|
|
|
|
|
|
|
Graph::ModularDecomposition->debug(1); # turn on debugging |
117
|
|
|
|
|
|
|
Graph::ModularDecomposition->debug(2); # extra debugging |
118
|
|
|
|
|
|
|
$g->debug(2); # same thing |
119
|
|
|
|
|
|
|
$g->debug(0); # off (default) |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
Manipulates the debug level of this module. Debug output is sent |
122
|
|
|
|
|
|
|
to STDERR. Object-level debugging is not yet supported. |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
=cut |
125
|
|
|
|
|
|
|
|
126
|
18
|
|
|
18
|
|
160
|
use Carp; |
|
18
|
|
|
|
|
25
|
|
|
18
|
|
|
|
|
47737
|
|
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
my $VSEP = '|'; # string used to separate vertices |
129
|
|
|
|
|
|
|
my $WSEP = '\|'; # regexp used to separate vertices |
130
|
|
|
|
|
|
|
my $PSEP = '\+'; # regexp used to separate elements of partition |
131
|
|
|
|
|
|
|
my $QSEP = '+'; # string used to separate elements of partition |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
my $MD_Debug = 0; |
134
|
|
|
|
|
|
|
|
135
|
|
|
|
|
|
|
sub debug { |
136
|
25
|
|
|
25
|
1
|
3165
|
my $class = shift; |
137
|
25
|
100
|
|
|
|
64
|
if ( ref($class) ) { $class = ref($class) } |
|
13
|
|
|
|
|
20
|
|
138
|
25
|
|
|
|
|
25
|
$MD_Debug = shift; |
139
|
25
|
100
|
|
|
|
3562
|
carp 'Turning ', ($MD_Debug ? 'on' : 'off'), ' ', |
|
|
100
|
|
|
|
|
|
140
|
|
|
|
|
|
|
$class, ' debugging', ($MD_Debug ? ", level $MD_Debug" : ''); |
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=item canonical_form() |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
my $g = new Graph::ModularDecomposition; |
147
|
|
|
|
|
|
|
Graph::ModularDecomposition->canonical_form(1); # on (default) |
148
|
|
|
|
|
|
|
Graph::ModularDecomposition->canonical_form(0); # off |
149
|
|
|
|
|
|
|
$g->canonical_form(1); # same thing |
150
|
|
|
|
|
|
|
$g->canonical_form(0); # off |
151
|
|
|
|
|
|
|
print "yes" if $g->canonical_form(); |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
Manipulates whether this module keeps modular decomposition trees in |
154
|
|
|
|
|
|
|
"canonical" form, where lists of vertices are kept sorted. This allows |
155
|
|
|
|
|
|
|
tree_to_string() on two isomorphic decomposition trees to produce the |
156
|
|
|
|
|
|
|
same output (well, sometimes -- a more general solution requires an |
157
|
|
|
|
|
|
|
isomorphism test). Canonical form forces sorting of vertices in several |
158
|
|
|
|
|
|
|
places, which will slow down some of the algorithms. When called with |
159
|
|
|
|
|
|
|
no arguments, returns the current state. |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
=cut |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
my $Canonical_form = 1; |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
sub canonical_form { |
166
|
163
|
|
|
163
|
1
|
331
|
my $class = shift; |
167
|
163
|
50
|
|
|
|
264
|
if ( ref($class) ) { $class = ref($class) } |
|
163
|
|
|
|
|
154
|
|
168
|
163
|
|
|
|
|
126
|
my $cf = shift; |
169
|
163
|
100
|
|
|
|
385
|
return $Canonical_form unless defined $cf; |
170
|
1
|
|
|
|
|
2
|
$Canonical_form = $cf; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
=item new() |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
my $g = new Graph::ModularDecomposition; |
177
|
|
|
|
|
|
|
$g = Graph::ModularDecomposition->new; # same thing |
178
|
|
|
|
|
|
|
my $h = $g->new; |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
Constructor. The instance method style C<< $object->new >> is an extension |
181
|
|
|
|
|
|
|
and was not present in L. |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
=cut |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub new { |
186
|
379
|
|
|
379
|
1
|
87707
|
my $self = shift; |
187
|
379
|
100
|
|
|
|
630
|
my $class = ref($self) ? ref($self) : $self; |
188
|
379
|
|
|
|
|
990
|
return bless $class->SUPER::new(@_,directed=>1), $class; |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
=item pairstring_to_graph |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
my $g = Graph::ModularDecomposition |
195
|
|
|
|
|
|
|
->pairstring_to_graph( 'ac, ad, bd' ); |
196
|
|
|
|
|
|
|
my $h = $g->pairstring_to_graph( 'a-c, a-d,b-d' ); # same thing |
197
|
|
|
|
|
|
|
my $h = $g->pairstring_to_graph( 'a,b,c,d,a-c,a-d,b-d' ); # same thing |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
use Graph::ModularDecomposition qw( pairstring_to_graph ); |
200
|
|
|
|
|
|
|
my $k = pairstring_to_graph( 'Graph::ModularDecomposition', |
201
|
|
|
|
|
|
|
'ac,ad,bd' ); # same thing |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
Convert string of pairs input to Graph::ModularDecomposition output. |
204
|
|
|
|
|
|
|
Allows either 'a-b,b-c,d' or 'ab,bc,d' style notation but these should |
205
|
|
|
|
|
|
|
not be mixed in one string. Vertex labels should not include the |
206
|
|
|
|
|
|
|
'-' character. Use the '-' style if multi-character vertex labels |
207
|
|
|
|
|
|
|
are in use. Single label "pairs" are interpreted as vertices to add. |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
=cut |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub pairstring_to_graph { |
212
|
28
|
|
|
28
|
1
|
1549
|
my $class = shift; |
213
|
28
|
100
|
|
|
|
63
|
if ( ref($class) ) { $class = ref($class) } |
|
5
|
|
|
|
|
10
|
|
214
|
28
|
|
|
|
|
32
|
my $pairs = shift; |
215
|
28
|
|
|
|
|
57
|
my $g = new $class; |
216
|
28
|
|
|
|
|
3255
|
my ($p, $q); |
217
|
28
|
100
|
|
|
|
98
|
my $s = ( ( index( $pairs, '-' ) >= 0 ) ? '\-' : '' ); |
218
|
28
|
|
|
|
|
254
|
foreach my $r ( split /,\s*/, $pairs ) { |
219
|
261
|
|
|
|
|
11304
|
( $p, $q ) = split $s, $r; |
220
|
261
|
100
|
|
|
|
4904
|
print "p=$p, q=$q\n" if $MD_Debug > 2; |
221
|
261
|
100
|
|
|
|
334
|
if ( $q ) { |
222
|
254
|
100
|
|
|
|
447
|
$g = $g->add_edge( $p, $q ) unless $g->has_edge( $p, $q ); |
223
|
|
|
|
|
|
|
} else { |
224
|
7
|
100
|
|
|
|
25
|
$g = $g->add_vertex( $p ) unless $g->has_vertex( $p ); |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
} |
227
|
28
|
|
|
|
|
958
|
return bless $g, $class; |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=item check_transitive() |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
my $g = new Graph::ModularDecomposition; |
234
|
|
|
|
|
|
|
# add some edges... |
235
|
|
|
|
|
|
|
print "transitive" if $g->check_transitive; |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
Returns 1 if input digraph is transitive, '' otherwise. May break if |
238
|
|
|
|
|
|
|
Graph::stringify lists vertices in unsorted order. |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
=cut |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
sub check_transitive { |
243
|
39
|
|
|
39
|
1
|
37
|
my $g = shift; |
244
|
39
|
|
|
|
|
110
|
my $g2 = $g->copy; |
245
|
39
|
|
|
|
|
17582
|
my $h = $g->TransitiveClosure_Floyd_Warshall; |
246
|
|
|
|
|
|
|
# get rid of loops |
247
|
39
|
|
|
|
|
69100
|
foreach ( $h->vertices ) { $h->delete_edge( $_, $_ ) } |
|
139
|
|
|
|
|
6452
|
|
248
|
39
|
|
|
|
|
2052
|
foreach ( $g2->vertices ) { $g2->delete_edge( $_, $_ ) } |
|
139
|
|
|
|
|
3101
|
|
249
|
39
|
100
|
|
|
|
892
|
print STDERR "gdct: ", $g, ' vs. ', $h, "\n" if $MD_Debug; |
250
|
39
|
|
|
|
|
2424
|
return $h eq $g2; |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
=item setminus() |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
my @d = setminus( ['a','b','c'], ['b','d'] ); # ('a','c') |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
Given two references to lists, returns the set difference of the two |
259
|
|
|
|
|
|
|
lists as a list. Can be imported. |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
=cut |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
sub setminus { |
264
|
1337
|
|
|
1337
|
1
|
42935
|
my $X = shift; |
265
|
1337
|
|
|
|
|
821
|
my $Y = shift; |
266
|
1337
|
|
|
|
|
824
|
my @X = @{$X}; |
|
1337
|
|
|
|
|
1459
|
|
267
|
1337
|
100
|
|
|
|
1677
|
print STDERR 'setminus# ', @X, ' - ', @{$Y}, ' = ' if $MD_Debug > 1; |
|
49
|
|
|
|
|
49
|
|
268
|
1337
|
|
|
|
|
779
|
foreach my $x ( @{$Y} ) { |
|
1337
|
|
|
|
|
1116
|
|
269
|
1522
|
|
|
|
|
2528
|
@X = grep $x ne $_, @X; |
270
|
|
|
|
|
|
|
} |
271
|
1337
|
100
|
|
|
|
1586
|
print STDERR @X, "\n" if $MD_Debug > 1; |
272
|
1337
|
|
|
|
|
2266
|
return @X; |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
=item setunion() |
277
|
|
|
|
|
|
|
|
278
|
|
|
|
|
|
|
my @u = setunion(['a','bc',42], [42,4,'a','c']); |
279
|
|
|
|
|
|
|
# ('a','bc',42,4,'c') |
280
|
|
|
|
|
|
|
|
281
|
|
|
|
|
|
|
Given two references to lists, returns the set union of the two lists |
282
|
|
|
|
|
|
|
as a list. Can be imported. |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
=cut |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
sub setunion { |
287
|
597
|
|
|
597
|
1
|
428
|
my $X = shift; |
288
|
597
|
|
|
|
|
365
|
my $Y = shift; |
289
|
597
|
|
|
|
|
342
|
my @X = @{$X}; |
|
597
|
|
|
|
|
547
|
|
290
|
597
|
100
|
|
|
|
690
|
print STDERR 'setunion# ', @X, ' U ', @{$Y}, ' = ' if $MD_Debug > 1; |
|
23
|
|
|
|
|
29
|
|
291
|
597
|
|
|
|
|
375
|
foreach my $x ( @{$Y} ) { |
|
597
|
|
|
|
|
481
|
|
292
|
404
|
100
|
|
|
|
710
|
push @X, $x unless grep $x eq $_, @X; |
293
|
|
|
|
|
|
|
} |
294
|
597
|
100
|
|
|
|
709
|
print STDERR @X, "\n" if $MD_Debug > 1; |
295
|
597
|
|
|
|
|
1000
|
return sort @X; |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
=item restriction() |
300
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
use Graph::ModularDecomposition; |
302
|
|
|
|
|
|
|
my $G = new Graph::ModularDecomposition; |
303
|
|
|
|
|
|
|
foreach ( 'ac', 'ad', 'bd' ) { $G->add_edge( split // ) } |
304
|
|
|
|
|
|
|
restriction( $G, split(//, 'abdefgh') ); # a-d,b-d |
305
|
|
|
|
|
|
|
$G->restriction( split(//, 'abdefgh') ); # same thing |
306
|
|
|
|
|
|
|
|
307
|
|
|
|
|
|
|
Compute G|X, the subgraph of G induced by X. X is represented as a |
308
|
|
|
|
|
|
|
list of vertices. |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
=cut |
311
|
|
|
|
|
|
|
|
312
|
|
|
|
|
|
|
sub restriction { |
313
|
80
|
|
|
80
|
1
|
70
|
my $G = shift; |
314
|
80
|
100
|
|
|
|
146
|
if ( $MD_Debug > 2 ) { print STDERR 'restriction(', ref($G), ")\n" } |
|
1
|
|
|
|
|
4
|
|
315
|
80
|
|
|
|
|
180
|
my $h = ($G->copy)->delete_vertices( setminus( [$G->vertices], [@_] ) ); |
316
|
80
|
100
|
|
|
|
20335
|
if ( $MD_Debug > 1 ) { |
317
|
1
|
|
|
|
|
6
|
print STDERR 'restriction(', $G, '|', join($QSEP, @_), ') = ', $h, "\n" |
318
|
|
|
|
|
|
|
} |
319
|
80
|
|
|
|
|
681
|
return $h; |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
=item factor() |
324
|
|
|
|
|
|
|
|
325
|
|
|
|
|
|
|
$h = factor( $g, [['a','b'], ['c'], ['d','e','f']] ); |
326
|
|
|
|
|
|
|
$h = $g->factor( [[qw(a b)], ['c'], [qw(d e f)]] ); # same thing |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
Compute G/P for partition P containing modules. Will fail in odd |
329
|
|
|
|
|
|
|
ways if members of P are not modules. |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
=cut |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
sub factor { |
334
|
41
|
|
|
41
|
1
|
37
|
my $G = shift; |
335
|
41
|
|
|
|
|
33
|
my $P = shift; |
336
|
41
|
|
|
|
|
92
|
my $GP = $G->copy; |
337
|
41
|
|
|
|
|
18621
|
my $p; |
338
|
41
|
|
|
|
|
43
|
foreach my $X ( @{$P} ) { |
|
41
|
|
|
|
|
55
|
|
339
|
124
|
100
|
|
|
|
5057
|
print STDERR "factor# X = $X\n" if $MD_Debug > 1; |
340
|
124
|
100
|
|
|
|
167
|
print STDERR "factor# \@X = @$X\n" if $MD_Debug > 1; |
341
|
124
|
|
|
|
|
81
|
my $newnode = join $VSEP, @{$X}; # turn nodes a, b, c into new node abc |
|
124
|
|
|
|
|
142
|
|
342
|
124
|
100
|
|
|
|
178
|
print STDERR "factor# newnode = $newnode\n" if $MD_Debug > 1; |
343
|
124
|
|
|
|
|
93
|
my $a = ${$X}[0]; |
|
124
|
|
|
|
|
109
|
|
344
|
124
|
100
|
|
|
|
170
|
print STDERR "factor# representative node $a\n" if $MD_Debug > 1; |
345
|
124
|
100
|
|
|
|
187
|
if ( $newnode ne $a ) { # do nothing if singleton |
346
|
19
|
|
|
|
|
37
|
$GP->add_vertex( $newnode ); |
347
|
19
|
|
|
|
|
326
|
foreach $p ( $GP->predecessors( $a ) ) { |
348
|
11
|
100
|
|
|
|
255
|
print STDERR "factor# predecessor $p\n" if $MD_Debug > 2; |
349
|
11
|
50
|
|
|
|
19
|
$GP = $GP->add_edge( $p, $newnode ) |
350
|
|
|
|
|
|
|
unless $GP->has_edge( $p, $newnode ); |
351
|
|
|
|
|
|
|
} |
352
|
19
|
|
|
|
|
444
|
foreach $p ( $GP->successors( $a ) ) { |
353
|
45
|
100
|
|
|
|
1279
|
print STDERR "factor# successor $p\n" if $MD_Debug > 2; |
354
|
45
|
50
|
|
|
|
67
|
$GP = $GP->add_edge( $newnode, $p ) |
355
|
|
|
|
|
|
|
unless $GP->has_edge( $newnode, $p ); |
356
|
|
|
|
|
|
|
} |
357
|
19
|
|
|
|
|
578
|
$GP = $GP->delete_vertices( @{$X} ); |
|
19
|
|
|
|
|
38
|
|
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
} |
360
|
41
|
|
|
|
|
472
|
return $GP; |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
|
364
|
|
|
|
|
|
|
=item partition_subsets() |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
@part = partition_subsets( $G, ['a','b','c'], $w ); |
367
|
|
|
|
|
|
|
@part = $G->partition_subsets( ['a','b','c'], $w ); # same thing |
368
|
|
|
|
|
|
|
|
369
|
|
|
|
|
|
|
Partition set of vertices into maximal subsets not distinguished by w in G. |
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
=cut |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
sub partition_subsets { |
374
|
486
|
|
|
486
|
1
|
328
|
my $G = shift; |
375
|
486
|
|
|
|
|
337
|
my $S = shift; |
376
|
486
|
|
|
|
|
322
|
my $w = shift; |
377
|
|
|
|
|
|
|
|
378
|
486
|
100
|
|
|
|
551
|
print STDERR 'p..n_subsets# @S = ', @{$S}, ", w = $w \n" if $MD_Debug > 1; |
|
19
|
|
|
|
|
25
|
|
379
|
486
|
|
|
|
|
302
|
my (@A, @B, @C, @D); |
380
|
486
|
|
|
|
|
323
|
foreach my $x ( @{$S} ) { |
|
486
|
|
|
|
|
418
|
|
381
|
794
|
100
|
|
|
|
901
|
print STDERR 'p..n_subsets# xw = ', $x, $w if $MD_Debug > 2; |
382
|
794
|
100
|
|
|
|
1088
|
if ( $G->has_edge( $w, $x ) ) { |
383
|
182
|
100
|
|
|
|
2057
|
if ( $G->has_edge( $x, $w ) ) { # xw wx (not poset) |
384
|
2
|
|
|
|
|
21
|
push @A, $x; |
385
|
2
|
100
|
|
|
|
5
|
print STDERR ' A = ', @A, "\n" if $MD_Debug > 2; |
386
|
|
|
|
|
|
|
} else { # ~xw wx |
387
|
180
|
|
|
|
|
1736
|
push @B, $x; |
388
|
180
|
100
|
|
|
|
310
|
print STDERR ' B = ', @B, "\n" if $MD_Debug > 2; |
389
|
|
|
|
|
|
|
} |
390
|
|
|
|
|
|
|
} else { |
391
|
612
|
100
|
|
|
|
6579
|
if ( $G->has_edge( $x, $w ) ) { # xw ~wx |
392
|
189
|
|
|
|
|
1949
|
push @C, $x; |
393
|
189
|
100
|
|
|
|
317
|
print STDERR ' C = ', @C, "\n" if $MD_Debug > 2; |
394
|
|
|
|
|
|
|
} else { # ~xw ~wx |
395
|
423
|
|
|
|
|
4024
|
push @D, $x; |
396
|
423
|
100
|
|
|
|
680
|
print STDERR ' D = ', @D, "\n" if $MD_Debug > 2; |
397
|
|
|
|
|
|
|
} |
398
|
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
} |
400
|
486
|
|
|
|
|
523
|
return grep @{$_}, (\@A, \@B, \@C, \@D); |
|
1944
|
|
|
|
|
1713
|
|
401
|
|
|
|
|
|
|
} |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
=item partition() |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
my $p = partition( $g, $v ); |
407
|
|
|
|
|
|
|
$p = $g->partition( $v ); # same thing |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
For a graph, calculate maximal modules not including a given vertex. |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
=cut |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
sub partition { |
414
|
66
|
|
|
66
|
1
|
74
|
my $G = shift; |
415
|
66
|
|
|
|
|
60
|
my $v = shift; |
416
|
|
|
|
|
|
|
|
417
|
66
|
100
|
|
|
|
145
|
print STDERR 'partition# G = ', $G, ", v = $v\n" if $MD_Debug > 1; |
418
|
66
|
|
|
|
|
582
|
my (%L, @done, $tempset, $S, @ZS, $w); |
419
|
66
|
|
|
|
|
127
|
$S = [ setminus( [ $G->vertices ], [ $v ] ) ]; |
420
|
66
|
100
|
|
|
|
143
|
print STDERR 'partition# @S = ', @{$S}, "\n" if $MD_Debug > 1; |
|
2
|
|
|
|
|
4
|
|
421
|
66
|
|
|
|
|
143
|
$L{$S} = [ $v ]; |
422
|
66
|
|
|
|
|
86
|
my @todo = ( $S ); |
423
|
66
|
100
|
|
|
|
106
|
print STDERR 'partition# L{S}[0] = ', $L{$S}[0], "\n" if $MD_Debug > 1; |
424
|
66
|
|
|
|
|
119
|
while ( @todo ) { |
425
|
479
|
|
|
|
|
369
|
$S = shift @todo; |
426
|
479
|
|
|
|
|
365
|
@ZS = @{$L{$S}}; |
|
479
|
|
|
|
|
747
|
|
427
|
479
|
|
|
|
|
380
|
$w = $ZS[0]; |
428
|
479
|
100
|
|
|
|
583
|
print STDERR 'partition# ZS = ', @ZS, "\n" if $MD_Debug > 1; |
429
|
479
|
|
|
|
|
567
|
delete $L{$S}; |
430
|
479
|
|
|
|
|
561
|
foreach my $W ( $G->partition_subsets( $S, $w ) ) { |
431
|
595
|
100
|
|
|
|
720
|
print STDERR 'partition# W = ', @{$W}, "\n" if $MD_Debug > 1; |
|
23
|
|
|
|
|
23
|
|
432
|
595
|
|
|
|
|
628
|
$tempset = [ setunion( [ setminus( $S, $W ) ], |
433
|
|
|
|
|
|
|
[ setminus( \@ZS, [ $w ] ) ] ) ]; |
434
|
595
|
100
|
|
|
|
636
|
if ( @{$tempset} ) { |
|
595
|
|
|
|
|
646
|
|
435
|
413
|
100
|
|
|
|
480
|
print STDERR 'partition# tempset = ', @{$tempset}, "\n" |
|
17
|
|
|
|
|
17
|
|
436
|
|
|
|
|
|
|
if $MD_Debug > 1; |
437
|
413
|
|
|
|
|
711
|
$L{$W} = $tempset; |
438
|
413
|
|
|
|
|
717
|
push @todo, $W; |
439
|
|
|
|
|
|
|
} else { |
440
|
182
|
|
|
|
|
378
|
push @done, $W; |
441
|
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
|
} |
443
|
|
|
|
|
|
|
} |
444
|
66
|
|
|
|
|
174
|
return \@done; |
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
=item distinguishes() |
449
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
print "yes" if distinguishes( $g, $x, $y, $z ); |
451
|
|
|
|
|
|
|
print "yes" if $g->distinguishes( $x, $y, $z ); # same thing |
452
|
|
|
|
|
|
|
|
453
|
|
|
|
|
|
|
True if vertex $x distinguishes vertices $y and $z in graph $g. |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
=cut |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
sub distinguishes { |
458
|
380
|
|
|
380
|
1
|
673
|
my ($g,$x,$y,$z) = @_; |
459
|
380
|
100
|
|
|
|
452
|
print STDERR " $x$y?", $g->has_edge($x,$y) if $MD_Debug > 1; |
460
|
380
|
100
|
|
|
|
597
|
print STDERR " $x$z?", $g->has_edge($x,$z) if $MD_Debug > 1; |
461
|
380
|
100
|
|
|
|
543
|
print STDERR " $y$x?", $g->has_edge($y,$x) if $MD_Debug > 1; |
462
|
380
|
100
|
|
|
|
529
|
print STDERR " $z$x?", $g->has_edge($z,$x) if $MD_Debug > 1; |
463
|
380
|
|
100
|
|
|
563
|
my $ret = ( $g->has_edge($x,$y) != $g->has_edge($x,$z) ) |
464
|
|
|
|
|
|
|
|| ( $g->has_edge($y,$x) != $g->has_edge($z,$x) ); |
465
|
380
|
100
|
|
|
|
12210
|
print STDERR "=$ret\n" if $MD_Debug > 1; |
466
|
380
|
|
|
|
|
745
|
return $ret; |
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
=item G() |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
$G = G( $g, $v ); |
473
|
|
|
|
|
|
|
$G = $g->G( $v ); # same thing |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
"Trivially" calculate G(g,v). dom(G(g,v)) = dom(g)\{v}, and (x,y) is |
476
|
|
|
|
|
|
|
an edge of G(g,v) whenever x distinguishes y and v in g. |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
=cut |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
sub G { |
481
|
49
|
|
|
49
|
1
|
52
|
my $g = shift; |
482
|
49
|
|
|
|
|
54
|
my $v = shift; |
483
|
49
|
|
|
|
|
105
|
my $G = new ref($g); |
484
|
49
|
100
|
|
|
|
4954
|
print STDERR 'G([', $g, "], $v) =...\n" if $MD_Debug; |
485
|
49
|
|
|
|
|
564
|
X: foreach my $x ( $g->vertices ) { |
486
|
180
|
100
|
|
|
|
2913
|
next X if ( $v eq $x ); |
487
|
131
|
100
|
|
|
|
189
|
print STDERR 'X=', $x, "\n" if $MD_Debug > 1; |
488
|
131
|
|
|
|
|
204
|
$G = $G->add_vertex( $x ); |
489
|
131
|
|
|
|
|
2186
|
Y: foreach my $y ( $g->vertices ) { |
490
|
632
|
100
|
100
|
|
|
10719
|
next Y if ( $v eq $y or $x eq $y ); |
491
|
370
|
100
|
|
|
|
444
|
print STDERR 'Y=', $y, "\n" if $MD_Debug > 1; |
492
|
370
|
100
|
|
|
|
440
|
if ( $g->distinguishes( $x, $y, $v ) ) { |
493
|
189
|
50
|
|
|
|
276
|
$G = $G->add_edge( $x, $y ) unless $G->has_edge( $x, $y ); |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
} |
497
|
49
|
100
|
|
|
|
99
|
print STDERR '...G()=', $G, "\n" if $MD_Debug; |
498
|
49
|
|
|
|
|
507
|
return $G; |
499
|
|
|
|
|
|
|
} |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
=item tree_to_string() |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
print tree_to_string( $t ); |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
String representation of decomposition tree. Returns empty string for |
507
|
|
|
|
|
|
|
an empty decomposition tree. Needs to be explicitly imported. If |
508
|
|
|
|
|
|
|
Graph::vertices returns the vertices in unsorted order, then isomorphic |
509
|
|
|
|
|
|
|
trees can have different string representations. |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
=cut |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
sub tree_to_string { |
514
|
180
|
|
|
180
|
1
|
135
|
my $t = shift; |
515
|
180
|
|
|
|
|
127
|
my $s = ''; |
516
|
180
|
100
|
|
|
|
283
|
return $s unless defined $t->{type}; |
517
|
174
|
100
|
|
|
|
270
|
$s .= $t->{type} if $t->{type} ne 'leaf'; |
518
|
174
|
100
|
|
|
|
233
|
$s .= '_' . $t->{col} if ( $t->{type} eq 'complete' ); |
519
|
174
|
|
|
|
|
188
|
$s .= '[' . $t->{value} . ']'; |
520
|
174
|
100
|
|
|
|
240
|
if ( $t->{type} ne 'leaf' ) { |
521
|
49
|
|
|
|
|
46
|
my $sep = ''; |
522
|
49
|
|
|
|
|
44
|
$s .= '('; |
523
|
49
|
|
|
|
|
31
|
foreach ( @{$t->{children}} ) { |
|
49
|
|
|
|
|
67
|
|
524
|
131
|
|
|
|
|
152
|
$s .= $sep . tree_to_string( $_ ); |
525
|
131
|
|
|
|
|
131
|
$sep = ';'; |
526
|
|
|
|
|
|
|
} |
527
|
49
|
|
|
|
|
44
|
$s .= ')'; |
528
|
|
|
|
|
|
|
} |
529
|
174
|
|
|
|
|
210
|
return $s; |
530
|
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
|
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
=item partition_to_string |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
print partition_to_string([['h'], [qw(c a b)], [qw(d e f g)]]); |
536
|
|
|
|
|
|
|
# a+b+c,d+e+f+g,h |
537
|
|
|
|
|
|
|
|
538
|
|
|
|
|
|
|
String representation of partition. Returns empty string for an |
539
|
|
|
|
|
|
|
empty partition. Needs to be explicitly imported. |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
=cut |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
sub partition_to_string { |
544
|
36
|
|
|
36
|
1
|
38
|
return join ',', sort (map { join $QSEP, sort @{$_} } @{+shift}); |
|
125
|
|
|
|
|
84
|
|
|
125
|
|
|
|
|
284
|
|
|
36
|
|
|
|
|
37
|
|
545
|
|
|
|
|
|
|
} |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
=item modular_decomposition_EGMS() |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
use Graph::ModularDecomposition; |
551
|
|
|
|
|
|
|
$g = new Graph::ModularDecomposition; |
552
|
|
|
|
|
|
|
$m = $g->modular_decomposition_EGMS; |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
Compute modular decomposition tree of the input, which must be |
555
|
|
|
|
|
|
|
a Graph::ModularDecomposition object, using algorithm 6.1 of |
556
|
|
|
|
|
|
|
A. Ehrenfeucht, H. N. Gabow, R. M. McConnell, S. J. Sullivan, "An |
557
|
|
|
|
|
|
|
O(n^2) Divide-and-Conquer Algorithm for the Prime Tree Decomposition |
558
|
|
|
|
|
|
|
of Two-Structures and Modular Decomposition of Graphs", Journal of |
559
|
|
|
|
|
|
|
Algorithms 16 (1994), pp. 283-294. |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
The decomposition tree consists of nodes with attributes: 'type' is |
562
|
|
|
|
|
|
|
a string matching /^leaf|primitive|complete|linear$/, 'children' is |
563
|
|
|
|
|
|
|
a reference to a potentially empty list of pointers to other nodes, |
564
|
|
|
|
|
|
|
'value' is a string with the vertices in the decomposition defined |
565
|
|
|
|
|
|
|
by the tree, separated by '|' (VSEP), and 'col' is a string containing the |
566
|
|
|
|
|
|
|
colour of the module, matching /^0|1|01$/. A node with 'type' of |
567
|
|
|
|
|
|
|
'complete' is parallel if 'col' is '0' and series if 'col' is '1'. |
568
|
|
|
|
|
|
|
A node with 'type' of 'linear' has 'col' of '01'. Use the function |
569
|
|
|
|
|
|
|
tree_to_string() to convert the tree into a more generally usable form. |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
=cut |
572
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
sub modular_decomposition_EGMS { |
574
|
114
|
|
|
114
|
1
|
369
|
my $g = shift; |
575
|
114
|
|
|
|
|
105
|
my $md = 0; |
576
|
114
|
|
|
|
|
84
|
$md ++; |
577
|
114
|
|
|
|
|
144
|
my $B = ' 'x$md; |
578
|
114
|
100
|
|
|
|
199
|
print STDERR $B, 'MD(', $g, ")=...\n" if $MD_Debug; |
579
|
114
|
|
|
|
|
890
|
my $v = ($g->vertices)[0]; |
580
|
114
|
100
|
|
|
|
2565
|
print STDERR $B, 'v=', (defined($v) ? $v : 'undef'), "\n" if $MD_Debug; |
|
|
100
|
|
|
|
|
|
581
|
|
|
|
|
|
|
|
582
|
114
|
|
|
|
|
113
|
my $t = {}; |
583
|
114
|
100
|
|
|
|
164
|
unless ( $v ) { |
584
|
3
|
100
|
|
|
|
9
|
print STDERR $B, '...MD=', tree_to_string( $t ), "\n" if $MD_Debug; |
585
|
3
|
|
|
|
|
4
|
$md --; |
586
|
3
|
|
|
|
|
8
|
return $t; |
587
|
|
|
|
|
|
|
} |
588
|
111
|
|
|
|
|
201
|
$t->{type} = 'leaf'; |
589
|
111
|
|
|
|
|
141
|
$t->{children} = []; |
590
|
111
|
50
|
|
|
|
217
|
if ($g->canonical_form()) { |
591
|
111
|
|
|
|
|
188
|
$t->{value} = join($VSEP, sort($g->vertices)); |
592
|
|
|
|
|
|
|
} else { |
593
|
0
|
|
|
|
|
0
|
$t->{value} = join($VSEP, $g->vertices); |
594
|
|
|
|
|
|
|
} |
595
|
111
|
|
|
|
|
2314
|
$t->{col} = '0'; |
596
|
|
|
|
|
|
|
|
597
|
111
|
100
|
|
|
|
173
|
if ( scalar $g->vertices == 1 ) { |
598
|
73
|
100
|
|
|
|
1318
|
print STDERR $B, '...MD=', tree_to_string( $t ), "\n" if $MD_Debug; |
599
|
73
|
|
|
|
|
62
|
$md --; |
600
|
73
|
|
|
|
|
102
|
return $t; |
601
|
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
|
|
603
|
38
|
|
|
|
|
840
|
my $p = partition( $g, $v ); |
604
|
38
|
|
|
|
|
35
|
push @{$p}, [ $v ]; |
|
38
|
|
|
|
|
56
|
|
605
|
38
|
|
|
|
|
78
|
my $gd = $g->factor( $p ); |
606
|
38
|
100
|
|
|
|
78
|
print STDERR $B, 'gd = ', $gd, "\n" if $MD_Debug; |
607
|
38
|
|
|
|
|
385
|
my $Gdd = $gd->G($v)->strongly_connected_graph; |
608
|
38
|
100
|
|
|
|
62640
|
print STDERR $B, 'Gdd = [', $Gdd, '], ', scalar $Gdd->vertices, "\n" if $MD_Debug; |
609
|
|
|
|
|
|
|
|
610
|
38
|
|
|
|
|
375
|
my $u = $t; |
611
|
38
|
|
|
|
|
34
|
my @f; |
612
|
38
|
|
|
|
|
90
|
while ( @f = grep( $Gdd->out_degree($_) == 0 , $Gdd->vertices ) ) { |
613
|
50
|
100
|
|
|
|
8197
|
print STDERR $B, "\@f=[@f]\n" if $MD_Debug; |
614
|
50
|
|
|
|
|
55
|
my @s; |
615
|
50
|
|
|
|
|
90
|
foreach my $s ( $Gdd->vertices ) { |
616
|
74
|
|
|
|
|
1338
|
push @s, split(/$PSEP/, $s); |
617
|
|
|
|
|
|
|
} |
618
|
50
|
50
|
|
|
|
103
|
if ($g->canonical_form()) { |
619
|
50
|
|
|
|
|
167
|
$u->{value} = join('', sort($v, @s)); |
620
|
|
|
|
|
|
|
} else { |
621
|
0
|
|
|
|
|
0
|
$u->{value} = join('', ($v, @s)); |
622
|
|
|
|
|
|
|
} |
623
|
50
|
|
|
|
|
58
|
my $w = {}; |
624
|
50
|
|
|
|
|
88
|
$w->{type} = 'leaf'; |
625
|
50
|
|
|
|
|
89
|
$w->{children} = []; |
626
|
50
|
|
|
|
|
84
|
$w->{value} = $v; |
627
|
50
|
|
|
|
|
60
|
$w->{col} = '0'; |
628
|
50
|
|
|
|
|
36
|
push @{$u->{children}}, $w; |
|
50
|
|
|
|
|
75
|
|
629
|
|
|
|
|
|
|
|
630
|
50
|
|
|
|
|
115
|
$Gdd->delete_vertices( @f ); |
631
|
50
|
|
|
|
|
6335
|
my @F; |
632
|
50
|
|
|
|
|
70
|
foreach my $f ( @f ) { |
633
|
55
|
|
|
|
|
174
|
foreach my $F ( split /$PSEP/, $f ) { |
634
|
77
|
50
|
|
|
|
246
|
push @F, $F unless grep $F eq $_, @F; |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
} |
637
|
50
|
100
|
|
|
|
95
|
print STDERR $B, "\@F=@F\n" if $MD_Debug; |
638
|
50
|
100
|
100
|
|
|
209
|
if ( @f == 1 and @F > 1 ) { |
639
|
11
|
|
|
|
|
23
|
$u->{type} = 'primitive'; |
640
|
11
|
|
|
|
|
22
|
$u->{col} = '0'; |
641
|
|
|
|
|
|
|
} else { |
642
|
39
|
|
|
|
|
69
|
my $x = substr $F[0], 0, 1; # single-char vertex names! |
643
|
39
|
100
|
|
|
|
86
|
if ( $g->has_edge($v, $x) == $g->has_edge($x, $v) ) { |
644
|
10
|
|
|
|
|
226
|
$u->{type} = 'complete'; # 0 parallel, 1 series |
645
|
10
|
50
|
|
|
|
23
|
$u->{col} = $g->has_edge($v, $x) ? '1' : '0'; |
646
|
|
|
|
|
|
|
} else { |
647
|
29
|
|
|
|
|
667
|
$u->{type} = 'linear'; |
648
|
29
|
|
|
|
|
37
|
$u->{col} = '01'; |
649
|
|
|
|
|
|
|
} |
650
|
|
|
|
|
|
|
} |
651
|
50
|
100
|
|
|
|
194
|
print STDERR $B, 'u = ', tree_to_string( $u ), "\n" if $MD_Debug; |
652
|
50
|
|
|
|
|
66
|
foreach my $X ( @F ) { |
653
|
77
|
|
|
|
|
253
|
my $m = $g->restriction( split /$WSEP/, $X ) |
654
|
|
|
|
|
|
|
->modular_decomposition_EGMS; |
655
|
77
|
100
|
66
|
|
|
752
|
if ( defined $m->{col} |
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
656
|
|
|
|
|
|
|
and ( $u->{col} eq $m->{col} ) |
657
|
|
|
|
|
|
|
and ( |
658
|
|
|
|
|
|
|
( $u->{type} eq 'complete' and $m->{type} eq 'complete' ) |
659
|
|
|
|
|
|
|
or ( $u->{type} eq 'linear' and $m->{type} eq 'linear' ) |
660
|
|
|
|
|
|
|
) |
661
|
|
|
|
|
|
|
) { |
662
|
5
|
50
|
|
|
|
7
|
if ( $MD_Debug ) { |
663
|
0
|
|
|
|
|
0
|
print STDERR $B, "u->children= @{$u->{children}}\n"; |
|
0
|
|
|
|
|
0
|
|
664
|
0
|
|
|
|
|
0
|
print STDERR $B, 'm->children= '; |
665
|
0
|
|
|
|
|
0
|
my $sep = ''; |
666
|
0
|
|
|
|
|
0
|
foreach ( @{$m->{children}} ) { |
|
0
|
|
|
|
|
0
|
|
667
|
0
|
|
|
|
|
0
|
print STDERR $sep, '[', tree_to_string( $_ ), ']'; |
668
|
0
|
|
|
|
|
0
|
$sep = ', '; |
669
|
|
|
|
|
|
|
} |
670
|
0
|
|
|
|
|
0
|
print STDERR "\n"; |
671
|
|
|
|
|
|
|
} |
672
|
5
|
|
|
|
|
6
|
push @{$u->{children}}, @{$m->{children}}; |
|
5
|
|
|
|
|
6
|
|
|
5
|
|
|
|
|
12
|
|
673
|
|
|
|
|
|
|
} else { |
674
|
72
|
|
|
|
|
56
|
push @{$u->{children}}, $m; |
|
72
|
|
|
|
|
139
|
|
675
|
|
|
|
|
|
|
} |
676
|
|
|
|
|
|
|
} |
677
|
50
|
|
|
|
|
129
|
$u = $w; |
678
|
|
|
|
|
|
|
} |
679
|
38
|
100
|
|
|
|
723
|
print STDERR $B, '...MD=', tree_to_string( $t ), "\n" if $MD_Debug; |
680
|
38
|
|
|
|
|
28
|
$md --; |
681
|
38
|
|
|
|
|
362
|
return $t; |
682
|
|
|
|
|
|
|
} |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
=item classify() |
686
|
|
|
|
|
|
|
|
687
|
|
|
|
|
|
|
use Graph::ModularDecomposition; |
688
|
|
|
|
|
|
|
my $g = new Graph::ModularDecomposition; |
689
|
|
|
|
|
|
|
my $c = classify( $g ); |
690
|
|
|
|
|
|
|
$c = $g->classify; # same thing |
691
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
Based on the modular decomposition tree, returns: |
693
|
|
|
|
|
|
|
n non-transitive |
694
|
|
|
|
|
|
|
i indecomposable |
695
|
|
|
|
|
|
|
d decomposable but not SP, at least one non-primitive node |
696
|
|
|
|
|
|
|
s series-parallel |
697
|
|
|
|
|
|
|
p decomposable but each module is primitive or series |
698
|
|
|
|
|
|
|
u unclassified: should not happen |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
=cut |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
sub classify { |
703
|
36
|
|
|
36
|
1
|
18086
|
my $g = shift; |
704
|
36
|
100
|
|
|
|
81
|
return 'n' unless $g->check_transitive; |
705
|
33
|
|
|
|
|
13184
|
my $s = tree_to_string( $g->modular_decomposition_EGMS ); |
706
|
33
|
100
|
|
|
|
254
|
return 'i' if $s =~ m/^primitive\[[^\]]+\]\([^\(]*$/; |
707
|
26
|
100
|
100
|
|
|
106
|
return 'd' if $s =~ m/primitive/ and $s =~ m/complete_|linear/; |
708
|
25
|
100
|
|
|
|
197
|
return 's' if $s !~ m/primitive|complete_1/; # matches empty string |
709
|
1
|
50
|
|
|
|
10
|
return 'p' if $s =~ m/primitive|complete_1/; |
710
|
0
|
|
|
|
|
|
return 'u'; |
711
|
|
|
|
|
|
|
} |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
=item to_bitvector2() |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
$b = $g->to_bitvector2; |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
Convert input graph to Bitvector2 output. |
719
|
|
|
|
|
|
|
L version 20104 permits |
720
|
|
|
|
|
|
|
multi-edges; these will be collapsed into a single edge in the |
721
|
|
|
|
|
|
|
output Bitvector2. The Bitvector2 is relative to the unique |
722
|
|
|
|
|
|
|
lexicographic ordering of the vertices. This method is only present |
723
|
|
|
|
|
|
|
if L is found. |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
=cut |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
eval {require Graph::Bitvector2; 1} and # alas, circular dependency here |
728
|
|
|
|
|
|
|
eval q{ |
729
|
|
|
|
|
|
|
sub to_bitvector2 { |
730
|
|
|
|
|
|
|
my $g = shift; |
731
|
|
|
|
|
|
|
my @v = sort $g->vertices; |
732
|
|
|
|
|
|
|
my @bits; |
733
|
|
|
|
|
|
|
while ( @v ) { |
734
|
|
|
|
|
|
|
my $x = shift @v; |
735
|
|
|
|
|
|
|
foreach my $y ( @v ) { |
736
|
|
|
|
|
|
|
push @bits, ( |
737
|
|
|
|
|
|
|
$g->has_edge( $x, $y ) |
738
|
|
|
|
|
|
|
? 1 |
739
|
|
|
|
|
|
|
: ( $g->has_edge( $y, $x ) ? 2 : 0 ) |
740
|
|
|
|
|
|
|
); |
741
|
|
|
|
|
|
|
} |
742
|
|
|
|
|
|
|
} |
743
|
|
|
|
|
|
|
return new Graph::Bitvector2 (join '', @bits); |
744
|
|
|
|
|
|
|
} |
745
|
|
|
|
|
|
|
}; |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
=back |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
=cut |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
1; |
753
|
|
|
|
|
|
|
__END__ |