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