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