diff options
Diffstat (limited to 'perllib/Graph/AdjacencyMap.pm')
| -rw-r--r-- | perllib/Graph/AdjacencyMap.pm | 473 |
1 files changed, 473 insertions, 0 deletions
diff --git a/perllib/Graph/AdjacencyMap.pm b/perllib/Graph/AdjacencyMap.pm new file mode 100644 index 00000000..d2245da6 --- /dev/null +++ b/perllib/Graph/AdjacencyMap.pm @@ -0,0 +1,473 @@ +package Graph::AdjacencyMap; + +use strict; + +require Exporter; +use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS); +@ISA = qw(Exporter); +@EXPORT_OK = qw(_COUNT _MULTI _COUNTMULTI _GEN_ID + _HYPER _UNORD _UNIQ _REF _UNORDUNIQ _UNIONFIND _LIGHT + _n _f _a _i _s _p _g _u _ni _nc _na _nm); +%EXPORT_TAGS = + (flags => [qw(_COUNT _MULTI _COUNTMULTI _GEN_ID + _HYPER _UNORD _UNIQ _REF _UNORDUNIQ _UNIONFIND _LIGHT)], + fields => [qw(_n _f _a _i _s _p _g _u _ni _nc _na _nm)]); + +sub _COUNT () { 0x00000001 } +sub _MULTI () { 0x00000002 } +sub _COUNTMULTI () { _COUNT|_MULTI } +sub _HYPER () { 0x00000004 } +sub _UNORD () { 0x00000008 } +sub _UNIQ () { 0x00000010 } +sub _REF () { 0x00000020 } +sub _UNORDUNIQ () { _UNORD|_UNIQ } +sub _UNIONFIND () { 0x00000040 } +sub _LIGHT () { 0x00000080 } + +my $_GEN_ID = 0; + +sub _GEN_ID () { \$_GEN_ID } + +sub _ni () { 0 } # Node index. +sub _nc () { 1 } # Node count. +sub _na () { 2 } # Node attributes. +sub _nm () { 3 } # Node map. + +sub _n () { 0 } # Next id. +sub _f () { 1 } # Flags. +sub _a () { 2 } # Arity. +sub _i () { 3 } # Index to path. +sub _s () { 4 } # Successors / Path to Index. +sub _p () { 5 } # Predecessors. +sub _g () { 6 } # Graph (AdjacencyMap::Light) + +sub _V () { 2 } # Graph::_V() + +sub _new { + my $class = shift; + my $map = bless [ 0, @_ ], $class; + return $map; +} + +sub _ids { + my $m = shift; + return $m->[ _i ]; +} + +sub has_paths { + my $m = shift; + return defined $m->[ _i ] && keys %{ $m->[ _i ] }; +} + +sub _dump { + my $d = Data::Dumper->new([$_[0]],[ref $_[0]]); + defined wantarray ? $d->Dump : print $d->Dump; +} + +sub _del_id { + my ($m, $i) = @_; + my @p = $m->_get_id_path( $i ); + $m->del_path( @p ) if @p; +} + +sub _new_node { + my ($m, $n, $id) = @_; + my $f = $m->[ _f ]; + my $i = $m->[ _n ]++; + if (($f & _MULTI)) { + $id = 0 if $id eq _GEN_ID; + $$n = [ $i, 0, undef, { $id => { } } ]; + } elsif (($f & _COUNT)) { + $$n = [ $i, 1 ]; + } else { + $$n = $i; + } + return $i; +} + +sub _inc_node { + my ($m, $n, $id) = @_; + my $f = $m->[ _f ]; + if (($f & _MULTI)) { + if ($id eq _GEN_ID) { + $$n->[ _nc ]++ + while exists $$n->[ _nm ]->{ $$n->[ _nc ] }; + $id = $$n->[ _nc ]; + } + $$n->[ _nm ]->{ $id } = { }; + } elsif (($f & _COUNT)) { + $$n->[ _nc ]++; + } + return $id; +} + +sub __get_path_node { + my $m = shift; + my ($p, $k); + my $f = $m->[ _f ]; + @_ = sort @_ if ($f & _UNORD); + if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. + return unless exists $m->[ _s ]->{ $_[0] }; + $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ]; + $k = [ $_[0], $_[1] ]; + } else { + ($p, $k) = $m->__has_path( @_ ); + } + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + return ( exists $p->[-1]->{ $l }, $p->[-1]->{ $l }, $p, $k, $l ); +} + +sub set_path_by_multi_id { + my $m = shift; + my ($p, $k) = $m->__set_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + return $m->__set_path_node( $p, $l, @_ ); +} + +sub get_multi_ids { + my $m = shift; + my $f = $m->[ _f ]; + return () unless ($f & _MULTI); + my ($e, $n) = $m->__get_path_node( @_ ); + return $e ? keys %{ $n->[ _nm ] } : (); +} + +sub _has_path_attrs { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + return keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } } ? 1 : 0; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return ref $n && $#$n == _na && keys %{ $n->[ _na ] } ? 1 : 0; + } +} + +sub _set_path_attrs { + my $m = shift; + my $f = $m->[ _f ]; + my $attr = pop; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( @_ ); + push @_, $id if ($f & _MULTI); + my ($p, $k) = $m->__set_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + $m->__set_path_node( $p, $l, @_ ) unless exists $p->[-1]->{ $l }; + if (($f & _MULTI)) { + $p->[-1]->{ $l }->[ _nm ]->{ $id } = $attr; + } else { + # Extend the node if it is a simple id node. + $p->[-1]->{ $l } = [ $p->[-1]->{ $l }, 1 ] unless ref $p->[-1]->{ $l }; + $p->[-1]->{ $l }->[ _na ] = $attr; + } +} + +sub _has_path_attr { + my $m = shift; + my $f = $m->[ _f ]; + my $attr = pop; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + exists $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr }; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return ref $n && $#$n == _na ? exists $n->[ _na ]->{ $attr } : undef; + } +} + +sub _set_path_attr { + my $m = shift; + my $f = $m->[ _f ]; + my $val = pop; + my $attr = pop; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + my ($p, $k); + $m->__attr( \@_ ); # _LIGHT maps need this to get upgraded when needed. + push @_, $id if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_REF|_UNIQ|_HYPER|_UNIQ))) { + $m->[ _s ]->{ $_[0] } ||= { }; + $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ]; + $k = [ $_[0], $_[1] ]; + } else { + ($p, $k) = $m->__set_path( @_ ); + } + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + $m->__set_path_node( $p, $l, @_ ) unless exists $p->[-1]->{ $l }; + if (($f & _MULTI)) { + $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr } = $val; + } else { + # Extend the node if it is a simple id node. + $p->[-1]->{ $l } = [ $p->[-1]->{ $l }, 1 ] unless ref $p->[-1]->{ $l }; + $p->[-1]->{ $l }->[ _na ]->{ $attr } = $val; + } + return $val; +} + +sub _get_path_attrs { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + $p->[-1]->{ $l }->[ _nm ]->{ $id }; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return unless $e; + return $n->[ _na ] if ref $n && $#$n == _na; + return; + } +} + +sub _get_path_attr { + my $m = shift; + my $f = $m->[ _f ]; + my $attr = pop; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + return $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr }; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return ref $n && $#$n == _na ? $n->[ _na ]->{ $attr } : undef; + } +} + +sub _get_path_attr_names { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } }; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return keys %{ $n->[ _na ] } if ref $n && $#$n == _na; + return; + } +} + +sub _get_path_attr_values { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + values %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } }; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return values %{ $n->[ _na ] } if ref $n && $#$n == _na; + return; + } +} + +sub _del_path_attrs { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + delete $p->[-1]->{ $l }->[ _nm ]->{ $id }; + unless (keys %{ $p->[-1]->{ $l }->[ _nm ] } || + (defined $p->[-1]->{ $l }->[ _na ] && + keys %{ $p->[-1]->{ $l }->[ _na ] })) { + delete $p->[-1]->{ $l }; + } + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + if (ref $n) { + $e = _na == $#$n && keys %{ $n->[ _na ] } ? 1 : 0; + $#$n = _na - 1; + return $e; + } else { + return 0; + } + } +} + +sub _del_path_attr { + my $m = shift; + my $f = $m->[ _f ]; + my $attr = pop; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + delete $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr }; + $m->_del_path_attrs( @_, $id ) + unless keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } }; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + if (ref $n && $#$n == _na && exists $n->[ _na ]->{ $attr }) { + delete $n->[ _na ]->{ $attr }; + return 1; + } else { + return 0; + } + } +} + +sub _is_COUNT { $_[0]->[ _f ] & _COUNT } +sub _is_MULTI { $_[0]->[ _f ] & _MULTI } +sub _is_HYPER { $_[0]->[ _f ] & _HYPER } +sub _is_UNORD { $_[0]->[ _f ] & _UNORD } +sub _is_UNIQ { $_[0]->[ _f ] & _UNIQ } +sub _is_REF { $_[0]->[ _f ] & _REF } + +sub __arg { + my $m = shift; + my $f = $m->[ _f ]; + my @a = @{$_[0]}; + if ($f & _UNIQ) { + my %u; + if ($f & _UNORD) { + @u{ @a } = @a; + @a = values %u; + } else { + my @u; + for my $e (@a) { + push @u, $e if $u{$e}++ == 0; + } + @a = @u; + } + } + # Alphabetic or numeric sort, does not matter as long as it unifies. + @{$_[0]} = ($f & _UNORD) ? sort @a : @a; +} + +sub _successors { + my $E = shift; + my $g = shift; + my $V = $g->[ _V ]; + map { my @v = @{ $_->[ 1 ] }; + shift @v; + map { $V->_get_id_path($_) } @v } $g->_edges_from( @_ ); +} + +sub _predecessors { + my $E = shift; + my $g = shift; + my $V = $g->[ _V ]; + if (wantarray) { + map { my @v = @{ $_->[ 1 ] }; + pop @v; + map { $V->_get_id_path($_) } @v } $g->_edges_to( @_ ); + } else { + return $g->_edges_to( @_ ); + } +} + +1; +__END__ +=pod + +=head1 NAME + +Graph::AdjacencyMap - create and a map of graph vertices or edges + +=head1 SYNOPSIS + + Internal. + +=head1 DESCRIPTION + +B<This module is meant for internal use by the Graph module.> + +=head2 Object Methods + +=over 4 + +=item del_path(@id) + +Delete a Map path by ids. + +=item del_path_by_multi_id($id) + +Delete a Map path by a multi(vertex) id. + +=item get_multi_ids + +Return the multi ids. + +=item has_path(@id) + +Return true if the Map has the path by ids, false if not. + +=item has_paths + +Return true if the Map has any paths, false if not. + +=item has_path_by_multi_id($id) + +Return true ifd the a Map has the path by a multi(vertex) id, false if not. + +=item paths + +Return all the paths of the Map. + +=item set_path(@id) + +Set the path by @ids. + +=item set_path_by_multi_id + +Set the path in the Map by the multi id. + +=back + +=head1 AUTHOR AND COPYRIGHT + +Jarkko Hietaniemi F<jhi@iki.fi> + +=head1 LICENSE + +This module is licensed under the same terms as Perl itself. + +=cut |