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   76012 use 5.006;
  18         46  
4 18     18   67 use strict;
  18         18  
  18         308  
5 18     18   49 use warnings;
  18         27  
  18         904  
6              
7             =head1 NAME
8              
9             Graph::ModularDecomposition - Modular decomposition of directed graphs
10              
11             =cut
12              
13             require Exporter;
14             our $VERSION = '0.14';
15              
16 18     18   10169 use Graph 0.20105;
  18         1487564  
  18         1841  
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   115 use Carp;
  18         21  
  18         46175  
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 2972 my $class = shift;
137 25 100       77 if ( ref($class) ) { $class = ref($class) }
  13         19  
138 25         31 $MD_Debug = shift;
139 25 100       3631 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 162     162 1 323 my $class = shift;
167 162 50       276 if ( ref($class) ) { $class = ref($class) }
  162         154  
168 162         132 my $cf = shift;
169 162 100       362 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>->C is an extension
181             and was not present in L.
182              
183             =cut
184              
185             sub new {
186 379     379 1 90347 my $self = shift;
187 379 100       626 my $class = ref($self) ? ref($self) : $self;
188 379         1026 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 1489 my $class = shift;
213 28 100       73 if ( ref($class) ) { $class = ref($class) }
  5         10  
214 28         35 my $pairs = shift;
215 28         57 my $g = new $class;
216 28         3457 my ($p, $q);
217 28 100       98 my $s = ( ( index( $pairs, '-' ) >= 0 ) ? '\-' : '' );
218 28         239 foreach my $r ( split /,\s*/, $pairs ) {
219 261         11193 ( $p, $q ) = split $s, $r;
220 261 100       3653 print "p=$p, q=$q\n" if $MD_Debug > 2;
221 261 100       320 if ( $q ) {
222 254 100       448 $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         946 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 44 my $g = shift;
244 39         117 my $g2 = $g->copy;
245 39         17623 my $h = $g->TransitiveClosure_Floyd_Warshall;
246             # get rid of loops
247 39         69491 foreach ( $h->vertices ) { $h->delete_edge( $_, $_ ) }
  139         6896  
248 39         2128 foreach ( $g2->vertices ) { $g2->delete_edge( $_, $_ ) }
  139         3079  
249 39 100       870 print STDERR "gdct: ", $g, ' vs. ', $h, "\n" if $MD_Debug;
250 39         2386 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 1313     1313 1 40725 my $X = shift;
265 1313         831 my $Y = shift;
266 1313         762 my @X = @{$X};
  1313         1499  
267 1313 100       1640 print STDERR 'setminus# ', @X, ' - ', @{$Y}, ' = ' if $MD_Debug > 1;
  49         52  
268 1313         748 foreach my $x ( @{$Y} ) {
  1313         1087  
269 1510         2444 @X = grep $x ne $_, @X;
270             }
271 1313 100       1644 print STDERR @X, "\n" if $MD_Debug > 1;
272 1313         2199 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 585     585 1 419 my $X = shift;
288 585         347 my $Y = shift;
289 585         349 my @X = @{$X};
  585         521  
290 585 100       728 print STDERR 'setunion# ', @X, ' U ', @{$Y}, ' = ' if $MD_Debug > 1;
  23         22  
291 585         406 foreach my $x ( @{$Y} ) {
  585         460  
292 371 100       651 push @X, $x unless grep $x eq $_, @X;
293             }
294 585 100       713 print STDERR @X, "\n" if $MD_Debug > 1;
295 585         985 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 72 my $G = shift;
314 80 100       133 if ( $MD_Debug > 2 ) { print STDERR 'restriction(', ref($G), ")\n" }
  1         4  
315 80         169 my $h = ($G->copy)->delete_vertices( setminus( [$G->vertices], [@_] ) );
316 80 100       17885 if ( $MD_Debug > 1 ) {
317 1         6 print STDERR 'restriction(', $G, '|', join($QSEP, @_), ') = ', $h, "\n"
318             }
319 80         672 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 38 my $G = shift;
335 41         41 my $P = shift;
336 41         103 my $GP = $G->copy;
337 41         18788 my $p;
338 41         55 foreach my $X ( @{$P} ) {
  41         71  
339 124 100       5696 print STDERR "factor# X = $X\n" if $MD_Debug > 1;
340 124 100       173 print STDERR "factor# \@X = @$X\n" if $MD_Debug > 1;
341 124         86 my $newnode = join $VSEP, @{$X}; # turn nodes a, b, c into new node abc
  124         156  
342 124 100       158 print STDERR "factor# newnode = $newnode\n" if $MD_Debug > 1;
343 124         90 my $a = ${$X}[0];
  124         114  
344 124 100       164 print STDERR "factor# representative node $a\n" if $MD_Debug > 1;
345 124 100       197 if ( $newnode ne $a ) { # do nothing if singleton
346 19         35 $GP->add_vertex( $newnode );
347 19         335 foreach $p ( $GP->predecessors( $a ) ) {
348 16 100       355 print STDERR "factor# predecessor $p\n" if $MD_Debug > 2;
349 16 50       34 $GP = $GP->add_edge( $p, $newnode )
350             unless $GP->has_edge( $p, $newnode );
351             }
352 19         606 foreach $p ( $GP->successors( $a ) ) {
353 38 100       1029 print STDERR "factor# successor $p\n" if $MD_Debug > 2;
354 38 50       64 $GP = $GP->add_edge( $newnode, $p )
355             unless $GP->has_edge( $newnode, $p );
356             }
357 19         585 $GP = $GP->delete_vertices( @{$X} );
  19         52  
358             }
359             }
360 41         477 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 474     474 1 332 my $G = shift;
375 474         287 my $S = shift;
376 474         292 my $w = shift;
377              
378 474 100       608 print STDERR 'p..n_subsets# @S = ', @{$S}, ", w = $w \n" if $MD_Debug > 1;
  19         25  
379 474         316 my (@A, @B, @C, @D);
380 474         289 foreach my $x ( @{$S} ) {
  474         509  
381 787 100       870 print STDERR 'p..n_subsets# xw = ', $x, $w if $MD_Debug > 2;
382 787 100       1080 if ( $G->has_edge( $w, $x ) ) {
383 187 100       2083 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 185         2075 push @B, $x;
388 185 100       324 print STDERR ' B = ', @B, "\n" if $MD_Debug > 2;
389             }
390             } else {
391 600 100       6590 if ( $G->has_edge( $x, $w ) ) { # xw ~wx
392 180         1827 push @C, $x;
393 180 100       292 print STDERR ' C = ', @C, "\n" if $MD_Debug > 2;
394             } else { # ~xw ~wx
395 420         4107 push @D, $x;
396 420 100       681 print STDERR ' D = ', @D, "\n" if $MD_Debug > 2;
397             }
398             }
399             }
400 474         558 return grep @{$_}, (\@A, \@B, \@C, \@D);
  1896         1661  
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 79 my $G = shift;
415 66         65 my $v = shift;
416              
417 66 100       190 print STDERR 'partition# G = ', $G, ", v = $v\n" if $MD_Debug > 1;
418 66         610 my (%L, @done, $tempset, $S, @ZS, $w);
419 66         138 $S = [ setminus( [ $G->vertices ], [ $v ] ) ];
420 66 100       150 print STDERR 'partition# @S = ', @{$S}, "\n" if $MD_Debug > 1;
  2         5  
421 66         145 $L{$S} = [ $v ];
422 66         82 my @todo = ( $S );
423 66 100       109 print STDERR 'partition# L{S}[0] = ', $L{$S}[0], "\n" if $MD_Debug > 1;
424 66         106 while ( @todo ) {
425 467         371 $S = shift @todo;
426 467         372 @ZS = @{$L{$S}};
  467         723  
427 467         353 $w = $ZS[0];
428 467 100       596 print STDERR 'partition# ZS = ', @ZS, "\n" if $MD_Debug > 1;
429 467         539 delete $L{$S};
430 467         557 foreach my $W ( $G->partition_subsets( $S, $w ) ) {
431 583 100       688 print STDERR 'partition# W = ', @{$W}, "\n" if $MD_Debug > 1;
  23         21  
432 583         593 $tempset = [ setunion( [ setminus( $S, $W ) ],
433             [ setminus( \@ZS, [ $w ] ) ] ) ];
434 583 100       599 if ( @{$tempset} ) {
  583         607  
435 401 100       466 print STDERR 'partition# tempset = ', @{$tempset}, "\n"
  17         17  
436             if $MD_Debug > 1;
437 401         585 $L{$W} = $tempset;
438 401         651 push @todo, $W;
439             } else {
440 182         346 push @done, $W;
441             }
442             }
443             }
444 66         219 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 350     350 1 678 my ($g,$x,$y,$z) = @_;
459 350 100       500 print STDERR " $x$y?", $g->has_edge($x,$y) if $MD_Debug > 1;
460 350 100       567 print STDERR " $x$z?", $g->has_edge($x,$z) if $MD_Debug > 1;
461 350 100       502 print STDERR " $y$x?", $g->has_edge($y,$x) if $MD_Debug > 1;
462 350 100       504 print STDERR " $z$x?", $g->has_edge($z,$x) if $MD_Debug > 1;
463 350   100     546 my $ret = ( $g->has_edge($x,$y) != $g->has_edge($x,$z) )
464             || ( $g->has_edge($y,$x) != $g->has_edge($z,$x) );
465 350 100       11139 print STDERR "=$ret\n" if $MD_Debug > 1;
466 350         653 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 51 my $g = shift;
482 49         53 my $v = shift;
483 49         112 my $G = new ref($g);
484 49 100       5172 print STDERR 'G([', $g, "], $v) =...\n" if $MD_Debug;
485 49         567 X: foreach my $x ( $g->vertices ) {
486 180 100       2851 next X if ( $v eq $x );
487 131 100       193 print STDERR 'X=', $x, "\n" if $MD_Debug > 1;
488 131         220 $G = $G->add_vertex( $x );
489 131         2126 Y: foreach my $y ( $g->vertices ) {
490 602 100 100     10118 next Y if ( $v eq $y or $x eq $y );
491 340 100       434 print STDERR 'Y=', $y, "\n" if $MD_Debug > 1;
492 340 100       437 if ( $g->distinguishes( $x, $y, $v ) ) {
493 182 50       226 $G = $G->add_edge( $x, $y ) unless $G->has_edge( $x, $y );
494             }
495             }
496             }
497 49 100       104 print STDERR '...G()=', $G, "\n" if $MD_Debug;
498 49         516 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 142 my $t = shift;
515 180         136 my $s = '';
516 180 100       276 return $s unless defined $t->{type};
517 174 100       270 $s .= $t->{type} if $t->{type} ne 'leaf';
518 174 100       240 $s .= '_' . $t->{col} if ( $t->{type} eq 'complete' );
519 174         218 $s .= '[' . $t->{value} . ']';
520 174 100       237 if ( $t->{type} ne 'leaf' ) {
521 49         47 my $sep = '';
522 49         45 $s .= '(';
523 49         35 foreach ( @{$t->{children}} ) {
  49         73  
524 131         161 $s .= $sep . tree_to_string( $_ );
525 131         128 $sep = ';';
526             }
527 49         50 $s .= ')';
528             }
529 174         215 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 44 return join ',', sort (map { join $QSEP, sort @{$_} } @{+shift});
  125         81  
  125         317  
  36         39  
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 357 my $g = shift;
575 114         98 my $md = 0;
576 114         90 $md ++;
577 114         146 my $B = ' 'x$md;
578 114 100       182 print STDERR $B, 'MD(', $g, ")=...\n" if $MD_Debug;
579 114         902 my $v = ($g->vertices)[0];
580 114 100       2625 print STDERR $B, 'v=', (defined($v) ? $v : 'undef'), "\n" if $MD_Debug;
    100          
581              
582 114         134 my $t = {};
583 114 100       172 unless ( $v ) {
584 3 100       9 print STDERR $B, '...MD=', tree_to_string( $t ), "\n" if $MD_Debug;
585 3         5 $md --;
586 3         7 return $t;
587             }
588 111         176 $t->{type} = 'leaf';
589 111         139 $t->{children} = [];
590 111 50       205 if ($g->canonical_form()) {
591 111         173 $t->{value} = join($VSEP, sort($g->vertices));
592             } else {
593 0         0 $t->{value} = join($VSEP, $g->vertices);
594             }
595 111         2349 $t->{col} = '0';
596              
597 111 100       161 if ( scalar $g->vertices == 1 ) {
598 73 100       1277 print STDERR $B, '...MD=', tree_to_string( $t ), "\n" if $MD_Debug;
599 73         60 $md --;
600 73         108 return $t;
601             }
602              
603 38         893 my $p = partition( $g, $v );
604 38         35 push @{$p}, [ $v ];
  38         55  
605 38         80 my $gd = $g->factor( $p );
606 38 100       77 print STDERR $B, 'gd = ', $gd, "\n" if $MD_Debug;
607 38         384 my $Gdd = $gd->G($v)->strongly_connected_graph;
608 38 100       59078 print STDERR $B, 'Gdd = [', $Gdd, '], ', scalar $Gdd->vertices, "\n" if $MD_Debug;
609              
610 38         357 my $u = $t;
611 38         44 my @f;
612 38         85 while ( @f = grep( $Gdd->out_degree($_) == 0 , $Gdd->vertices ) ) {
613 49 100       7281 print STDERR $B, "\@f=[@f]\n" if $MD_Debug;
614 49         49 my @s;
615 49         98 foreach my $s ( $Gdd->vertices ) {
616 69         1318 push @s, split(/$PSEP/, $s);
617             }
618 49 50       105 if ($g->canonical_form()) {
619 49         181 $u->{value} = join('', sort($v, @s));
620             } else {
621 0         0 $u->{value} = join('', ($v, @s));
622             }
623 49         92 my $w = {};
624 49         95 $w->{type} = 'leaf';
625 49         93 $w->{children} = [];
626 49         81 $w->{value} = $v;
627 49         61 $w->{col} = '0';
628 49         44 push @{$u->{children}}, $w;
  49         68  
629              
630 49         109 $Gdd->delete_vertices( @f );
631 49         6084 my @F;
632 49         78 foreach my $f ( @f ) {
633 55         179 foreach my $F ( split /$PSEP/, $f ) {
634 77 50       228 push @F, $F unless grep $F eq $_, @F;
635             }
636             }
637 49 100       98 print STDERR $B, "\@F=@F\n" if $MD_Debug;
638 49 100 100     201 if ( @f == 1 and @F > 1 ) {
639 11         18 $u->{type} = 'primitive';
640 11         17 $u->{col} = '0';
641             } else {
642 38         76 my $x = substr $F[0], 0, 1; # single-char vertex names!
643 38 100       80 if ( $g->has_edge($v, $x) == $g->has_edge($x, $v) ) {
644 10         229 $u->{type} = 'complete'; # 0 parallel, 1 series
645 10 50       25 $u->{col} = $g->has_edge($v, $x) ? '1' : '0';
646             } else {
647 28         662 $u->{type} = 'linear';
648 28         45 $u->{col} = '01';
649             }
650             }
651 49 100       196 print STDERR $B, 'u = ', tree_to_string( $u ), "\n" if $MD_Debug;
652 49         63 foreach my $X ( @F ) {
653 77         265 my $m = $g->restriction( split /$WSEP/, $X )
654             ->modular_decomposition_EGMS;
655 77 100 66     747 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 4 50       10 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 4         5 push @{$u->{children}}, @{$m->{children}};
  4         6  
  4         14  
673             } else {
674 73         47 push @{$u->{children}}, $m;
  73         133  
675             }
676             }
677 49         123 $u = $w;
678             }
679 38 100       701 print STDERR $B, '...MD=', tree_to_string( $t ), "\n" if $MD_Debug;
680 38         31 $md --;
681 38         363 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 17697 my $g = shift;
704 36 100       82 return 'n' unless $g->check_transitive;
705 33         13337 my $s = tree_to_string( $g->modular_decomposition_EGMS );
706 33 100       241 return 'i' if $s =~ m/^primitive\[[^\]]+\]\([^\(]*$/;
707 26 100 100     108 return 'd' if $s =~ m/primitive/ and $s =~ m/complete_|linear/;
708 25 100       207 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__