1package Graph::TransitiveClosure::Matrix;
2
3use strict;
4use warnings;
5
6use Graph::AdjacencyMatrix;
7use Graph::Matrix;
8use Scalar::Util qw(weaken);
9use List::Util qw(min);
10
11sub _A() { 0 } # adjacency
12sub _D() { 1 } # distance
13sub _S() { 2 } # successors
14sub _V() { 3 } # vertices
15sub _G() { 4 } # the original graph (OG)
16
17sub _new {
18    my ($g, $class, $am_opt, $want_transitive, $want_reflexive, $want_path, $want_path_vertices, $want_path_count) = @_;
19    my $m = Graph::AdjacencyMatrix->new($g, %$am_opt);
20    my @V = $g->vertices;
21    my %v2i; @v2i{ @V } = 0..$#V; # paths are in array -> stable ordering
22    my $am = $m->adjacency_matrix;
23    $am->[1] = \%v2i;
24    my ($dm, @di); # The distance matrix.
25    my ($sm, @si); # The successor matrix.
26    # directly use (not via API) arrays of bit-vectors etc for speed.
27    # the API is so low-level it adds no clarity anyway
28    my @ai = @{ $am->[0] };
29    my $multi = $g->multiedged;
30    unless ($want_transitive) {
31	$dm = $m->distance_matrix || Graph::Matrix->new($g); # if no distance_matrix in AM, we make our own
32	if ($want_path_count) {
33	    # force defined
34	    @di = map [ (0) x @V ], 0..$#V;
35	} else {
36	    @di = @{ $dm->[0] };
37	}
38	$sm = Graph::Matrix->new($g);
39	$dm->[1] = $sm->[1] = \%v2i;
40	@si = @{ $sm->[0] };
41	for (my $iu = $#V; $iu >= 0; $iu--) {
42	    vec($ai[$iu], $iu, 1) = 1 if $want_reflexive;
43	    for (my $iv = $#V; $iv >= 0; $iv--) {
44		next unless vec($ai[$iu], $iv, 1);
45		if ($want_path_count or !defined $di[$iu][$iv]) {
46		    $di[$iu][$iv] = $iu == $iv ? 0 : 1;
47		} elsif ($multi and ref($di[$iu][$iv]) eq 'HASH') {
48		    $di[$iu][$iv] = min values %{ $di[$iu][$iv] };
49		}
50		$si[$iu]->[$iv] = $V[$iv] unless $iu == $iv;
51	    }
52	}
53    }
54    # naming here is u = start, v = midpoint, w = endpoint
55    for (my $iv = $#V; $iv >= 0; $iv--) {
56	my $div = $di[$iv];
57	my $aiv = $ai[$iv];
58	for (my $iu = $#V; $iu >= 0; $iu--) {
59	    my $aiu = $ai[$iu];
60	    next if !vec($aiu, $iv, 1);
61	    if ($want_transitive) {
62		for (my $iw = $#V; $iw >= 0; $iw--) {
63		    return 0
64			if  $iw != $iv &&
65			    vec($aiv, $iw, 1) &&
66			   !vec($aiu, $iw, 1);
67		}
68		next;
69	    }
70	    my $aiuo = $aiu;
71	    $aiu |= $aiv;
72	    if ($aiu ne $aiuo) {
73		$ai[$iu] = $aiu;
74		$aiv = $aiu if $iv == $iu;
75	    }
76	    next if !$want_path;
77	    my $diu = $di[$iu];
78	    my $d1a = $diu->[$iv];
79	    for (my $iw = $#V; $iw >= 0; $iw--) {
80		next unless vec($aiv, $iw, 1);
81		if ($want_path_count) {
82		    $diu->[$iw]++ if $iu != $iv and $iv != $iw and $iw != $iu;
83		    next;
84		}
85		my $d0  = $diu->[$iw];
86		my $d1b = $div->[$iw];
87		my $d1 = $d1a + $d1b;
88		if (!defined $d0 || ($d1 < $d0)) {
89		    # print "d1 = $d1a ($V[$iu], $V[$iv]) + $d1b ($V[$iv], $V[$iw]) = $d1 ($V[$iu], $V[$iw]) (".(defined$d0?$d0:"-").") (propagate=".($aiu ne $aiuo?1:0).")\n";
90		    $diu->[$iw] = $d1;
91		    $si[$iu]->[$iw] = $si[$iu]->[$iv]
92			if $want_path_vertices;
93		}
94	    }
95	}
96    }
97    return 1 if $want_transitive;
98    my %V; @V{ @V } = @V;
99    $am->[0] = \@ai;
100    $dm->[0] = \@di if defined $dm;
101    $sm->[0] = \@si if defined $sm;
102    weaken(my $og = $g);
103    bless [ $am, $dm, $sm, \%V, $og ], $class;
104}
105
106sub new {
107    my ($class, $g, %opt) = @_;
108    my %am_opt = (distance_matrix => 1);
109    $am_opt{attribute_name} = delete $opt{attribute_name}
110	if exists $opt{attribute_name};
111    $am_opt{distance_matrix} = delete $opt{distance_matrix}
112	if $opt{distance_matrix};
113    $opt{path_length} = $opt{path_vertices} = delete $opt{path}
114	if exists $opt{path};
115    my $want_path_length = delete $opt{path_length};
116    my $want_path_count = delete $opt{path_count};
117    my $want_path_vertices = delete $opt{path_vertices};
118    my $want_reflexive = delete $opt{reflexive};
119    $am_opt{is_transitive} = my $want_transitive = delete $opt{is_transitive}
120	if exists $opt{is_transitive};
121    Graph::_opt_unknown(\%opt);
122    $want_reflexive = 1 unless defined $want_reflexive;
123    my $want_path = $want_path_length || $want_path_vertices || $want_path_count;
124    # $g->expect_dag if $want_path;
125    $am_opt{distance_matrix} = 0 if $want_path_count;
126    _new($g, $class,
127	 \%am_opt,
128	 $want_transitive, $want_reflexive,
129	 $want_path, $want_path_vertices, $want_path_count);
130}
131
132sub has_vertices {
133    my $tc = shift;
134    for my $v (@_) {
135	return 0 unless exists $tc->[ _V ]->{ $v };
136    }
137    return 1;
138}
139
140sub is_reachable {
141    my ($tc, $u, $v) = @_;
142    return undef unless $tc->has_vertices($u, $v);
143    return 1 if $u eq $v;
144    $tc->[ _A ]->get($u, $v);
145}
146
147sub is_transitive {
148    return __PACKAGE__->new($_[0], is_transitive => 1) if @_ == 1; # Any graph
149    # A TC graph
150    my ($tc, $u, $v) = @_;
151    return undef unless $tc->has_vertices($u, $v);
152    $tc->[ _A ]->get($u, $v);
153}
154
155sub vertices {
156    my $tc = shift;
157    values %{ $tc->[3] };
158}
159
160sub path_length {
161    my ($tc, $u, $v) = @_;
162    return undef unless $tc->has_vertices($u, $v);
163    return 0 if $u eq $v;
164    $tc->[ _D ]->get($u, $v);
165}
166
167sub path_successor {
168    my ($tc, $u, $v) = @_;
169    return undef if $u eq $v;
170    return undef unless $tc->has_vertices($u, $v);
171    $tc->[ _S ]->get($u, $v);
172}
173
174sub path_vertices {
175    my ($tc, $u, $v) = @_;
176    return unless $tc->is_reachable($u, $v);
177    return wantarray ? () : 0 if $u eq $v;
178    my @v = ( $u );
179    while ($u ne $v) {
180	last unless defined($u = $tc->path_successor($u, $v));
181	push @v, $u;
182    }
183    $tc->[ _S ]->set($u, $v, [ @v ]) if @v;
184    return @v;
185}
186
187sub all_paths {
188    my ($tc, $u, $v, $seen) = @_;
189    return if $u eq $v;
190    $seen ||= {};
191    return if exists $seen->{$u};
192    $seen = { %$seen, $u => undef }; # accumulate, but don't mutate
193    my @found;
194    push @found, [$u, $v] if $tc->[ _G ]->has_edge($u, $v);
195    push @found,
196        map [$u, @$_],
197        map $tc->all_paths($_, $v, $seen),
198        grep $tc->is_reachable($_, $v),
199        grep $_ ne $v && $_ ne $u, $tc->[ _G ]->successors($u);
200    @found;
201}
202
2031;
204__END__
205=pod
206
207=head1 NAME
208
209Graph::TransitiveClosure::Matrix - create and query transitive closure of graph
210
211=head1 SYNOPSIS
212
213    use Graph::TransitiveClosure::Matrix;
214    use Graph::Directed; # or Undirected
215
216    my $g  = Graph::Directed->new;
217    $g->add_...(); # build $g
218
219    # Compute the transitive closure matrix.
220    my $tcm = Graph::TransitiveClosure::Matrix->new($g);
221
222    # Being reflexive is the default,
223    # meaning that null transitions are included.
224    my $tcm = Graph::TransitiveClosure::Matrix->new($g, reflexive => 1);
225    $tcm->is_reachable($u, $v)
226
227    # is_reachable(u, v) is always reflexive.
228    $tcm->is_reachable($u, $v)
229
230    # The reflexivity of is_transitive(u, v) depends on the reflexivity
231    # of the transitive closure.
232    $tcg->is_transitive($u, $v)
233
234    my $tcm = Graph::TransitiveClosure::Matrix->new($g, path_length => 1);
235    my $n = $tcm->path_length($u, $v)
236
237    my $tcm = Graph::TransitiveClosure::Matrix->new($g, path_vertices => 1);
238    my @v = $tcm->path_vertices($u, $v)
239
240    my $tcm =
241        Graph::TransitiveClosure::Matrix->new($g,
242                                              attribute_name => 'length');
243    my $n = $tcm->path_length($u, $v)
244
245    my @v = $tcm->vertices
246
247=head1 DESCRIPTION
248
249You can use C<Graph::TransitiveClosure::Matrix> to compute the
250transitive closure matrix of a graph and optionally also the minimum
251paths (lengths and vertices) between vertices, and after that query
252the transitiveness between vertices by using the C<is_reachable()> and
253C<is_transitive()> methods, and the paths by using the
254C<path_length()> and C<path_vertices()> methods.
255
256If you modify the graph after computing its transitive closure,
257the transitive closure and minimum paths may become invalid.
258
259=head1 Methods
260
261=head2 Class Methods
262
263=over 4
264
265=item new($g)
266
267Construct the transitive closure matrix of the graph $g.
268
269=item new($g, options)
270
271Construct the transitive closure matrix of the graph $g with options
272as a hash. The known options are
273
274=over 8
275
276=item C<attribute_name> => I<attribute_name>
277
278By default the edge attribute used for distance is C<weight>.  You can
279change that by giving another attribute name with the C<attribute_name>
280attribute to the new() constructor.
281
282=item reflexive => boolean
283
284By default the transitive closure matrix is not reflexive: that is,
285the adjacency matrix has zeroes on the diagonal.  To have ones on
286the diagonal, use true for the C<reflexive> option.
287
288=item path => boolean
289
290If set true, sets C<path_length> and C<path_vertices>. If either of
291those are true (and C<path_vertices> is by default), then both are
292calculated.
293
294=item path_length => boolean
295
296By default "false", but see above as overridden by default
297C<path_vertices> being true. If calculated,
298they can be retrieved using the path_length() method.
299
300=item path_vertices => boolean
301
302By default the paths are computed, with the boolean transitivity,
303they can be retrieved using the path_vertices() method.
304
305=item path_count => boolean
306
307As an alternative to setting C<path_length>, if this is true then the
308matrix will store the quantity of paths between the two vertices. This
309is still retrieved using the path_length() method. The path vertices
310will not be available. You should probably only use this on a DAG,
311and not with C<reflexive>.
312
313=back
314
315=back
316
317=head2 Object Methods
318
319=over 4
320
321=item is_reachable($u, $v)
322
323Return true if the vertex $v is reachable from the vertex $u,
324or false if not.
325
326=item path_length($u, $v)
327
328Return the minimum path length from the vertex $u to the vertex $v,
329or undef if there is no such path.
330
331=item path_vertices($u, $v)
332
333Return the minimum path (as a list of vertices) from the vertex $u to
334the vertex $v, or an empty list if there is no such path, OR also return
335an empty list if $u equals $v.
336
337=item has_vertices($u, $v, ...)
338
339Return true if the transitive closure matrix has all the listed vertices,
340false if not.
341
342=item is_transitive($u, $v)
343
344Return true if the vertex $v is transitively reachable from the vertex $u,
345false if not.
346
347=item vertices
348
349Return the list of vertices in the transitive closure matrix.
350
351=item path_successor($u, $v)
352
353Return the successor of vertex $u in the transitive closure path towards
354vertex $v.
355
356=item all_paths($u, $v)
357
358Return list of array-refs with all the paths from $u to $v. Will ignore
359self-loops.
360
361=back
362
363=head1 RETURN VALUES
364
365For path_length() the return value will be the sum of the appropriate
366attributes on the edges of the path, C<weight> by default.  If no
367attribute has been set, one (1) will be assumed.
368
369If you try to ask about vertices not in the graph, undefs and empty
370lists will be returned.
371
372=head1 ALGORITHM
373
374The transitive closure algorithm used is Warshall and Floyd-Warshall
375for the minimum paths, which is O(V**3) in time, and the returned
376matrices are O(V**2) in space.
377
378=head1 SEE ALSO
379
380L<Graph::AdjacencyMatrix>
381
382=head1 AUTHOR AND COPYRIGHT
383
384Jarkko Hietaniemi F<jhi@iki.fi>
385
386=head1 LICENSE
387
388This module is licensed under the same terms as Perl itself.
389
390=cut
391