1package Graph::TransitiveClosure::Matrix;
2
3use strict;
4
5use Graph::AdjacencyMatrix;
6use Graph::Matrix;
7
8sub _new {
9    my ($g, $class, $opt, $want_transitive, $want_reflexive, $want_path, $want_path_vertices) = @_;
10    my $m = Graph::AdjacencyMatrix->new($g, %$opt);
11    my @V = $g->vertices;
12    my $am = $m->adjacency_matrix;
13    my $dm; # The distance matrix.
14    my $pm; # The predecessor matrix.
15    my @di;
16    my %di; @di{ @V } = 0..$#V;
17    my @ai = @{ $am->[0] };
18    my %ai = %{ $am->[1] };
19    my @pi;
20    my %pi;
21    unless ($want_transitive) {
22	$dm = $m->distance_matrix;
23	@di = @{ $dm->[0] };
24	%di = %{ $dm->[1] };
25	$pm = Graph::Matrix->new($g);
26	@pi = @{ $pm->[0] };
27	%pi = %{ $pm->[1] };
28	for my $u (@V) {
29	    my $diu = $di{$u};
30	    my $aiu = $ai{$u};
31	    for my $v (@V) {
32		my $div = $di{$v};
33		my $aiv = $ai{$v};
34		next unless
35		    # $am->get($u, $v)
36		    vec($ai[$aiu], $aiv, 1)
37			;
38		# $dm->set($u, $v, $u eq $v ? 0 : 1)
39		$di[$diu]->[$div] = $u eq $v ? 0 : 1
40		    unless
41			defined
42			    # $dm->get($u, $v)
43			    $di[$diu]->[$div]
44			    ;
45		$pi[$diu]->[$div] = $v unless $u eq $v;
46	    }
47	}
48    }
49    # XXX (see the bits below): sometimes, being nice and clean is the
50    # wrong thing to do.  In this case, using the public API for graph
51    # transitive matrices and bitmatrices makes things awfully slow.
52    # Instead, we go straight for the jugular of the data structures.
53    for my $u (@V) {
54	my $diu = $di{$u};
55	my $aiu = $ai{$u};
56	my $didiu = $di[$diu];
57	my $aiaiu = $ai[$aiu];
58	for my $v (@V) {
59	    my $div = $di{$v};
60	    my $aiv = $ai{$v};
61	    my $didiv = $di[$div];
62	    my $aiaiv = $ai[$aiv];
63	    if (
64		# $am->get($v, $u)
65		vec($aiaiv, $aiu, 1)
66		|| ($want_reflexive && $u eq $v)) {
67		my $aivivo = $aiaiv;
68		if ($want_transitive) {
69		    if ($want_reflexive) {
70			for my $w (@V) {
71			    next if $w eq $u;
72			    my $aiw = $ai{$w};
73			    return 0
74				if  vec($aiaiu, $aiw, 1) &&
75				   !vec($aiaiv, $aiw, 1);
76			}
77			# See XXX above.
78			# for my $w (@V) {
79			#    my $aiw = $ai{$w};
80			#    if (
81			#	# $am->get($u, $w)
82			#	vec($aiaiu, $aiw, 1)
83			#	|| ($u eq $w)) {
84			#	return 0
85			#	    if $u ne $w &&
86			#		# !$am->get($v, $w)
87			#		!vec($aiaiv, $aiw, 1)
88			#		    ;
89			#	# $am->set($v, $w)
90			#	vec($aiaiv, $aiw, 1) = 1
91			#	    ;
92			#     }
93			# }
94		    } else {
95			# See XXX above.
96			# for my $w (@V) {
97			#     my $aiw = $ai{$w};
98			#     if (
99			#	# $am->get($u, $w)
100			#	vec($aiaiu, $aiw, 1)
101			#       ) {
102			#	return 0
103			#	    if $u ne $w &&
104			#		# !$am->get($v, $w)
105			#		!vec($aiaiv, $aiw, 1)
106			#		    ;
107			# 	# $am->set($v, $w)
108			# 	vec($aiaiv, $aiw, 1) = 1
109			# 	    ;
110			#     }
111			# }
112			$aiaiv |= $aiaiu;
113		    }
114		} else {
115		    if ($want_reflexive) {
116			$aiaiv |= $aiaiu;
117			vec($aiaiv, $aiu, 1) = 1;
118			# See XXX above.
119			# for my $w (@V) {
120			#     my $aiw = $ai{$w};
121			#     if (
122			# 	# $am->get($u, $w)
123			#	vec($aiaiu, $aiw, 1)
124			#	|| ($u eq $w)) {
125			#	# $am->set($v, $w)
126			#	vec($aiaiv, $aiw, 1) = 1
127			#	    ;
128			#     }
129			# }
130		    } else {
131			$aiaiv |= $aiaiu;
132			# See XXX above.
133			# for my $w (@V) {
134			#    my $aiw = $ai{$w};
135			#    if (
136			#	# $am->get($u, $w)
137			#	vec($aiaiu, $aiw, 1)
138			#       ) {
139			#	# $am->set($v, $w)
140			#	vec($aiaiv, $aiw, 1) = 1
141			#	    ;
142			#     }
143			# }
144		    }
145		}
146		if ($aiaiv ne $aivivo) {
147		    $ai[$aiv] = $aiaiv;
148		    $aiaiu = $aiaiv if $u eq $v;
149		}
150	    }
151	    if ($want_path && !$want_transitive) {
152		for my $w (@V) {
153		    my $aiw = $ai{$w};
154		    next unless
155			# See XXX above.
156			# $am->get($v, $u)
157			vec($aiaiv, $aiu, 1)
158			    &&
159			# See XXX above.
160			# $am->get($u, $w)
161			vec($aiaiu, $aiw, 1)
162			    ;
163		    my $diw = $di{$w};
164		    my ($d0, $d1a, $d1b);
165		    if (defined $dm) {
166			# See XXX above.
167			# $d0  = $dm->get($v, $w);
168			# $d1a = $dm->get($v, $u) || 1;
169			# $d1b = $dm->get($u, $w) || 1;
170			$d0  = $didiv->[$diw];
171			$d1a = $didiv->[$diu] || 1;
172			$d1b = $didiu->[$diw] || 1;
173		    } else {
174			$d1a = 1;
175			$d1b = 1;
176		    }
177		    my $d1 = $d1a + $d1b;
178		    if (!defined $d0 || ($d1 < $d0)) {
179			# print "d1 = $d1a ($v, $u) + $d1b ($u, $w) = $d1 ($v, $w) (".(defined$d0?$d0:"-").")\n";
180			# See XXX above.
181			# $dm->set($v, $w, $d1);
182			$didiv->[$diw] = $d1;
183			$pi[$div]->[$diw] = $pi[$div]->[$diu]
184			    if $want_path_vertices;
185		    }
186		}
187		# $dm->set($u, $v, 1)
188		$didiu->[$div] = 1
189		    if $u ne $v &&
190		       # $am->get($u, $v)
191		       vec($aiaiu, $aiv, 1)
192			   &&
193		       # !defined $dm->get($u, $v);
194		       !defined $didiu->[$div];
195	    }
196	}
197    }
198    return 1 if $want_transitive;
199    my %V; @V{ @V } = @V;
200    $am->[0] = \@ai;
201    $am->[1] = \%ai;
202    if (defined $dm) {
203	$dm->[0] = \@di;
204	$dm->[1] = \%di;
205    }
206    if (defined $pm) {
207	$pm->[0] = \@pi;
208	$pm->[1] = \%pi;
209    }
210    bless [ $am, $dm, $pm, \%V ], $class;
211}
212
213sub new {
214    my ($class, $g, %opt) = @_;
215    my %am_opt = (distance_matrix => 1);
216    if (exists $opt{attribute_name}) {
217	$am_opt{attribute_name} = $opt{attribute_name};
218	delete $opt{attribute_name};
219    }
220    if ($opt{distance_matrix}) {
221	$am_opt{distance_matrix} = $opt{distance_matrix};
222    }
223    delete $opt{distance_matrix};
224    if (exists $opt{path}) {
225	$opt{path_length}   = $opt{path};
226	$opt{path_vertices} = $opt{path};
227	delete $opt{path};
228    }
229    my $want_path_length;
230    if (exists $opt{path_length}) {
231	$want_path_length = $opt{path_length};
232	delete $opt{path_length};
233    }
234    my $want_path_vertices;
235    if (exists $opt{path_vertices}) {
236	$want_path_vertices = $opt{path_vertices};
237	delete $opt{path_vertices};
238    }
239    my $want_reflexive;
240    if (exists $opt{reflexive}) {
241	$want_reflexive = $opt{reflexive};
242	delete $opt{reflexive};
243    }
244    my $want_transitive;
245    if (exists $opt{is_transitive}) {
246	$want_transitive = $opt{is_transitive};
247	$am_opt{is_transitive} = $want_transitive;
248	delete $opt{is_transitive};
249    }
250    die "Graph::TransitiveClosure::Matrix::new: Unknown options: @{[map { qq['$_' => $opt{$_}]} keys %opt]}"
251	if keys %opt;
252    $want_reflexive = 1 unless defined $want_reflexive;
253    my $want_path = $want_path_length || $want_path_vertices;
254    # $g->expect_dag if $want_path;
255    _new($g, $class,
256	 \%am_opt,
257	 $want_transitive, $want_reflexive,
258	 $want_path, $want_path_vertices);
259}
260
261sub has_vertices {
262    my $tc = shift;
263    for my $v (@_) {
264	return 0 unless exists $tc->[3]->{ $v };
265    }
266    return 1;
267}
268
269sub is_reachable {
270    my ($tc, $u, $v) = @_;
271    return undef unless $tc->has_vertices($u, $v);
272    return 1 if $u eq $v;
273    $tc->[0]->get($u, $v);
274}
275
276sub is_transitive {
277    if (@_ == 1) {	# Any graph.
278	__PACKAGE__->new($_[0], is_transitive => 1);	# Scary.
279    } else {		# A TC graph.
280	my ($tc, $u, $v) = @_;
281	return undef unless $tc->has_vertices($u, $v);
282	$tc->[0]->get($u, $v);
283    }
284}
285
286sub vertices {
287    my $tc = shift;
288    values %{ $tc->[3] };
289}
290
291sub path_length {
292    my ($tc, $u, $v) = @_;
293    return undef unless $tc->has_vertices($u, $v);
294    return 0 if $u eq $v;
295    $tc->[1]->get($u, $v);
296}
297
298sub path_predecessor {
299    my ($tc, $u, $v) = @_;
300    return undef if $u eq $v;
301    return undef unless $tc->has_vertices($u, $v);
302    $tc->[2]->get($u, $v);
303}
304
305sub path_vertices {
306    my ($tc, $u, $v) = @_;
307    return unless $tc->is_reachable($u, $v);
308    return wantarray ? () : 0 if $u eq $v;
309    my @v = ( $u );
310    while ($u ne $v) {
311	last unless defined($u = $tc->path_predecessor($u, $v));
312	push @v, $u;
313    }
314    $tc->[2]->set($u, $v, [ @v ]) if @v;
315    return @v;
316}
317
3181;
319__END__
320=pod
321
322=head1 NAME
323
324Graph::TransitiveClosure::Matrix - create and query transitive closure of graph
325
326=head1 SYNOPSIS
327
328    use Graph::TransitiveClosure::Matrix;
329    use Graph::Directed; # or Undirected
330
331    my $g  = Graph::Directed->new;
332    $g->add_...(); # build $g
333
334    # Compute the transitive closure matrix.
335    my $tcm = Graph::TransitiveClosure::Matrix->new($g);
336
337    # Being reflexive is the default,
338    # meaning that null transitions are included.
339    my $tcm = Graph::TransitiveClosure::Matrix->new($g, reflexive => 1);
340    $tcm->is_reachable($u, $v)
341
342    # is_reachable(u, v) is always reflexive.
343    $tcm->is_reachable($u, $v)
344
345    # The reflexivity of is_transitive(u, v) depends of the reflexivity
346    # of the transitive closure.
347    $tcg->is_transitive($u, $v)
348
349    my $tcm = Graph::TransitiveClosure::Matrix->new($g, path_length => 1);
350    my $n = $tcm->path_length($u, $v)
351
352    my $tcm = Graph::TransitiveClosure::Matrix->new($g, path_vertices => 1);
353    my @v = $tcm->path_vertices($u, $v)
354
355    my $tcm =
356        Graph::TransitiveClosure::Matrix->new($g,
357                                              attribute_name => 'length');
358    my $n = $tcm->path_length($u, $v)
359
360    my @v = $tcm->vertices
361
362=head1 DESCRIPTION
363
364You can use C<Graph::TransitiveClosure::Matrix> to compute the
365transitive closure matrix of a graph and optionally also the minimum
366paths (lengths and vertices) between vertices, and after that query
367the transitiveness between vertices by using the C<is_reachable()> and
368C<is_transitive()> methods, and the paths by using the
369C<path_length()> and C<path_vertices()> methods.
370
371If you modify the graph after computing its transitive closure,
372the transitive closure and minimum paths may become invalid.
373
374=head1 Methods
375
376=head2 Class Methods
377
378=over 4
379
380=item new($g)
381
382Construct the transitive closure matrix of the graph $g.
383
384=item new($g, options)
385
386Construct the transitive closure matrix of the graph $g with options
387as a hash. The known options are
388
389=over 8
390
391=item C<attribute_name> => I<attribute_name>
392
393By default the edge attribute used for distance is C<w>.  You can
394change that by giving another attribute name with the C<attribute_name>
395attribute to the new() constructor.
396
397=item reflexive => boolean
398
399By default the transitive closure matrix is not reflexive: that is,
400the adjacency matrix has zeroes on the diagonal.  To have ones on
401the diagonal, use true for the C<reflexive> option.
402
403B<NOTE>: this behaviour has changed from Graph 0.2xxx: transitive
404closure graphs were by default reflexive.
405
406=item path_length => boolean
407
408By default the path lengths are not computed, only the boolean transitivity.
409By using true for C<path_length> also the path lengths will be computed,
410they can be retrieved using the path_length() method.
411
412=item path_vertices => boolean
413
414By default the paths are not computed, only the boolean transitivity.
415By using true for C<path_vertices> also the paths will be computed,
416they can be retrieved using the path_vertices() method.
417
418=back
419
420=back
421
422=head2 Object Methods
423
424=over 4
425
426=item is_reachable($u, $v)
427
428Return true if the vertex $v is reachable from the vertex $u,
429or false if not.
430
431=item path_length($u, $v)
432
433Return the minimum path length from the vertex $u to the vertex $v,
434or undef if there is no such path.
435
436=item path_vertices($u, $v)
437
438Return the minimum path (as a list of vertices) from the vertex $u to
439the vertex $v, or an empty list if there is no such path, OR also return
440an empty list if $u equals $v.
441
442=item has_vertices($u, $v, ...)
443
444Return true if the transitive closure matrix has all the listed vertices,
445false if not.
446
447=item is_transitive($u, $v)
448
449Return true if the vertex $v is transitively reachable from the vertex $u,
450false if not.
451
452=item vertices
453
454Return the list of vertices in the transitive closure matrix.
455
456=item path_predecessor
457
458Return the predecessor of vertex $v in the transitive closure path
459going back to vertex $u.
460
461=back
462
463=head1 RETURN VALUES
464
465For path_length() the return value will be the sum of the appropriate
466attributes on the edges of the path, C<weight> by default.  If no
467attribute has been set, one (1) will be assumed.
468
469If you try to ask about vertices not in the graph, undefs and empty
470lists will be returned.
471
472=head1 ALGORITHM
473
474The transitive closure algorithm used is Warshall and Floyd-Warshall
475for the minimum paths, which is O(V**3) in time, and the returned
476matrices are O(V**2) in space.
477
478=head1 SEE ALSO
479
480L<Graph::AdjacencyMatrix>
481
482=head1 AUTHOR AND COPYRIGHT
483
484Jarkko Hietaniemi F<jhi@iki.fi>
485
486=head1 LICENSE
487
488This module is licensed under the same terms as Perl itself.
489
490=cut
491