perllib/Graph/AdjacencyMap.pm

   1 package Graph::AdjacencyMap;
   2
   3 use strict;
   4
   5 require Exporter;
   6 use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS);
   7 @ISA = qw(Exporter);
   8 @EXPORT_OK   = qw(_COUNT _MULTI _COUNTMULTI _GEN_ID
   9                   _HYPER _UNORD _UNIQ _REF _UNORDUNIQ _UNIONFIND _LIGHT
  10                   _n _f _a _i _s _p _g _u _ni _nc _na _nm);
  11 %EXPORT_TAGS =
  12     (flags =>  [qw(_COUNT _MULTI _COUNTMULTI _GEN_ID
  13                    _HYPER _UNORD _UNIQ _REF _UNORDUNIQ _UNIONFIND _LIGHT)],
  14      fields => [qw(_n _f _a _i _s _p _g _u _ni _nc _na _nm)]);
  15
  16 sub _COUNT      () {  0x00000001   }
  17 sub _MULTI      () {  0x00000002   }
  18 sub _COUNTMULTI () { _COUNT|_MULTI }
  19 sub _HYPER      () {  0x00000004   }
  20 sub _UNORD      () {  0x00000008   }
  21 sub _UNIQ       () {  0x00000010   }
  22 sub _REF        () {  0x00000020   }
  23 sub _UNORDUNIQ  () { _UNORD|_UNIQ  }
  24 sub _UNIONFIND  () {  0x00000040   }
  25 sub _LIGHT      () {  0x00000080   }
  26
  27 my $_GEN_ID = 0;
  28
  29 sub _GEN_ID () { \$_GEN_ID }
  30
  31 sub _ni () { 0 } # Node index.
  32 sub _nc () { 1 } # Node count.
  33 sub _na () { 2 } # Node attributes.
  34 sub _nm () { 3 } # Node map.
  35
  36 sub _n () { 0 } # Next id.
  37 sub _f () { 1 } # Flags.
  38 sub _a () { 2 } # Arity.
  39 sub _i () { 3 } # Index to path.
  40 sub _s () { 4 } # Successors / Path to Index.
  41 sub _p () { 5 } # Predecessors.
  42 sub _g () { 6 } # Graph (AdjacencyMap::Light)
  43
  44 sub _V () { 2 }  # Graph::_V()
  45
  46 sub _new {
  47     my $class = shift;
  48     my $map = bless [ 0, @_ ], $class;
  49     return $map;
  50 }
  51
  52 sub _ids {
  53     my $m = shift;
  54     return $m->[ _i ];
  55 }
  56
  57 sub has_paths {
  58     my $m = shift;
  59     return defined $m->[ _i ] && keys %{ $m->[ _i ] };
  60 }
  61
  62 sub _dump {
  63     my $d = Data::Dumper->new([$_[0]],[ref $_[0]]);
  64     defined wantarray ? $d->Dump : print $d->Dump;
  65 }
  66
  67 sub _del_id {
  68     my ($m, $i) = @_;
  69     my @p = $m->_get_id_path( $i );
  70     $m->del_path( @p ) if @p;
  71 }
  72
  73 sub _new_node {
  74     my ($m, $n, $id) = @_;
  75     my $f = $m->[ _f ];
  76     my $i = $m->[ _n ]++;
  77     if (($f & _MULTI)) {
  78         $id = 0 if $id eq _GEN_ID;
  79         $$n = [ $i, 0, undef, { $id => { } } ];
  80     } elsif (($f & _COUNT)) {
  81         $$n = [ $i, 1 ];
  82     } else {
  83         $$n = $i;
  84     }
  85     return $i;
  86 }
  87
  88 sub _inc_node {
  89     my ($m, $n, $id) = @_;
  90     my $f = $m->[ _f ];
  91     if (($f & _MULTI)) {
  92         if ($id eq _GEN_ID) {
  93             $$n->[ _nc ]++
  94                 while exists $$n->[ _nm ]->{ $$n->[ _nc ] };
  95             $id = $$n->[ _nc ];
  96         }
  97         $$n->[ _nm ]->{ $id } = { };
  98     } elsif (($f & _COUNT)) {
  99         $$n->[ _nc ]++;
 100     }
 101     return $id;
 102 }
 103
 104 sub __get_path_node {
 105     my $m = shift;
 106     my ($p, $k);
 107     my $f = $m->[ _f ];
 108     @_ = sort @_ if ($f & _UNORD);
 109     if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
 110         return unless exists $m->[ _s ]->{ $_[0] };
 111         $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ];
 112         $k = [ $_[0], $_[1] ];
 113     } else {
 114         ($p, $k) = $m->__has_path( @_ );
 115     }
 116     return unless defined $p && defined $k;
 117     my $l = defined $k->[-1] ? $k->[-1] : "";
 118     return ( exists $p->[-1]->{ $l }, $p->[-1]->{ $l }, $p, $k, $l );
 119 }
 120
 121 sub set_path_by_multi_id {
 122     my $m = shift;
 123     my ($p, $k) = $m->__set_path( @_ );
 124     return unless defined $p && defined $k;
 125     my $l = defined $k->[-1] ? $k->[-1] : "";
 126     return $m->__set_path_node( $p, $l, @_ );
 127 }
 128
 129 sub get_multi_ids {
 130     my $m = shift;
 131     my $f = $m->[ _f ];
 132     return () unless ($f & _MULTI);
 133     my ($e, $n) = $m->__get_path_node( @_ );
 134     return $e ? keys %{ $n->[ _nm ] } : ();
 135 }
 136
 137 sub _has_path_attrs {
 138     my $m = shift;
 139     my $f = $m->[ _f ];
 140     my $id = pop if ($f & _MULTI);
 141     @_ = sort @_ if ($f & _UNORD);
 142     $m->__attr( \@_ );
 143     if (($f & _MULTI)) {
 144         my ($p, $k) = $m->__has_path( @_ );
 145         return unless defined $p && defined $k;
 146         my $l = defined $k->[-1] ? $k->[-1] : "";
 147         return keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } } ? 1 : 0;
 148     } else {
 149         my ($e, $n) = $m->__get_path_node( @_ );
 150         return undef unless $e;
 151         return ref $n && $#$n == _na && keys %{ $n->[ _na ] } ? 1 : 0;
 152     }
 153 }
 154
 155 sub _set_path_attrs {
 156     my $m = shift;
 157     my $f = $m->[ _f ];
 158     my $attr = pop;
 159     my $id   = pop if ($f & _MULTI);
 160     @_ = sort @_ if ($f & _UNORD);
 161     $m->__attr( @_ );
 162     push @_, $id if ($f & _MULTI);
 163     my ($p, $k) = $m->__set_path( @_ );
 164     return unless defined $p && defined $k;
 165     my $l = defined $k->[-1] ? $k->[-1] : "";
 166     $m->__set_path_node( $p, $l, @_ ) unless exists $p->[-1]->{ $l };
 167     if (($f & _MULTI)) {
 168         $p->[-1]->{ $l }->[ _nm ]->{ $id } = $attr;
 169     } else {
 170         # Extend the node if it is a simple id node.
 171         $p->[-1]->{ $l } = [ $p->[-1]->{ $l }, 1 ] unless ref $p->[-1]->{ $l };
 172         $p->[-1]->{ $l }->[ _na ] = $attr;
 173     }
 174 }
 175
 176 sub _has_path_attr {
 177     my $m = shift;
 178     my $f = $m->[ _f ];
 179     my $attr = pop;
 180     my $id   = pop if ($f & _MULTI);
 181     @_ = sort @_ if ($f & _UNORD);
 182     $m->__attr( \@_ );
 183     if (($f & _MULTI)) {
 184         my ($p, $k) = $m->__has_path( @_ );
 185         return unless defined $p && defined $k;
 186         my $l = defined $k->[-1] ? $k->[-1] : "";
 187         exists $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr };
 188     } else {
 189         my ($e, $n) = $m->__get_path_node( @_ );
 190         return undef unless $e;
 191         return ref $n && $#$n == _na ? exists $n->[ _na ]->{ $attr } : undef;
 192     }
 193 }
 194
 195 sub _set_path_attr {
 196     my $m = shift;
 197     my $f = $m->[ _f ];
 198     my $val  = pop;
 199     my $attr = pop;
 200     my $id   = pop if ($f & _MULTI);
 201     @_ = sort @_ if ($f & _UNORD);
 202     my ($p, $k);
 203     $m->__attr( \@_ ); # _LIGHT maps need this to get upgraded when needed.
 204     push @_, $id if ($f & _MULTI);
 205     @_ = sort @_ if ($f & _UNORD);
 206     if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_REF|_UNIQ|_HYPER|_UNIQ))) {
 207         $m->[ _s ]->{ $_[0] } ||= { };
 208         $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ];
 209         $k = [ $_[0], $_[1] ];
 210     } else {
 211         ($p, $k) = $m->__set_path( @_ );
 212     }
 213     return unless defined $p && defined $k;
 214     my $l = defined $k->[-1] ? $k->[-1] : "";
 215     $m->__set_path_node( $p, $l, @_ ) unless exists $p->[-1]->{ $l };
 216     if (($f & _MULTI)) {
 217         $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr } = $val;
 218     } else {
 219         # Extend the node if it is a simple id node.
 220         $p->[-1]->{ $l } = [ $p->[-1]->{ $l }, 1 ] unless ref $p->[-1]->{ $l };
 221         $p->[-1]->{ $l }->[ _na ]->{ $attr } = $val;
 222     }
 223     return $val;
 224 }
 225
 226 sub _get_path_attrs {
 227     my $m = shift;
 228     my $f = $m->[ _f ];
 229     my $id   = pop if ($f & _MULTI);
 230     @_ = sort @_ if ($f & _UNORD);
 231     $m->__attr( \@_ );
 232     if (($f & _MULTI)) {
 233         my ($p, $k) = $m->__has_path( @_ );
 234         return unless defined $p && defined $k;
 235         my $l = defined $k->[-1] ? $k->[-1] : "";
 236         $p->[-1]->{ $l }->[ _nm ]->{ $id };
 237     } else {
 238         my ($e, $n) = $m->__get_path_node( @_ );
 239         return unless $e;
 240         return $n->[ _na ] if ref $n && $#$n == _na;
 241         return;
 242     }
 243 }
 244
 245 sub _get_path_attr {
 246     my $m = shift;
 247     my $f = $m->[ _f ];
 248     my $attr = pop;
 249     my $id = pop if ($f & _MULTI);
 250     @_ = sort @_ if ($f & _UNORD);
 251     $m->__attr( \@_ );
 252     if (($f & _MULTI)) {
 253         my ($p, $k) = $m->__has_path( @_ );
 254         return unless defined $p && defined $k;
 255         my $l = defined $k->[-1] ? $k->[-1] : "";
 256         return $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr };
 257     } else {
 258         my ($e, $n) = $m->__get_path_node( @_ );
 259         return undef unless $e;
 260         return ref $n && $#$n == _na ? $n->[ _na ]->{ $attr } : undef;
 261     }
 262 }
 263
 264 sub _get_path_attr_names {
 265     my $m = shift;
 266     my $f = $m->[ _f ];
 267     my $id = pop if ($f & _MULTI);
 268     @_ = sort @_ if ($f & _UNORD);
 269     $m->__attr( \@_ );
 270     if (($f & _MULTI)) {
 271         my ($p, $k) = $m->__has_path( @_ );
 272         return unless defined $p && defined $k;
 273         my $l = defined $k->[-1] ? $k->[-1] : "";
 274         keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } };
 275     } else {
 276         my ($e, $n) = $m->__get_path_node( @_ );
 277         return undef unless $e;
 278         return keys %{ $n->[ _na ] } if ref $n && $#$n == _na;
 279         return;
 280     }
 281 }
 282
 283 sub _get_path_attr_values {
 284     my $m = shift;
 285     my $f = $m->[ _f ];
 286     my $id = pop if ($f & _MULTI);
 287     @_ = sort @_ if ($f & _UNORD);
 288     $m->__attr( \@_ );
 289     if (($f & _MULTI)) {
 290         my ($p, $k) = $m->__has_path( @_ );
 291         return unless defined $p && defined $k;
 292         my $l = defined $k->[-1] ? $k->[-1] : "";
 293         values %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } };
 294     } else {
 295         my ($e, $n) = $m->__get_path_node( @_ );
 296         return undef unless $e;
 297         return values %{ $n->[ _na ] } if ref $n && $#$n == _na;
 298         return;
 299     }
 300 }
 301
 302 sub _del_path_attrs {
 303     my $m = shift;
 304     my $f = $m->[ _f ];
 305     my $id = pop if ($f & _MULTI);
 306     @_ = sort @_ if ($f & _UNORD);
 307     $m->__attr( \@_ );
 308     if (($f & _MULTI)) {
 309         my ($p, $k) = $m->__has_path( @_ );
 310         return unless defined $p && defined $k;
 311         my $l = defined $k->[-1] ? $k->[-1] : "";
 312         delete $p->[-1]->{ $l }->[ _nm ]->{ $id };
 313         unless (keys %{ $p->[-1]->{ $l }->[ _nm ] } ||
 314                 (defined $p->[-1]->{ $l }->[ _na ] &&
 315                  keys %{ $p->[-1]->{ $l }->[ _na ] })) {
 316             delete $p->[-1]->{ $l };
 317         }
 318     } else {
 319         my ($e, $n) = $m->__get_path_node( @_ );
 320         return undef unless $e;
 321         if (ref $n) {
 322             $e = _na == $#$n && keys %{ $n->[ _na ] } ? 1 : 0;
 323             $#$n = _na - 1;
 324             return $e;
 325         } else {
 326             return 0;
 327         }
 328     }
 329 }
 330
 331 sub _del_path_attr {
 332     my $m = shift;
 333     my $f = $m->[ _f ];
 334     my $attr = pop;
 335     my $id = pop if ($f & _MULTI);
 336     @_ = sort @_ if ($f & _UNORD);
 337     $m->__attr( \@_ );
 338     if (($f & _MULTI)) {
 339         my ($p, $k) = $m->__has_path( @_ );
 340         return unless defined $p && defined $k;
 341         my $l = defined $k->[-1] ? $k->[-1] : "";
 342         delete $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr };
 343         $m->_del_path_attrs( @_, $id )
 344             unless keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } };
 345     } else {
 346         my ($e, $n) = $m->__get_path_node( @_ );
 347         return undef unless $e;
 348         if (ref $n && $#$n == _na && exists $n->[ _na ]->{ $attr }) {
 349             delete $n->[ _na ]->{ $attr };
 350             return 1;
 351         } else {
 352             return 0;
 353         }
 354     }
 355 }
 356
 357 sub _is_COUNT { $_[0]->[ _f ] & _COUNT }
 358 sub _is_MULTI { $_[0]->[ _f ] & _MULTI }
 359 sub _is_HYPER { $_[0]->[ _f ] & _HYPER }
 360 sub _is_UNORD { $_[0]->[ _f ] & _UNORD }
 361 sub _is_UNIQ  { $_[0]->[ _f ] & _UNIQ  }
 362 sub _is_REF   { $_[0]->[ _f ] & _REF   }
 363
 364 sub __arg {
 365     my $m = shift;
 366     my $f = $m->[ _f ];
 367     my @a = @{$_[0]};
 368     if ($f & _UNIQ) {
 369         my %u;
 370         if ($f & _UNORD) {
 371             @u{ @a } = @a;
 372             @a = values %u;
 373         } else {
 374             my @u;
 375             for my $e (@a) {
 376                 push @u, $e if $u{$e}++ == 0;
 377             }
 378             @a = @u;
 379         }
 380     }
 381     # Alphabetic or numeric sort, does not matter as long as it unifies.
 382     @{$_[0]} = ($f & _UNORD) ? sort @a : @a;
 383 }
 384
 385 sub _successors {
 386     my $E = shift;
 387     my $g = shift;
 388     my $V = $g->[ _V ];
 389     map { my @v = @{ $_->[ 1 ] };
 390           shift @v;
 391           map { $V->_get_id_path($_) } @v } $g->_edges_from( @_ );
 392 }
 393
 394 sub _predecessors {
 395     my $E = shift;
 396     my $g = shift;
 397     my $V = $g->[ _V ];
 398     if (wantarray) {
 399         map { my @v = @{ $_->[ 1 ] };
 400               pop @v;
 401               map { $V->_get_id_path($_) } @v } $g->_edges_to( @_ );
 402     } else {
 403         return $g->_edges_to( @_ );
 404     }
 405 }
 406
 407 1;
 408 __END__
 409 =pod
 410
 411 =head1 NAME
 412
 413 Graph::AdjacencyMap - create and a map of graph vertices or edges
 414
 415 =head1 SYNOPSIS
 416
 417     Internal.
 418
 419 =head1 DESCRIPTION
 420
 421 B<This module is meant for internal use by the Graph module.>
 422
 423 =head2 Object Methods
 424
 425 =over 4
 426
 427 =item del_path(@id)
 428
 429 Delete a Map path by ids.
 430
 431 =item del_path_by_multi_id($id)
 432
 433 Delete a Map path by a multi(vertex) id.
 434
 435 =item get_multi_ids
 436
 437 Return the multi ids.
 438
 439 =item has_path(@id)
 440
 441 Return true if the Map has the path by ids, false if not.
 442
 443 =item has_paths
 444
 445 Return true if the Map has any paths, false if not.
 446
 447 =item has_path_by_multi_id($id)
 448
 449 Return true ifd the a Map has the path by a multi(vertex) id, false if not.
 450
 451 =item paths
 452
 453 Return all the paths of the Map.
 454
 455 =item set_path(@id)
 456
 457 Set the path by @ids.
 458
 459 =item set_path_by_multi_id
 460
 461 Set the path in the Map by the multi id.
 462
 463 =back
 464
 465 =head1 AUTHOR AND COPYRIGHT
 466
 467 Jarkko Hietaniemi F<jhi@iki.fi>
 468
 469 =head1 LICENSE
 470
 471 This module is licensed under the same terms as Perl itself.
 472
 473 =cut