perllib/Graph/TransitiveClosure/Matrix.pm

   1 package Graph::TransitiveClosure::Matrix;
   2
   3 use strict;
   4
   5 use Graph::AdjacencyMatrix;
   6 use Graph::Matrix;
   7
   8 sub _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
 213 sub 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
 261 sub has_vertices {
 262     my $tc = shift;
 263     for my $v (@_) {
 264         return 0 unless exists $tc->[3]->{ $v };
 265     }
 266     return 1;
 267 }
 268
 269 sub 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
 276 sub 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
 286 sub vertices {
 287     my $tc = shift;
 288     values %{ $tc->[3] };
 289 }
 290
 291 sub 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
 298 sub 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
 305 sub 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
 318 1;
 319 __END__
 320 =pod
 321
 322 =head1 NAME
 323
 324 Graph::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     $tcm->path_length($u, $v)
 351
 352     my $tcm = Graph::TransitiveClosure::Matrix->new($g, path_vertices => 1);
 353     $tcm->path_vertices($u, $v)
 354
 355     my $tcm = Graph::TransitiveClosure::Matrix->new($g, attribute_name => 'length');
 356     $tcm->path_length($u, $v)
 357
 358     $tcm->vertices
 359
 360 =head1 DESCRIPTION
 361
 362 You can use C<Graph::TransitiveClosure::Matrix> to compute the
 363 transitive closure matrix of a graph and optionally also the minimum
 364 paths (lengths and vertices) between vertices, and after that query
 365 the transitiveness between vertices by using the C<is_reachable()> and
 366 C<is_transitive()> methods, and the paths by using the
 367 C<path_length()> and C<path_vertices()> methods.
 368
 369 If you modify the graph after computing its transitive closure,
 370 the transitive closure and minimum paths may become invalid.
 371
 372 =head1 Methods
 373
 374 =head2 Class Methods
 375
 376 =over 4
 377
 378 =item new($g)
 379
 380 Construct the transitive closure matrix of the graph $g.
 381
 382 =item new($g, options)
 383
 384 Construct the transitive closure matrix of the graph $g with options
 385 as a hash. The known options are
 386
 387 =over 8
 388
 389 =item C<attribute_name> => I<attribute_name>
 390
 391 By default the edge attribute used for distance is C<w>.  You can
 392 change that by giving another attribute name with the C<attribute_name>
 393 attribute to the new() constructor.
 394
 395 =item reflexive => boolean
 396
 397 By default the transitive closure matrix is not reflexive: that is,
 398 the adjacency matrix has zeroes on the diagonal.  To have ones on
 399 the diagonal, use true for the C<reflexive> option.
 400
 401 B<NOTE>: this behaviour has changed from Graph 0.2xxx: transitive
 402 closure graphs were by default reflexive.
 403
 404 =item path_length => boolean
 405
 406 By default the path lengths are not computed, only the boolean transitivity.
 407 By using true for C<path_length> also the path lengths will be computed,
 408 they can be retrieved using the path_length() method.
 409
 410 =item path_vertices => boolean
 411
 412 By default the paths are not computed, only the boolean transitivity.
 413 By using true for C<path_vertices> also the paths will be computed,
 414 they can be retrieved using the path_vertices() method.
 415
 416 =back
 417
 418 =back
 419
 420 =head2 Object Methods
 421
 422 =over 4
 423
 424 =item is_reachable($u, $v)
 425
 426 Return true if the vertex $v is reachable from the vertex $u,
 427 or false if not.
 428
 429 =item path_length($u, $v)
 430
 431 Return the minimum path length from the vertex $u to the vertex $v,
 432 or undef if there is no such path.
 433
 434 =item path_vertices($u, $v)
 435
 436 Return the minimum path (as a list of vertices) from the vertex $u to
 437 the vertex $v, or an empty list if there is no such path, OR also return
 438 an empty list if $u equals $v.
 439
 440 =item has_vertices($u, $v, ...)
 441
 442 Return true if the transitive closure matrix has all the listed vertices,
 443 false if not.
 444
 445 =item is_transitive($u, $v)
 446
 447 Return true if the vertex $v is transitively reachable from the vertex $u,
 448 false if not.
 449
 450 =item vertices
 451
 452 Return the list of vertices in the transitive closure matrix.
 453
 454 =item path_predecessor
 455
 456 Return the predecessor of vertex $v in the transitive closure path
 457 going back to vertex $u.
 458
 459 =back
 460
 461 =head1 RETURN VALUES
 462
 463 For path_length() the return value will be the sum of the appropriate
 464 attributes on the edges of the path, C<weight> by default.  If no
 465 attribute has been set, one (1) will be assumed.
 466
 467 If you try to ask about vertices not in the graph, undefs and empty
 468 lists will be returned.
 469
 470 =head1 ALGORITHM
 471
 472 The transitive closure algorithm used is Warshall and Floyd-Warshall
 473 for the minimum paths, which is O(V**3) in time, and the returned
 474 matrices are O(V**2) in space.
 475
 476 =head1 SEE ALSO
 477
 478 L<Graph::AdjacencyMatrix>
 479
 480 =head1 AUTHOR AND COPYRIGHT
 481
 482 Jarkko Hietaniemi F<jhi@iki.fi>
 483
 484 =head1 LICENSE
 485
 486 This module is licensed under the same terms as Perl itself.
 487
 488 =cut