File Coverage

blib/lib/Graph/ModularDecomposition.pm
Criterion Covered Total %
statement 278 290 95.8
branch 166 176 94.3
condition 17 21 80.9
subroutine 22 22 100.0
pod 17 17 100.0
total 500 526 95.0


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__