procyberian/nasm
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Create a Perl library directory, and add the Graph module to it

Browse source 
Graph-0.84 from CPAN
This commit is contained in:
H. Peter Anvin 2007-08-29 17:20:09 +00:00
parent 8781c6a5f3
commit 16a76654b8
23 changed files with 10913 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
Makefile.in
View file

@ -22,7 +22,7 @@ INTERNAL_CFLAGS = -I$(srcdir) -I.
ALL_CFLAGS = $(BUILD_CFLAGS) $(INTERNAL_CFLAGS)
LDFLAGS = @LDFLAGS@
LIBS = @LIBS@
PERL = perl
PERL = perl -I$(srcdir)/perllib
INSTALL = @INSTALL@
INSTALL_PROGRAM = @INSTALL_PROGRAM@

3851
perllib/Graph.pm Normal file
View file

File diff suppressed because it is too large Load diff

2768
perllib/Graph.pod Normal file
View file

File diff suppressed because it is too large Load diff

473
perllib/Graph/AdjacencyMap.pm Normal file
View file

@ -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

253
perllib/Graph/AdjacencyMap/Heavy.pm Normal file
View file

@ -0,0 +1,253 @@
package Graph::AdjacencyMap::Heavy;
# THIS IS INTERNAL IMPLEMENTATION ONLY, NOT TO BE USED DIRECTLY.
# THE INTERFACE IS HARD TO USE AND GOING TO STAY THAT WAY AND
# ALMOST GUARANTEED TO CHANGE OR GO AWAY IN FUTURE RELEASES.
use strict;
# $SIG{__DIE__ } = sub { use Carp; confess };
# $SIG{__WARN__} = sub { use Carp; confess };
use Graph::AdjacencyMap qw(:flags :fields);
use base 'Graph::AdjacencyMap';
require overload; # for de-overloading
require Data::Dumper;
sub __set_path {
my $m = shift;
my $f = $m->[ _f ];
my $id = pop if ($f & _MULTI);
if (@_ != $m->[ _a ] && !($f & _HYPER)) {
require Carp;
Carp::confess(sprintf "Graph::AdjacencyMap::Heavy: arguments %d expected %d",
scalar @_, $m->[ _a ]);
}
my $p;
$p = ($f & _HYPER) ?
(( $m->[ _s ] ||= [ ] )->[ @_ ] ||= { }) :
( $m->[ _s ] ||= { });
my @p = $p;
my @k;
while (@_) {
my $k = shift;
my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k;
if (@_) {
$p = $p->{ $q } ||= {};
return unless $p;
push @p, $p;
}
push @k, $q;
}
return (\@p, \@k);
}
sub __set_path_node {
my ($m, $p, $l) = splice @_, 0, 3;
my $f = $m->[ _f ] ;
my $id = pop if ($f & _MULTI);
unless (exists $p->[-1]->{ $l }) {
my $i = $m->_new_node( \$p->[-1]->{ $l }, $id );
$m->[ _i ]->{ defined $i ? $i : "" } = [ @_ ];
return defined $id ? ($id eq _GEN_ID ? $$id : $id) : $i;
} else {
return $m->_inc_node( \$p->[-1]->{ $l }, $id );
}
}
sub set_path {
my $m = shift;
my $f = $m->[ _f ];
if (@_ > 1 && ($f & _UNORDUNIQ)) {
if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
else { $m->__arg(\@_) }
}
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 __has_path {
my $m = shift;
my $f = $m->[ _f ];
if (@_ != $m->[ _a ] && !($f & _HYPER)) {
require Carp;
Carp::confess(sprintf "Graph::AdjacencyMap::Heavy: arguments %d expected %d",
scalar @_, $m->[ _a ]);
}
if (@_ > 1 && ($f & _UNORDUNIQ)) {
if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
else { $m->__arg(\@_) }
}
my $p = $m->[ _s ];
return unless defined $p;
$p = $p->[ @_ ] if ($f & _HYPER);
return unless defined $p;
my @p = $p;
my @k;
while (@_) {
my $k = shift;
my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k;
if (@_) {
$p = $p->{ $q };
return unless defined $p;
push @p, $p;
}
push @k, $q;
}
return (\@p, \@k);
}
sub has_path {
my $m = shift;
my $f = $m->[ _f ];
if (@_ > 1 && ($f & _UNORDUNIQ)) {
if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
else { $m->__arg(\@_) }
}
my ($p, $k) = $m->__has_path( @_ );
return unless defined $p && defined $k;
return exists $p->[-1]->{ defined $k->[-1] ? $k->[-1] : "" };
}
sub has_path_by_multi_id {
my $m = shift;
my $f = $m->[ _f ];
my $id = pop;
if (@_ > 1 && ($f & _UNORDUNIQ)) {
if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
else { $m->__arg(\@_) }
}
my ($e, $n) = $m->__get_path_node( @_ );
return undef unless $e;
return exists $n->[ _nm ]->{ $id };
}
sub _get_path_node {
my $m = shift;
my $f = $m->[ _f ];
if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
@_ = sort @_ if ($f & _UNORD);
return unless exists $m->[ _s ]->{ $_[0] };
my $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ];
my $k = [ $_[0], $_[1] ];
my $l = $_[1];
return ( exists $p->[-1]->{ $l }, $p->[-1]->{ $l }, $p, $k, $l );
} else {
if (@_ > 1 && ($f & _UNORDUNIQ)) {
if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
else { $m->__arg(\@_) }
}
$m->__get_path_node( @_ );
}
}
sub _get_path_id {
my $m = shift;
my $f = $m->[ _f ];
my ($e, $n);
if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
@_ = sort @_ if ($f & _UNORD);
return unless exists $m->[ _s ]->{ $_[0] };
my $p = $m->[ _s ]->{ $_[0] };
$e = exists $p->{ $_[1] };
$n = $p->{ $_[1] };
} else {
($e, $n) = $m->_get_path_node( @_ );
}
return undef unless $e;
return ref $n ? $n->[ _ni ] : $n;
}
sub _get_path_count {
my $m = shift;
my $f = $m->[ _f ];
my ($e, $n) = $m->_get_path_node( @_ );
return undef unless $e && defined $n;
return
($f & _COUNT) ? $n->[ _nc ] :
($f & _MULTI) ? scalar keys %{ $n->[ _nm ] } : 1;
}
sub __attr {
my $m = shift;
if (@_) {
if (ref $_[0] && @{ $_[0] }) {
if (@{ $_[0] } != $m->[ _a ]) {
require Carp;
Carp::confess(sprintf
"Graph::AdjacencyMap::Heavy: arguments %d expected %d\n",
scalar @{ $_[0] }, $m->[ _a ]);
}
my $f = $m->[ _f ];
if (@{ $_[0] } > 1 && ($f & _UNORDUNIQ)) {
if (($f & _UNORDUNIQ) == _UNORD && @{ $_[0] } == 2) {
@{ $_[0] } = sort @{ $_[0] }
} else { $m->__arg(\@_) }
}
}
}
}
sub _get_id_path {
my ($m, $i) = @_;
my $p = defined $i ? $m->[ _i ]->{ $i } : undef;
return defined $p ? @$p : ( );
}
sub del_path {
my $m = shift;
my $f = $m->[ _f ];
if (@_ > 1 && ($f & _UNORDUNIQ)) {
if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
else { $m->__arg(\@_) }
}
my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ );
return unless $e;
my $c = ($f & _COUNT) ? --$n->[ _nc ] : 0;
if ($c == 0) {
delete $m->[ _i ]->{ ref $n ? $n->[ _ni ] : $n };
delete $p->[-1]->{ $l };
while (@$p && @$k && keys %{ $p->[-1]->{ $k->[-1] } } == 0) {
delete $p->[-1]->{ $k->[-1] };
pop @$p;
pop @$k;
}
}
return 1;
}
sub del_path_by_multi_id {
my $m = shift;
my $f = $m->[ _f ];
my $id = pop;
if (@_ > 1 && ($f & _UNORDUNIQ)) {
if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ }
else { $m->__arg(\@_) }
}
my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ );
return unless $e;
delete $n->[ _nm ]->{ $id };
unless (keys %{ $n->[ _nm ] }) {
delete $m->[ _i ]->{ $n->[ _ni ] };
delete $p->[-1]->{ $l };
while (@$p && @$k && keys %{ $p->[-1]->{ $k->[-1] } } == 0) {
delete $p->[-1]->{ $k->[-1] };
pop @$p;
pop @$k;
}
}
return 1;
}
sub paths {
my $m = shift;
return values %{ $m->[ _i ] } if defined $m->[ _i ];
wantarray ? ( ) : 0;
}
1;
__END__

247
perllib/Graph/AdjacencyMap/Light.pm Normal file
View file

@ -0,0 +1,247 @@
package Graph::AdjacencyMap::Light;
# THIS IS INTERNAL IMPLEMENTATION ONLY, NOT TO BE USED DIRECTLY.
# THE INTERFACE IS HARD TO USE AND GOING TO STAY THAT WAY AND
# ALMOST GUARANTEED TO CHANGE OR GO AWAY IN FUTURE RELEASES.
use strict;
use Graph::AdjacencyMap qw(:flags :fields);
use base 'Graph::AdjacencyMap';
use Scalar::Util qw(weaken);
use Graph::AdjacencyMap::Heavy;
use Graph::AdjacencyMap::Vertex;
sub _V () { 2 } # Graph::_V
sub _E () { 3 } # Graph::_E
sub _F () { 0 } # Graph::_F
sub _new {
my ($class, $graph, $flags, $arity) = @_;
my $m = bless [ ], $class;
$m->[ _n ] = 0;
$m->[ _f ] = $flags | _LIGHT;
$m->[ _a ] = $arity;
$m->[ _i ] = { };
$m->[ _s ] = { };
$m->[ _p ] = { };
$m->[ _g ] = $graph;
weaken $m->[ _g ]; # So that DESTROY finds us earlier.
return $m;
}
sub set_path {
my $m = shift;
my ($n, $f, $a, $i, $s, $p) = @$m;
if ($a == 2) {
@_ = sort @_ if ($f & _UNORD);
}
my $e0 = shift;
if ($a == 2) {
my $e1 = shift;
unless (exists $s->{ $e0 } && exists $s->{ $e0 }->{ $e1 }) {
$n = $m->[ _n ]++;
$i->{ $n } = [ $e0, $e1 ];
$s->{ $e0 }->{ $e1 } = $n;
$p->{ $e1 }->{ $e0 } = $n;
}
} else {
unless (exists $s->{ $e0 }) {
$n = $m->[ _n ]++;
$s->{ $e0 } = $n;
$i->{ $n } = $e0;
}
}
}
sub has_path {
my $m = shift;
my ($n, $f, $a, $i, $s) = @$m;
return 0 unless $a == @_;
my $e;
if ($a == 2) {
@_ = sort @_ if ($f & _UNORD);
$e = shift;
return 0 unless exists $s->{ $e };
$s = $s->{ $e };
}
$e = shift;
exists $s->{ $e };
}
sub _get_path_id {
my $m = shift;
my ($n, $f, $a, $i, $s) = @$m;
return undef unless $a == @_;
my $e;
if ($a == 2) {
@_ = sort @_ if ($f & _UNORD);
$e = shift;
return undef unless exists $s->{ $e };
$s = $s->{ $e };
}
$e = shift;
$s->{ $e };
}
sub _get_path_count {
my $m = shift;
my ($n, $f, $a, $i, $s) = @$m;
my $e;
if (@_ == 2) {
@_ = sort @_ if ($f & _UNORD);
$e = shift;
return undef unless exists $s->{ $e };
$s = $s->{ $e };
}
$e = shift;
return exists $s->{ $e } ? 1 : 0;
}
sub has_paths {
my $m = shift;
my ($n, $f, $a, $i, $s) = @$m;
keys %$s;
}
sub paths {
my $m = shift;
my ($n, $f, $a, $i) = @$m;
if (defined $i) {
my ($k, $v) = each %$i;
if (ref $v) {
return values %{ $i };
} else {
return map { [ $_ ] } values %{ $i };
}
} else {
return ( );
}
}
sub _get_id_path {
my $m = shift;
my ($n, $f, $a, $i) = @$m;
my $p = $i->{ $_[ 0 ] };
defined $p ? ( ref $p eq 'ARRAY' ? @$p : $p ) : ( );
}
sub del_path {
my $m = shift;
my ($n, $f, $a, $i, $s, $p) = @$m;
if (@_ == 2) {
@_ = sort @_ if ($f & _UNORD);
my $e0 = shift;
return 0 unless exists $s->{ $e0 };
my $e1 = shift;
if (defined($n = $s->{ $e0 }->{ $e1 })) {
delete $i->{ $n };
delete $s->{ $e0 }->{ $e1 };
delete $p->{ $e1 }->{ $e0 };
delete $s->{ $e0 } unless keys %{ $s->{ $e0 } };
delete $p->{ $e1 } unless keys %{ $p->{ $e1 } };
return 1;
}
} else {
my $e = shift;
if (defined($n = $s->{ $e })) {
delete $i->{ $n };
delete $s->{ $e };
return 1;
}
}
return 0;
}
sub __successors {
my $E = shift;
return wantarray ? () : 0 unless defined $E->[ _s ];
my $g = shift;
my $V = $g->[ _V ];
return wantarray ? () : 0 unless defined $V && defined $V->[ _s ];
# my $i = $V->_get_path_id( $_[0] );
my $i =
($V->[ _f ] & _LIGHT) ?
$V->[ _s ]->{ $_[0] } :
$V->_get_path_id( $_[0] );
return wantarray ? () : 0 unless defined $i && defined $E->[ _s ]->{ $i };
return keys %{ $E->[ _s ]->{ $i } };
}
sub _successors {
my $E = shift;
my $g = shift;
my @s = $E->__successors($g, @_);
if (($E->[ _f ] & _UNORD)) {
push @s, $E->__predecessors($g, @_);
my %s; @s{ @s } = ();
@s = keys %s;
}
my $V = $g->[ _V ];
return wantarray ? map { $V->[ _i ]->{ $_ } } @s : @s;
}
sub __predecessors {
my $E = shift;
return wantarray ? () : 0 unless defined $E->[ _p ];
my $g = shift;
my $V = $g->[ _V ];
return wantarray ? () : 0 unless defined $V && defined $V->[ _s ];
# my $i = $V->_get_path_id( $_[0] );
my $i =
($V->[ _f ] & _LIGHT) ?
$V->[ _s ]->{ $_[0] } :
$V->_get_path_id( $_[0] );
return wantarray ? () : 0 unless defined $i && defined $E->[ _p ]->{ $i };
return keys %{ $E->[ _p ]->{ $i } };
}
sub _predecessors {
my $E = shift;
my $g = shift;
my @p = $E->__predecessors($g, @_);
if ($E->[ _f ] & _UNORD) {
push @p, $E->__successors($g, @_);
my %p; @p{ @p } = ();
@p = keys %p;
}
my $V = $g->[ _V ];
return wantarray ? map { $V->[ _i ]->{ $_ } } @p : @p;
}
sub __attr {
# Major magic takes place here: we rebless the appropriate 'light'
# map into a more complex map and then redispatch the method.
my $m = $_[0];
my ($n, $f, $a, $i, $s, $p, $g) = @$m;
my ($k, $v) = each %$i;
my @V = @{ $g->[ _V ] };
my @E = $g->edges; # TODO: Both these (ZZZ) lines are mysteriously needed!
# ZZZ: an example of failing tests is t/52_edge_attributes.t.
if (ref $v eq 'ARRAY') { # Edges, then.
# print "Reedging.\n";
@E = $g->edges; # TODO: Both these (ZZZ) lines are mysteriously needed!
$g->[ _E ] = $m = Graph::AdjacencyMap::Heavy->_new($f, 2);
$g->add_edges( @E );
} else {
# print "Revertexing.\n";
$m = Graph::AdjacencyMap::Vertex->_new(($f & ~_LIGHT), 1);
$m->[ _n ] = $V[ _n ];
$m->[ _i ] = $V[ _i ];
$m->[ _s ] = $V[ _s ];
$m->[ _p ] = $V[ _p ];
$g->[ _V ] = $m;
}
$_[0] = $m;
goto &{ ref($m) . "::__attr" }; # Redispatch.
}
sub _is_COUNT () { 0 }
sub _is_MULTI () { 0 }
sub _is_HYPER () { 0 }
sub _is_UNIQ () { 0 }
sub _is_REF () { 0 }
1;

216
perllib/Graph/AdjacencyMap/Vertex.pm Normal file
View file

@ -0,0 +1,216 @@
package Graph::AdjacencyMap::Vertex;
# THIS IS INTERNAL IMPLEMENTATION ONLY, NOT TO BE USED DIRECTLY.
# THE INTERFACE IS HARD TO USE AND GOING TO STAY THAT WAY AND
# ALMOST GUARANTEED TO CHANGE OR GO AWAY IN FUTURE RELEASES.
use strict;
# $SIG{__DIE__ } = sub { use Carp; confess };
# $SIG{__WARN__} = sub { use Carp; confess };
use Graph::AdjacencyMap qw(:flags :fields);
use base 'Graph::AdjacencyMap';
use Scalar::Util qw(weaken);
sub _new {
my ($class, $flags, $arity) = @_;
bless [ 0, $flags, $arity ], $class;
}
require overload; # for de-overloading
sub __set_path {
my $m = shift;
my $f = $m->[ _f ];
my $id = pop if ($f & _MULTI);
if (@_ != 1) {
require Carp;
Carp::confess(sprintf "Graph::AdjacencyMap::Vertex: arguments %d expected 1", scalar @_);
}
my $p;
$p = $m->[ _s ] ||= { };
my @p = $p;
my @k;
my $k = shift;
my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k;
push @k, $q;
return (\@p, \@k);
}
sub __set_path_node {
my ($m, $p, $l) = splice @_, 0, 3;
my $f = $m->[ _f ];
my $id = pop if ($f & _MULTI);
unless (exists $p->[-1]->{ $l }) {
my $i = $m->_new_node( \$p->[-1]->{ $l }, $id );
$m->[ _i ]->{ defined $i ? $i : "" } = $_[0];
} else {
$m->_inc_node( \$p->[-1]->{ $l }, $id );
}
}
sub set_path {
my $m = shift;
my $f = $m->[ _f ];
my ($p, $k) = $m->__set_path( @_ );
return unless defined $p && defined $k;
my $l = defined $k->[-1] ? $k->[-1] : "";
my $set = $m->__set_path_node( $p, $l, @_ );
return $set;
}
sub __has_path {
my $m = shift;
my $f = $m->[ _f ];
if (@_ != 1) {
require Carp;
Carp::confess(sprintf
"Graph::AdjacencyMap: arguments %d expected 1\n",
scalar @_);
}
my $p = $m->[ _s ];
return unless defined $p;
my @p = $p;
my @k;
my $k = shift;
my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k;
push @k, $q;
return (\@p, \@k);
}
sub has_path {
my $m = shift;
my ($p, $k) = $m->__has_path( @_ );
return unless defined $p && defined $k;
return exists $p->[-1]->{ defined $k->[-1] ? $k->[-1] : "" };
}
sub has_path_by_multi_id {
my $m = shift;
my $id = pop;
my ($e, $n) = $m->__get_path_node( @_ );
return undef unless $e;
return exists $n->[ _nm ]->{ $id };
}
sub _get_path_id {
my $m = shift;
my $f = $m->[ _f ];
my ($e, $n) = $m->__get_path_node( @_ );
return undef unless $e;
return ref $n ? $n->[ _ni ] : $n;
}
sub _get_path_count {
my $m = shift;
my $f = $m->[ _f ];
my ($e, $n) = $m->__get_path_node( @_ );
return 0 unless $e && defined $n;
return
($f & _COUNT) ? $n->[ _nc ] :
($f & _MULTI) ? scalar keys %{ $n->[ _nm ] } : 1;
}
sub __attr {
my $m = shift;
if (@_ && ref $_[0] && @{ $_[0] } != $m->[ _a ]) {
require Carp;
Carp::confess(sprintf "Graph::AdjacencyMap::Vertex: arguments %d expected %d",
scalar @{ $_[0] }, $m->[ _a ]);
}
}
sub _get_id_path {
my ($m, $i) = @_;
return defined $m->[ _i ] ? $m->[ _i ]->{ $i } : undef;
}
sub del_path {
my $m = shift;
my $f = $m->[ _f ];
my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ );
return unless $e;
my $c = ($f & _COUNT) ? --$n->[ _nc ] : 0;
if ($c == 0) {
delete $m->[ _i ]->{ ref $n ? $n->[ _ni ] : $n };
delete $p->[ -1 ]->{ $l };
}
return 1;
}
sub del_path_by_multi_id {
my $m = shift;
my $f = $m->[ _f ];
my $id = pop;
my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ );
return unless $e;
delete $n->[ _nm ]->{ $id };
unless (keys %{ $n->[ _nm ] }) {
delete $m->[ _i ]->{ $n->[ _ni ] };
delete $p->[-1]->{ $l };
}
return 1;
}
sub paths {
my $m = shift;
return map { [ $_ ] } values %{ $m->[ _i ] } if defined $m->[ _i ];
wantarray ? ( ) : 0;
}
1;
=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 has_path(@id)
Return true if the Map has the path by ids, 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.
=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

223
perllib/Graph/AdjacencyMatrix.pm Normal file
View file

@ -0,0 +1,223 @@
package Graph::AdjacencyMatrix;
use strict;
use Graph::BitMatrix;
use Graph::Matrix;
use base 'Graph::BitMatrix';
use Graph::AdjacencyMap qw(:flags :fields);
sub _V () { 2 } # Graph::_V
sub _E () { 3 } # Graph::_E
sub new {
my ($class, $g, %opt) = @_;
my $n;
my @V = $g->vertices;
my $want_distance;
if (exists $opt{distance_matrix}) {
$want_distance = $opt{distance_matrix};
delete $opt{distance_matrix};
}
my $d = Graph::_defattr();
if (exists $opt{attribute_name}) {
$d = $opt{attribute_name};
$want_distance++;
}
delete $opt{attribute_name};
my $want_transitive = 0;
if (exists $opt{is_transitive}) {
$want_transitive = $opt{is_transitive};
delete $opt{is_transitive};
}
Graph::_opt_unknown(\%opt);
if ($want_distance) {
$n = Graph::Matrix->new($g);
for my $v (@V) { $n->set($v, $v, 0) }
}
my $m = Graph::BitMatrix->new($g, connect_edges => $want_distance);
if ($want_distance) {
# for my $u (@V) {
# for my $v (@V) {
# if ($g->has_edge($u, $v)) {
# $n->set($u, $v,
# $g->get_edge_attribute($u, $v, $d));
# }
# }
# }
my $Vi = $g->[_V]->[_i];
my $Ei = $g->[_E]->[_i];
my %V; @V{ @V } = 0 .. $#V;
my $n0 = $n->[0];
my $n1 = $n->[1];
if ($g->is_undirected) {
for my $e (keys %{ $Ei }) {
my ($i0, $j0) = @{ $Ei->{ $e } };
my $i1 = $V{ $Vi->{ $i0 } };
my $j1 = $V{ $Vi->{ $j0 } };
my $u = $V[ $i1 ];
my $v = $V[ $j1 ];
$n0->[ $i1 ]->[ $j1 ] =
$g->get_edge_attribute($u, $v, $d);
$n0->[ $j1 ]->[ $i1 ] =
$g->get_edge_attribute($v, $u, $d);
}
} else {
for my $e (keys %{ $Ei }) {
my ($i0, $j0) = @{ $Ei->{ $e } };
my $i1 = $V{ $Vi->{ $i0 } };
my $j1 = $V{ $Vi->{ $j0 } };
my $u = $V[ $i1 ];
my $v = $V[ $j1 ];
$n0->[ $i1 ]->[ $j1 ] =
$g->get_edge_attribute($u, $v, $d);
}
}
}
bless [ $m, $n, [ @V ] ], $class;
}
sub adjacency_matrix {
my $am = shift;
$am->[0];
}
sub distance_matrix {
my $am = shift;
$am->[1];
}
sub vertices {
my $am = shift;
@{ $am->[2] };
}
sub is_adjacent {
my ($m, $u, $v) = @_;
$m->[0]->get($u, $v) ? 1 : 0;
}
sub distance {
my ($m, $u, $v) = @_;
defined $m->[1] ? $m->[1]->get($u, $v) : undef;
}
1;
__END__
=pod
=head1 NAME
Graph::AdjacencyMatrix - create and query the adjacency matrix of graph G
=head1 SYNOPSIS
use Graph::AdjacencyMatrix;
use Graph::Directed; # or Undirected
my $g = Graph::Directed->new;
$g->add_...(); # build $g
my $am = Graph::AdjacencyMatrix->new($g);
$am->is_adjacent($u, $v)
my $am = Graph::AdjacencyMatrix->new($g, distance_matrix => 1);
$am->distance($u, $v)
my $am = Graph::AdjacencyMatrix->new($g, attribute_name => 'length');
$am->distance($u, $v)
my $am = Graph::AdjacencyMatrix->new($g, ...);
my @V = $am->vertices();
=head1 DESCRIPTION
You can use C<Graph::AdjacencyMatrix> to compute the adjacency matrix
and optionally also the distance matrix of a graph, and after that
query the adjacencyness between vertices by using the C<is_adjacent()>
method, or query the distance between vertices by using the
C<distance()> method.
By default the edge attribute used for distance is C<w>, but you
can change that in new(), see below.
If you modify the graph after creating the adjacency matrix of it,
the adjacency matrix and the distance matrix may become invalid.
=head1 Methods
=head2 Class Methods
=over 4
=item new($g)
Construct the adjacency matrix of the graph $g.
=item new($g, options)
Construct the adjacency matrix of the graph $g with options as a hash.
The known options are
=over 8
=item distance_matrix => boolean
By default only the adjacency matrix is computed. To compute also the
distance matrix, use the attribute C<distance_matrix> with a true value
to the new() constructor.
=item attribute_name => attribute_name
By default the edge attribute used for distance is C<w>. You can
change that by giving another attribute name with the C<attribute_name>
attribute to new() constructor. Using this attribute also implicitly
causes the distance matrix to be computed.
=back
=back
=head2 Object Methods
=over 4
=item is_adjacent($u, $v)
Return true if the vertex $v is adjacent to vertex $u, or false if not.
=item distance($u, $v)
Return the distance between the vertices $u and $v, or C<undef> if
the vertices are not adjacent.
=item adjacency_matrix
Return the adjacency matrix itself (a list of bitvector scalars).
=item vertices
Return the list of vertices (useful for indexing the adjacency matrix).
=back
=head1 ALGORITHM
The algorithm used to create the matrix is two nested loops, which is
O(V**2) in time, and the returned matrices are O(V**2) in space.
=head1 SEE ALSO
L<Graph::TransitiveClosure>, L<Graph::BitMatrix>
=head1 AUTHOR AND COPYRIGHT
Jarkko Hietaniemi F<jhi@iki.fi>
=head1 LICENSE
This module is licensed under the same terms as Perl itself.
=cut

130
perllib/Graph/Attribute.pm Normal file
View file

@ -0,0 +1,130 @@
package Graph::Attribute;
use strict;
sub _F () { 0 }
sub _COMPAT02 () { 0x00000001 }
sub import {
my $package = shift;
my %attr = @_;
my $caller = caller(0);
if (exists $attr{array}) {
my $i = $attr{array};
no strict 'refs';
*{"${caller}::_get_attributes"} = sub { $_[0]->[ $i ] };
*{"${caller}::_set_attributes"} =
sub { $_[0]->[ $i ] ||= { };
$_[0]->[ $i ] = $_[1] if @_ == 2;
$_[0]->[ $i ] };
*{"${caller}::_has_attributes"} = sub { defined $_[0]->[ $i ] };
*{"${caller}::_delete_attributes"} = sub { undef $_[0]->[ $i ]; 1 };
} elsif (exists $attr{hash}) {
my $k = $attr{hash};
no strict 'refs';
*{"${caller}::_get_attributes"} = sub { $_[0]->{ $k } };
*{"${caller}::_set_attributes"} =
sub { $_[0]->{ $k } ||= { };
$_[0]->{ $k } = $_[1] if @_ == 2;
$_[0]->{ $k } };
*{"${caller}::_has_attributes"} = sub { defined $_[0]->{ $k } };
*{"${caller}::_delete_attributes"} = sub { delete $_[0]->{ $k } };
} else {
die "Graph::Attribute::import($package @_) caller $caller\n";
}
my @api = qw(get_attribute
get_attributes
set_attribute
set_attributes
has_attribute
has_attributes
delete_attribute
delete_attributes
get_attribute_names
get_attribute_values);
if (exists $attr{map}) {
my $map = $attr{map};
for my $api (@api) {
my ($first, $rest) = ($api =~ /^(\w+?)_(.+)/);
no strict 'refs';
*{"${caller}::${first}_${map}_${rest}"} = \&$api;
}
}
}
sub set_attribute {
my $g = shift;
my $v = pop;
my $a = pop;
my $p = $g->_set_attributes;
$p->{ $a } = $v;
return 1;
}
sub set_attributes {
my $g = shift;
my $a = pop;
my $p = $g->_set_attributes( $a );
return 1;
}
sub has_attribute {
my $g = shift;
my $a = pop;
my $p = $g->_get_attributes;
$p ? exists $p->{ $a } : 0;
}
sub has_attributes {
my $g = shift;
$g->_get_attributes ? 1 : 0;
}
sub get_attribute {
my $g = shift;
my $a = pop;
my $p = $g->_get_attributes;
$p ? $p->{ $a } : undef;
}
sub delete_attribute {
my $g = shift;
my $a = pop;
my $p = $g->_get_attributes;
if (defined $p) {
delete $p->{ $a };
return 1;
} else {
return 0;
}
}
sub delete_attributes {
my $g = shift;
if ($g->_has_attributes) {
$g->_delete_attributes;
return 1;
} else {
return 0;
}
}
sub get_attribute_names {
my $g = shift;
my $p = $g->_get_attributes;
defined $p ? keys %{ $p } : ( );
}
sub get_attribute_values {
my $g = shift;
my $p = $g->_get_attributes;
defined $p ? values %{ $p } : ( );
}
sub get_attributes {
my $g = shift;
my $a = $g->_get_attributes;
($g->[ _F ] & _COMPAT02) ? (defined $a ? %{ $a } : ()) : $a;
}
1;

227
perllib/Graph/BitMatrix.pm Normal file
View file

@ -0,0 +1,227 @@
package Graph::BitMatrix;
use strict;
# $SIG{__DIE__ } = sub { use Carp; confess };
# $SIG{__WARN__} = sub { use Carp; confess };
sub _V () { 2 } # Graph::_V()
sub _E () { 3 } # Graph::_E()
sub _i () { 3 } # Index to path.
sub _s () { 4 } # Successors / Path to Index.
sub new {
my ($class, $g, %opt) = @_;
my @V = $g->vertices;
my $V = @V;
my $Z = "\0" x (($V + 7) / 8);
my %V; @V{ @V } = 0 .. $#V;
my $bm = bless [ [ ( $Z ) x $V ], \%V ], $class;
my $bm0 = $bm->[0];
my $connect_edges;
if (exists $opt{connect_edges}) {
$connect_edges = $opt{connect_edges};
delete $opt{connect_edges};
}
$connect_edges = 1 unless defined $connect_edges;
Graph::_opt_unknown(\%opt);
if ($connect_edges) {
# for (my $i = 0; $i <= $#V; $i++) {
# my $u = $V[$i];
# for (my $j = 0; $j <= $#V; $j++) {
# vec($bm0->[$i], $j, 1) = 1 if $g->has_edge($u, $V[$j]);
# }
# }
my $Vi = $g->[_V]->[_i];
my $Ei = $g->[_E]->[_i];
if ($g->is_undirected) {
for my $e (keys %{ $Ei }) {
my ($i0, $j0) = @{ $Ei->{ $e } };
my $i1 = $V{ $Vi->{ $i0 } };
my $j1 = $V{ $Vi->{ $j0 } };
vec($bm0->[$i1], $j1, 1) = 1;
vec($bm0->[$j1], $i1, 1) = 1;
}
} else {
for my $e (keys %{ $Ei }) {
my ($i0, $j0) = @{ $Ei->{ $e } };
vec($bm0->[$V{ $Vi->{ $i0 } }], $V{ $Vi->{ $j0 } }, 1) = 1;
}
}
}
return $bm;
}
sub set {
my ($m, $u, $v) = @_;
my ($i, $j) = map { $m->[1]->{ $_ } } ($u, $v);
vec($m->[0]->[$i], $j, 1) = 1 if defined $i && defined $j;
}
sub unset {
my ($m, $u, $v) = @_;
my ($i, $j) = map { $m->[1]->{ $_ } } ($u, $v);
vec($m->[0]->[$i], $j, 1) = 0 if defined $i && defined $j;
}
sub get {
my ($m, $u, $v) = @_;
my ($i, $j) = map { $m->[1]->{ $_ } } ($u, $v);
defined $i && defined $j ? vec($m->[0]->[$i], $j, 1) : undef;
}
sub set_row {
my ($m, $u) = splice @_, 0, 2;
my $m0 = $m->[0];
my $m1 = $m->[1];
my $i = $m1->{ $u };
return unless defined $i;
for my $v (@_) {
my $j = $m1->{ $v };
vec($m0->[$i], $j, 1) = 1 if defined $j;
}
}
sub unset_row {
my ($m, $u) = splice @_, 0, 2;
my $m0 = $m->[0];
my $m1 = $m->[1];
my $i = $m1->{ $u };
return unless defined $i;
for my $v (@_) {
my $j = $m1->{ $v };
vec($m0->[$i], $j, 1) = 0 if defined $j;
}
}
sub get_row {
my ($m, $u) = splice @_, 0, 2;
my $m0 = $m->[0];
my $m1 = $m->[1];
my $i = $m1->{ $u };
return () x @_ unless defined $i;
my @r;
for my $v (@_) {
my $j = $m1->{ $v };
push @r, defined $j ? (vec($m0->[$i], $j, 1) ? 1 : 0) : undef;
}
return @r;
}
sub vertices {
my ($m, $u, $v) = @_;
keys %{ $m->[1] };
}
1;
__END__
=pod
=head1 NAME
Graph::BitMatrix - create and manipulate a V x V bit matrix of graph G
=head1 SYNOPSIS
use Graph::BitMatrix;
use Graph::Directed;
my $g = Graph::Directed->new;
$g->add_...(); # build $g
my $m = Graph::BitMatrix->new($g, %opt);
$m->get($u, $v)
$m->set($u, $v)
$m->unset($u, $v)
$m->get_row($u, $v1, $v2, ..., $vn)
$m->set_row($u, $v1, $v2, ..., $vn)
$m->unset_row($u, $v1, $v2, ..., $vn)
$a->vertices()
=head1 DESCRIPTION
This class enables creating bit matrices that compactly describe
the connected of the graphs.
=head2 Class Methods
=over 4
=item new($g)
Create a bit matrix from a Graph $g. The C<%opt>, if present,
can have the following options:
=over 8
=item *
connect_edges
If true or if not present, set the bits in the bit matrix that
correspond to edges. If false, do not set any bits. In either
case the bit matrix of V x V bits is allocated.
=back
=back
=head2 Object Methods
=over 4
=item get($u, $v)
Return true if the bit matrix has a "one bit" between the vertices
$u and $v; in other words, if there is (at least one) a vertex going from
$u to $v. If there is no vertex and therefore a "zero bit", return false.
=item set($u, $v)
Set the bit between the vertices $u and $v; in other words, connect
the vertices $u and $v by an edge. The change does not get mirrored
back to the original graph. Returns nothing.
=item unset($u, $v)
Unset the bit between the vertices $u and $v; in other words, disconnect
the vertices $u and $v by an edge. The change does not get mirrored
back to the original graph. Returns nothing.
=item get_row($u, $v1, $v2, ..., $vn)
Test the row at vertex C<u> for the vertices C<v1>, C<v2>, ..., C<vn>
Returns a list of I<n> truth values.
=item set_row($u, $v1, $v2, ..., $vn)
Sets the row at vertex C<u> for the vertices C<v1>, C<v2>, ..., C<vn>,
in other words, connects the vertex C<u> to the vertices C<vi>.
The changes do not get mirrored back to the original graph.
Returns nothing.
=item unset_row($u, $v1, $v2, ..., $vn)
Unsets the row at vertex C<u> for the vertices C<v1>, C<v2>, ..., C<vn>,
in other words, disconnects the vertex C<u> from the vertices C<vi>.
The changes do not get mirrored back to the original graph.
Returns nothing.
=item vertices
Return the list of vertices in the bit matrix.
=back
=head1 ALGORITHM
The algorithm used to create the matrix is two nested loops, which is
O(V**2) in time, and the returned matrices are O(V**2) in space.
=head1 AUTHOR AND COPYRIGHT
Jarkko Hietaniemi F<jhi@iki.fi>
=head1 LICENSE
This module is licensed under the same terms as Perl itself.
=cut

44
perllib/Graph/Directed.pm Normal file
View file

@ -0,0 +1,44 @@
package Graph::Directed;
use Graph;
use base 'Graph';
use strict;
=pod
=head1 NAME
Graph::Directed - directed graphs
=head1 SYNOPSIS
use Graph::Directed;
my $g = Graph::Directed->new;
# Or alternatively:
use Graph;
my $g = Graph->new(directed => 1);
my $g = Graph->new(undirected => 0);
=head1 DESCRIPTION
Graph::Directed allows you to create directed graphs.
For the available methods, see L<Graph>.
=head1 SEE ALSO
L<Graph>, L<Graph::Undirected>
=head1 AUTHOR AND COPYRIGHT
Jarkko Hietaniemi F<jhi@iki.fi>
=head1 LICENSE
This module is licensed under the same terms as Perl itself.
=cut
1;

24
perllib/Graph/MSTHeapElem.pm Normal file
View file

@ -0,0 +1,24 @@
package Graph::MSTHeapElem;
use strict;
use vars qw($VERSION @ISA);
use Heap071::Elem;
use base 'Heap071::Elem';
$VERSION = 0.01;
sub new {
my $class = shift;
bless { u => $_[0], v => $_[1], w => $_[2] }, $class;
}
sub cmp {
($_[0]->{ w } || 0) <=> ($_[1]->{ w } || 0);
}
sub val {
@{ $_[0] }{ qw(u v w) };
}
1;

82
perllib/Graph/Matrix.pm Normal file
View file

@ -0,0 +1,82 @@
package Graph::Matrix;
# $SIG{__DIE__ } = sub { use Carp; confess };
# $SIG{__WARN__} = sub { use Carp; confess };
use strict;
sub new {
my ($class, $g) = @_;
my @V = $g->vertices;
my $V = @V;
my %V; @V{ @V } = 0 .. $#V;
bless [ [ map { [ ] } 0 .. $#V ], \%V ], $class;
}
sub set {
my ($m, $u, $v, $val) = @_;
my ($i, $j) = map { $m->[1]->{ $_ } } ($u, $v);
$m->[0]->[$i]->[$j] = $val;
}
sub get {
my ($m, $u, $v) = @_;
my ($i, $j) = map { $m->[1]->{ $_ } } ($u, $v);
$m->[0]->[$i]->[$j];
}
1;
__END__
=pod
=head1 NAME
Graph::Matrix - create and manipulate a V x V matrix of graph G
=head1 SYNOPSIS
use Graph::Matrix;
use Graph::Directed;
my $g = Graph::Directed->new;
$g->add_...(); # build $g
my $m = Graph::Matrix->new($g);
$m->get($u, $v)
$s->get($u, $v, $val)
=head1 DESCRIPTION
B<This module is meant for internal use by the Graph module.>
=head2 Class Methods
=over 4
=item new($g)
Construct a new Matrix from the Graph $g.
=back
=head2 Object Methods
=over 4
=item get($u, $v)
Return the value at the edge from $u to $v.
=item set($u, $v, $val)
Set the edge from $u to $v to value $val.
=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

26
perllib/Graph/SPTHeapElem.pm Normal file
View file

@ -0,0 +1,26 @@
package Graph::SPTHeapElem;
use strict;
use vars qw($VERSION @ISA);
use Heap071::Elem;
use base 'Heap071::Elem';
$VERSION = 0.01;
sub new {
my $class = shift;
bless { u => $_[0], v => $_[1], w => $_[2] }, $class;
}
sub cmp {
($_[0]->{ w } || 0) <=> ($_[1]->{ w } || 0) ||
($_[0]->{ u } cmp $_[1]->{ u }) ||
($_[0]->{ u } cmp $_[1]->{ v });
}
sub val {
@{ $_[0] }{ qw(u v w) };
}
1;

155
perllib/Graph/TransitiveClosure.pm Normal file
View file

@ -0,0 +1,155 @@
package Graph::TransitiveClosure;
# COMMENT THESE OUT FOR TESTING AND PRODUCTION.
# $SIG{__DIE__ } = sub { use Carp; confess };
# $SIG{__WARN__} = sub { use Carp; confess };
use base 'Graph';
use Graph::TransitiveClosure::Matrix;
sub _G () { Graph::_G() }
sub new {
my ($class, $g, %opt) = @_;
$g->expect_non_multiedged;
%opt = (path_vertices => 1) unless %opt;
my $attr = Graph::_defattr();
if (exists $opt{ attribute_name }) {
$attr = $opt{ attribute_name };
# No delete $opt{ attribute_name } since we need to pass it on.
}
$opt{ reflexive } = 1 unless exists $opt{ reflexive };
my $tcm = $g->new( $opt{ reflexive } ?
( vertices => [ $g->vertices ] ) : ( ) );
my $tcg = $g->get_graph_attribute('_tcg');
if (defined $tcg && $tcg->[ 0 ] == $g->[ _G ]) {
$tcg = $tcg->[ 1 ];
} else {
$tcg = Graph::TransitiveClosure::Matrix->new($g, %opt);
$g->set_graph_attribute('_tcg', [ $g->[ _G ], $tcg ]);
}
my $tcg00 = $tcg->[0]->[0];
my $tcg11 = $tcg->[1]->[1];
for my $u ($tcg->vertices) {
my $tcg00i = $tcg00->[ $tcg11->{ $u } ];
for my $v ($tcg->vertices) {
next if $u eq $v && ! $opt{ reflexive };
my $j = $tcg11->{ $v };
if (
# $tcg->is_transitive($u, $v)
# $tcg->[0]->get($u, $v)
vec($tcg00i, $j, 1)
) {
my $val = $g->_get_edge_attribute($u, $v, $attr);
$tcm->_set_edge_attribute($u, $v, $attr,
defined $val ? $val :
$u eq $v ?
0 : 1);
}
}
}
$tcm->set_graph_attribute('_tcm', $tcg);
bless $tcm, $class;
}
sub is_transitive {
my $g = shift;
Graph::TransitiveClosure::Matrix::is_transitive($g);
}
1;
__END__
=pod
Graph::TransitiveClosure - create and query transitive closure of graph
=head1 SYNOPSIS
use Graph::TransitiveClosure;
use Graph::Directed; # or Undirected
my $g = Graph::Directed->new;
$g->add_...(); # build $g
# Compute the transitive closure graph.
my $tcg = Graph::TransitiveClosure->new($g);
$tcg->is_reachable($u, $v) # Identical to $tcg->has_edge($u, $v)
# Being reflexive is the default, meaning that null transitions
# (transitions from a vertex to the same vertex) are included.
my $tcg = Graph::TransitiveClosure->new($g, reflexive => 1);
my $tcg = Graph::TransitiveClosure->new($g, reflexive => 0);
# is_reachable(u, v) is always reflexive.
$tcg->is_reachable($u, $v)
# The reflexivity of is_transitive(u, v) depends of the reflexivity
# of the transitive closure.
$tcg->is_transitive($u, $v)
# You can check any graph for transitivity.
$g->is_transitive()
my $tcg = Graph::TransitiveClosure->new($g, path_length => 1);
$tcg->path_length($u, $v)
# path_vertices is automatically always on so this is a no-op.
my $tcg = Graph::TransitiveClosure->new($g, path_vertices => 1);
$tcg->path_vertices($u, $v)
# Both path_length and path_vertices.
my $tcg = Graph::TransitiveClosure->new($g, path => 1);
$tcg->path_vertices($u, $v)
$tcg->length($u, $v)
my $tcg = Graph::TransitiveClosure->new($g, attribute_name => 'length');
$tcg->path_length($u, $v)
=head1 DESCRIPTION
You can use C<Graph::TransitiveClosure> to compute the transitive
closure graph of a graph and optionally also the minimum paths
(lengths and vertices) between vertices, and after that query the
transitiveness between vertices by using the C<is_reachable()> and
C<is_transitive()> methods, and the paths by using the
C<path_length()> and C<path_vertices()> methods.
For further documentation, see the L<Graph::TransitiveClosure::Matrix>.
=head2 Class Methods
=over 4
=item new($g, %opt)
Construct a new transitive closure object. Note that strictly speaking
the returned object is not a graph; it is a graph plus other stuff. But
you should be able to use it as a graph plus a couple of methods inherited
from the Graph::TransitiveClosure::Matrix class.
=back
=head2 Object Methods
These are only the methods 'native' to the class: see
L<Graph::TransitiveClosure::Matrix> for more.
=over 4
=item is_transitive($g)
Return true if the Graph $g is transitive.
=item transitive_closure_matrix
Return the transitive closure matrix of the transitive closure object.
=back
=head2 INTERNALS
The transitive closure matrix is stored as an attribute of the graph
called C<_tcm>, and any methods not found in the graph class are searched
in the transitive closure matrix class.
=cut

488
perllib/Graph/TransitiveClosure/Matrix.pm Normal file
View file

@ -0,0 +1,488 @@
package Graph::TransitiveClosure::Matrix;
use strict;
use Graph::AdjacencyMatrix;
use Graph::Matrix;
sub _new {
my ($g, $class, $opt, $want_transitive, $want_reflexive, $want_path, $want_path_vertices) = @_;
my $m = Graph::AdjacencyMatrix->new($g, %$opt);
my @V = $g->vertices;
my $am = $m->adjacency_matrix;
my $dm; # The distance matrix.
my $pm; # The predecessor matrix.
my @di;
my %di; @di{ @V } = 0..$#V;
my @ai = @{ $am->[0] };
my %ai = %{ $am->[1] };
my @pi;
my %pi;
unless ($want_transitive) {
$dm = $m->distance_matrix;
@di = @{ $dm->[0] };
%di = %{ $dm->[1] };
$pm = Graph::Matrix->new($g);
@pi = @{ $pm->[0] };
%pi = %{ $pm->[1] };
for my $u (@V) {
my $diu = $di{$u};
my $aiu = $ai{$u};
for my $v (@V) {
my $div = $di{$v};
my $aiv = $ai{$v};
next unless
# $am->get($u, $v)
vec($ai[$aiu], $aiv, 1)
;
# $dm->set($u, $v, $u eq $v ? 0 : 1)
$di[$diu]->[$div] = $u eq $v ? 0 : 1
unless
defined
# $dm->get($u, $v)
$di[$diu]->[$div]
;
$pi[$diu]->[$div] = $v unless $u eq $v;
}
}
}
# XXX (see the bits below): sometimes, being nice and clean is the
# wrong thing to do. In this case, using the public API for graph
# transitive matrices and bitmatrices makes things awfully slow.
# Instead, we go straight for the jugular of the data structures.
for my $u (@V) {
my $diu = $di{$u};
my $aiu = $ai{$u};
my $didiu = $di[$diu];
my $aiaiu = $ai[$aiu];
for my $v (@V) {
my $div = $di{$v};
my $aiv = $ai{$v};
my $didiv = $di[$div];
my $aiaiv = $ai[$aiv];
if (
# $am->get($v, $u)
vec($aiaiv, $aiu, 1)
|| ($want_reflexive && $u eq $v)) {
my $aivivo = $aiaiv;
if ($want_transitive) {
if ($want_reflexive) {
for my $w (@V) {
next if $w eq $u;
my $aiw = $ai{$w};
return 0
if vec($aiaiu, $aiw, 1) &&
!vec($aiaiv, $aiw, 1);
}
# See XXX above.
# for my $w (@V) {
# my $aiw = $ai{$w};
# if (
# # $am->get($u, $w)
# vec($aiaiu, $aiw, 1)
# || ($u eq $w)) {
# return 0
# if $u ne $w &&
# # !$am->get($v, $w)
# !vec($aiaiv, $aiw, 1)
# ;
# # $am->set($v, $w)
# vec($aiaiv, $aiw, 1) = 1
# ;
# }
# }
} else {
# See XXX above.
# for my $w (@V) {
# my $aiw = $ai{$w};
# if (
# # $am->get($u, $w)
# vec($aiaiu, $aiw, 1)
# ) {
# return 0
# if $u ne $w &&
# # !$am->get($v, $w)
# !vec($aiaiv, $aiw, 1)
# ;
# # $am->set($v, $w)
# vec($aiaiv, $aiw, 1) = 1
# ;
# }
# }
$aiaiv |= $aiaiu;
}
} else {
if ($want_reflexive) {
$aiaiv |= $aiaiu;
vec($aiaiv, $aiu, 1) = 1;
# See XXX above.
# for my $w (@V) {
# my $aiw = $ai{$w};
# if (
# # $am->get($u, $w)
# vec($aiaiu, $aiw, 1)
# || ($u eq $w)) {
# # $am->set($v, $w)
# vec($aiaiv, $aiw, 1) = 1
# ;
# }
# }
} else {
$aiaiv |= $aiaiu;
# See XXX above.
# for my $w (@V) {
# my $aiw = $ai{$w};
# if (
# # $am->get($u, $w)
# vec($aiaiu, $aiw, 1)
# ) {
# # $am->set($v, $w)
# vec($aiaiv, $aiw, 1) = 1
# ;
# }
# }
}
}
if ($aiaiv ne $aivivo) {
$ai[$aiv] = $aiaiv;
$aiaiu = $aiaiv if $u eq $v;
}
}
if ($want_path && !$want_transitive) {
for my $w (@V) {
my $aiw = $ai{$w};
next unless
# See XXX above.
# $am->get($v, $u)
vec($aiaiv, $aiu, 1)
&&
# See XXX above.
# $am->get($u, $w)
vec($aiaiu, $aiw, 1)
;
my $diw = $di{$w};
my ($d0, $d1a, $d1b);
if (defined $dm) {
# See XXX above.
# $d0 = $dm->get($v, $w);
# $d1a = $dm->get($v, $u) || 1;
# $d1b = $dm->get($u, $w) || 1;
$d0 = $didiv->[$diw];
$d1a = $didiv->[$diu] || 1;
$d1b = $didiu->[$diw] || 1;
} else {
$d1a = 1;
$d1b = 1;
}
my $d1 = $d1a + $d1b;
if (!defined $d0 || ($d1 < $d0)) {
# print "d1 = $d1a ($v, $u) + $d1b ($u, $w) = $d1 ($v, $w) (".(defined$d0?$d0:"-").")\n";
# See XXX above.
# $dm->set($v, $w, $d1);
$didiv->[$diw] = $d1;
$pi[$div]->[$diw] = $pi[$div]->[$diu]
if $want_path_vertices;
}
}
# $dm->set($u, $v, 1)
$didiu->[$div] = 1
if $u ne $v &&
# $am->get($u, $v)
vec($aiaiu, $aiv, 1)
&&
# !defined $dm->get($u, $v);
!defined $didiu->[$div];
}
}
}
return 1 if $want_transitive;
my %V; @V{ @V } = @V;
$am->[0] = \@ai;
$am->[1] = \%ai;
if (defined $dm) {
$dm->[0] = \@di;
$dm->[1] = \%di;
}
if (defined $pm) {
$pm->[0] = \@pi;
$pm->[1] = \%pi;
}
bless [ $am, $dm, $pm, \%V ], $class;
}
sub new {
my ($class, $g, %opt) = @_;
my %am_opt = (distance_matrix => 1);
if (exists $opt{attribute_name}) {
$am_opt{attribute_name} = $opt{attribute_name};
delete $opt{attribute_name};
}
if ($opt{distance_matrix}) {
$am_opt{distance_matrix} = $opt{distance_matrix};
}
delete $opt{distance_matrix};
if (exists $opt{path}) {
$opt{path_length} = $opt{path};
$opt{path_vertices} = $opt{path};
delete $opt{path};
}
my $want_path_length;
if (exists $opt{path_length}) {
$want_path_length = $opt{path_length};
delete $opt{path_length};
}
my $want_path_vertices;
if (exists $opt{path_vertices}) {
$want_path_vertices = $opt{path_vertices};
delete $opt{path_vertices};
}
my $want_reflexive;
if (exists $opt{reflexive}) {
$want_reflexive = $opt{reflexive};
delete $opt{reflexive};
}
my $want_transitive;
if (exists $opt{is_transitive}) {
$want_transitive = $opt{is_transitive};
$am_opt{is_transitive} = $want_transitive;
delete $opt{is_transitive};
}
die "Graph::TransitiveClosure::Matrix::new: Unknown options: @{[map { qq['$_' => $opt{$_}]} keys %opt]}"
if keys %opt;
$want_reflexive = 1 unless defined $want_reflexive;
my $want_path = $want_path_length || $want_path_vertices;
# $g->expect_dag if $want_path;
_new($g, $class,
\%am_opt,
$want_transitive, $want_reflexive,
$want_path, $want_path_vertices);
}
sub has_vertices {
my $tc = shift;
for my $v (@_) {
return 0 unless exists $tc->[3]->{ $v };
}
return 1;
}
sub is_reachable {
my ($tc, $u, $v) = @_;
return undef unless $tc->has_vertices($u, $v);
return 1 if $u eq $v;
$tc->[0]->get($u, $v);
}
sub is_transitive {
if (@_ == 1) { # Any graph.
__PACKAGE__->new($_[0], is_transitive => 1); # Scary.
} else { # A TC graph.
my ($tc, $u, $v) = @_;
return undef unless $tc->has_vertices($u, $v);
$tc->[0]->get($u, $v);
}
}
sub vertices {
my $tc = shift;
values %{ $tc->[3] };
}
sub path_length {
my ($tc, $u, $v) = @_;
return undef unless $tc->has_vertices($u, $v);
return 0 if $u eq $v;
$tc->[1]->get($u, $v);
}
sub path_predecessor {
my ($tc, $u, $v) = @_;
return undef if $u eq $v;
return undef unless $tc->has_vertices($u, $v);
$tc->[2]->get($u, $v);
}
sub path_vertices {
my ($tc, $u, $v) = @_;
return unless $tc->is_reachable($u, $v);
return wantarray ? () : 0 if $u eq $v;
my @v = ( $u );
while ($u ne $v) {
last unless defined($u = $tc->path_predecessor($u, $v));
push @v, $u;
}
$tc->[2]->set($u, $v, [ @v ]) if @v;
return @v;
}
1;
__END__
=pod
=head1 NAME
Graph::TransitiveClosure::Matrix - create and query transitive closure of graph
=head1 SYNOPSIS
use Graph::TransitiveClosure::Matrix;
use Graph::Directed; # or Undirected
my $g = Graph::Directed->new;
$g->add_...(); # build $g
# Compute the transitive closure matrix.
my $tcm = Graph::TransitiveClosure::Matrix->new($g);
# Being reflexive is the default,
# meaning that null transitions are included.
my $tcm = Graph::TransitiveClosure::Matrix->new($g, reflexive => 1);
$tcm->is_reachable($u, $v)
# is_reachable(u, v) is always reflexive.
$tcm->is_reachable($u, $v)
# The reflexivity of is_transitive(u, v) depends of the reflexivity
# of the transitive closure.
$tcg->is_transitive($u, $v)
my $tcm = Graph::TransitiveClosure::Matrix->new($g, path_length => 1);
$tcm->path_length($u, $v)
my $tcm = Graph::TransitiveClosure::Matrix->new($g, path_vertices => 1);
$tcm->path_vertices($u, $v)
my $tcm = Graph::TransitiveClosure::Matrix->new($g, attribute_name => 'length');
$tcm->path_length($u, $v)
$tcm->vertices
=head1 DESCRIPTION
You can use C<Graph::TransitiveClosure::Matrix> to compute the
transitive closure matrix of a graph and optionally also the minimum
paths (lengths and vertices) between vertices, and after that query
the transitiveness between vertices by using the C<is_reachable()> and
C<is_transitive()> methods, and the paths by using the
C<path_length()> and C<path_vertices()> methods.
If you modify the graph after computing its transitive closure,
the transitive closure and minimum paths may become invalid.
=head1 Methods
=head2 Class Methods
=over 4
=item new($g)
Construct the transitive closure matrix of the graph $g.
=item new($g, options)
Construct the transitive closure matrix of the graph $g with options
as a hash. The known options are
=over 8
=item C<attribute_name> => I<attribute_name>
By default the edge attribute used for distance is C<w>. You can
change that by giving another attribute name with the C<attribute_name>
attribute to the new() constructor.
=item reflexive => boolean
By default the transitive closure matrix is not reflexive: that is,
the adjacency matrix has zeroes on the diagonal. To have ones on
the diagonal, use true for the C<reflexive> option.
B<NOTE>: this behaviour has changed from Graph 0.2xxx: transitive
closure graphs were by default reflexive.
=item path_length => boolean
By default the path lengths are not computed, only the boolean transitivity.
By using true for C<path_length> also the path lengths will be computed,
they can be retrieved using the path_length() method.
=item path_vertices => boolean
By default the paths are not computed, only the boolean transitivity.
By using true for C<path_vertices> also the paths will be computed,
they can be retrieved using the path_vertices() method.
=back
=back
=head2 Object Methods
=over 4
=item is_reachable($u, $v)
Return true if the vertex $v is reachable from the vertex $u,
or false if not.
=item path_length($u, $v)
Return the minimum path length from the vertex $u to the vertex $v,
or undef if there is no such path.
=item path_vertices($u, $v)
Return the minimum path (as a list of vertices) from the vertex $u to
the vertex $v, or an empty list if there is no such path, OR also return
an empty list if $u equals $v.
=item has_vertices($u, $v, ...)
Return true if the transitive closure matrix has all the listed vertices,
false if not.
=item is_transitive($u, $v)
Return true if the vertex $v is transitively reachable from the vertex $u,
false if not.
=item vertices
Return the list of vertices in the transitive closure matrix.
=item path_predecessor
Return the predecessor of vertex $v in the transitive closure path
going back to vertex $u.
=back
=head1 RETURN VALUES
For path_length() the return value will be the sum of the appropriate
attributes on the edges of the path, C<weight> by default. If no
attribute has been set, one (1) will be assumed.
If you try to ask about vertices not in the graph, undefs and empty
lists will be returned.
=head1 ALGORITHM
The transitive closure algorithm used is Warshall and Floyd-Warshall
for the minimum paths, which is O(V**3) in time, and the returned
matrices are O(V**2) in space.
=head1 SEE ALSO
L<Graph::AdjacencyMatrix>
=head1 AUTHOR AND COPYRIGHT
Jarkko Hietaniemi F<jhi@iki.fi>
=head1 LICENSE
This module is licensed under the same terms as Perl itself.
=cut

714
perllib/Graph/Traversal.pm Normal file
View file

@ -0,0 +1,714 @@
package Graph::Traversal;
use strict;
# $SIG{__DIE__ } = sub { use Carp; confess };
# $SIG{__WARN__} = sub { use Carp; confess };
sub DEBUG () { 0 }
sub reset {
my $self = shift;
$self->{ unseen } = { map { $_ => $_ } $self->{ graph }->vertices };
$self->{ seen } = { };
$self->{ order } = [ ];
$self->{ preorder } = [ ];
$self->{ postorder } = [ ];
$self->{ roots } = [ ];
$self->{ tree } =
Graph->new( directed => $self->{ graph }->directed );
delete $self->{ terminate };
}
my $see = sub {
my $self = shift;
$self->see;
};
my $see_active = sub {
my $self = shift;
delete @{ $self->{ active } }{ $self->see };
};
sub has_a_cycle {
my ($u, $v, $t, $s) = @_;
$s->{ has_a_cycle } = 1;
$t->terminate;
}
sub find_a_cycle {
my ($u, $v, $t, $s) = @_;
my @cycle = ( $u );
push @cycle, $v unless $u eq $v;
my $path = $t->{ order };
if (@$path) {
my $i = $#$path;
while ($i >= 0 && $path->[ $i ] ne $v) { $i-- }
if ($i >= 0) {
unshift @cycle, @{ $path }[ $i+1 .. $#$path ];
}
}
$s->{ a_cycle } = \@cycle;
$t->terminate;
}
sub configure {
my ($self, %attr) = @_;
$self->{ pre } = $attr{ pre } if exists $attr{ pre };
$self->{ post } = $attr{ post } if exists $attr{ post };
$self->{ pre_vertex } = $attr{ pre_vertex } if exists $attr{ pre_vertex };
$self->{ post_vertex } = $attr{ post_vertex } if exists $attr{ post_vertex };
$self->{ pre_edge } = $attr{ pre_edge } if exists $attr{ pre_edge };
$self->{ post_edge } = $attr{ post_edge } if exists $attr{ post_edge };
if (exists $attr{ successor }) { # Graph 0.201 compatibility.
$self->{ tree_edge } = $self->{ non_tree_edge } = $attr{ successor };
}
if (exists $attr{ unseen_successor }) {
if (exists $self->{ tree_edge }) { # Graph 0.201 compatibility.
my $old_tree_edge = $self->{ tree_edge };
$self->{ tree_edge } = sub {
$old_tree_edge->( @_ );
$attr{ unseen_successor }->( @_ );
};
} else {
$self->{ tree_edge } = $attr{ unseen_successor };
}
}
if ($self->graph->multiedged || $self->graph->countedged) {
$self->{ seen_edge } = $attr{ seen_edge } if exists $attr{ seen_edge };
if (exists $attr{ seen_successor }) { # Graph 0.201 compatibility.
$self->{ seen_edge } = $attr{ seen_edge };
}
}
$self->{ non_tree_edge } = $attr{ non_tree_edge } if exists $attr{ non_tree_edge };
$self->{ pre_edge } = $attr{ tree_edge } if exists $attr{ tree_edge };
$self->{ back_edge } = $attr{ back_edge } if exists $attr{ back_edge };
$self->{ down_edge } = $attr{ down_edge } if exists $attr{ down_edge };
$self->{ cross_edge } = $attr{ cross_edge } if exists $attr{ cross_edge };
if (exists $attr{ start }) {
$attr{ first_root } = $attr{ start };
$attr{ next_root } = undef;
}
if (exists $attr{ get_next_root }) {
$attr{ next_root } = $attr{ get_next_root }; # Graph 0.201 compat.
}
$self->{ next_root } =
exists $attr{ next_root } ?
$attr{ next_root } :
$attr{ next_alphabetic } ?
\&Graph::_next_alphabetic :
$attr{ next_numeric } ?
\&Graph::_next_numeric :
\&Graph::_next_random;
$self->{ first_root } =
exists $attr{ first_root } ?
$attr{ first_root } :
exists $attr{ next_root } ?
$attr{ next_root } :
$attr{ next_alphabetic } ?
\&Graph::_next_alphabetic :
$attr{ next_numeric } ?
\&Graph::_next_numeric :
\&Graph::_next_random;
$self->{ next_successor } =
exists $attr{ next_successor } ?
$attr{ next_successor } :
$attr{ next_alphabetic } ?
\&Graph::_next_alphabetic :
$attr{ next_numeric } ?
\&Graph::_next_numeric :
\&Graph::_next_random;
if (exists $attr{ has_a_cycle }) {
my $has_a_cycle =
ref $attr{ has_a_cycle } eq 'CODE' ?
$attr{ has_a_cycle } : \&has_a_cycle;
$self->{ back_edge } = $has_a_cycle;
if ($self->{ graph }->is_undirected) {
$self->{ down_edge } = $has_a_cycle;
}
}
if (exists $attr{ find_a_cycle }) {
my $find_a_cycle =
ref $attr{ find_a_cycle } eq 'CODE' ?
$attr{ find_a_cycle } : \&find_a_cycle;
$self->{ back_edge } = $find_a_cycle;
if ($self->{ graph }->is_undirected) {
$self->{ down_edge } = $find_a_cycle;
}
}
$self->{ add } = \&add_order;
$self->{ see } = $see;
delete @attr{ qw(
pre post pre_edge post_edge
successor unseen_successor seen_successor
tree_edge non_tree_edge
back_edge down_edge cross_edge seen_edge
start get_next_root
next_root next_alphabetic next_numeric next_random next_successor
first_root
has_a_cycle find_a_cycle
) };
if (keys %attr) {
require Carp;
my @attr = sort keys %attr;
Carp::croak(sprintf "Graph::Traversal: unknown attribute%s @{[map { qq['$_'] } @attr]}\n", @attr == 1 ? '' : 's');
}
}
sub new {
my $class = shift;
my $g = shift;
unless (ref $g && $g->isa('Graph')) {
require Carp;
Carp::croak("Graph::Traversal: first argument is not a Graph");
}
my $self = { graph => $g, state => { } };
bless $self, $class;
$self->reset;
$self->configure( @_ );
return $self;
}
sub terminate {
my $self = shift;
$self->{ terminate } = 1;
}
sub add_order {
my ($self, @next) = @_;
push @{ $self->{ order } }, @next;
}
sub visit {
my ($self, @next) = @_;
delete @{ $self->{ unseen } }{ @next };
print "unseen = @{[sort keys %{$self->{unseen}}]}\n" if DEBUG;
@{ $self->{ seen } }{ @next } = @next;
print "seen = @{[sort keys %{$self->{seen}}]}\n" if DEBUG;
$self->{ add }->( $self, @next );
print "order = @{$self->{order}}\n" if DEBUG;
if (exists $self->{ pre }) {
my $p = $self->{ pre };
for my $v (@next) {
$p->( $v, $self );
}
}
}
sub visit_preorder {
my ($self, @next) = @_;
push @{ $self->{ preorder } }, @next;
for my $v (@next) {
$self->{ preordern }->{ $v } = $self->{ preorderi }++;
}
print "preorder = @{$self->{preorder}}\n" if DEBUG;
$self->visit( @next );
}
sub visit_postorder {
my ($self) = @_;
my @post = reverse $self->{ see }->( $self );
push @{ $self->{ postorder } }, @post;
for my $v (@post) {
$self->{ postordern }->{ $v } = $self->{ postorderi }++;
}
print "postorder = @{$self->{postorder}}\n" if DEBUG;
if (exists $self->{ post }) {
my $p = $self->{ post };
for my $v (@post) {
$p->( $v, $self ) ;
}
}
if (exists $self->{ post_edge }) {
my $p = $self->{ post_edge };
my $u = $self->current;
if (defined $u) {
for my $v (@post) {
$p->( $u, $v, $self, $self->{ state });
}
}
}
}
sub _callbacks {
my ($self, $current, @all) = @_;
return unless @all;
my $nontree = $self->{ non_tree_edge };
my $back = $self->{ back_edge };
my $down = $self->{ down_edge };
my $cross = $self->{ cross_edge };
my $seen = $self->{ seen_edge };
my $bdc = defined $back || defined $down || defined $cross;
if (defined $nontree || $bdc || defined $seen) {
my $u = $current;
my $preu = $self->{ preordern }->{ $u };
my $postu = $self->{ postordern }->{ $u };
for my $v ( @all ) {
my $e = $self->{ tree }->has_edge( $u, $v );
if ( !$e && (defined $nontree || $bdc) ) {
if ( exists $self->{ seen }->{ $v }) {
$nontree->( $u, $v, $self, $self->{ state })
if $nontree;
if ($bdc) {
my $postv = $self->{ postordern }->{ $v };
if ($back &&
(!defined $postv || $postv >= $postu)) {
$back ->( $u, $v, $self, $self->{ state });
} else {
my $prev = $self->{ preordern }->{ $v };
if ($down && $prev > $preu) {
$down ->( $u, $v, $self, $self->{ state });
} elsif ($cross && $prev < $preu) {
$cross->( $u, $v, $self, $self->{ state });
}
}
}
}
}
if ($seen) {
my $c = $self->graph->get_edge_count($u, $v);
while ($c-- > 1) {
$seen->( $u, $v, $self, $self->{ state } );
}
}
}
}
}
sub next {
my $self = shift;
return undef if $self->{ terminate };
my @next;
while ($self->seeing) {
my $current = $self->current;
print "current = $current\n" if DEBUG;
@next = $self->{ graph }->successors( $current );
print "next.0 - @next\n" if DEBUG;
my %next; @next{ @next } = @next;
# delete $next{ $current };
print "next.1 - @next\n" if DEBUG;
@next = keys %next;
my @all = @next;
print "all = @all\n" if DEBUG;
delete @next{ $self->seen };
@next = keys %next;
print "next.2 - @next\n" if DEBUG;
if (@next) {
@next = $self->{ next_successor }->( $self, \%next );
print "next.3 - @next\n" if DEBUG;
for my $v (@next) {
$self->{ tree }->add_edge( $current, $v );
}
if (exists $self->{ pre_edge }) {
my $p = $self->{ pre_edge };
my $u = $self->current;
for my $v (@next) {
$p->( $u, $v, $self, $self->{ state });
}
}
last;
} else {
$self->visit_postorder;
}
return undef if $self->{ terminate };
$self->_callbacks($current, @all);
# delete $next{ $current };
}
print "next.4 - @next\n" if DEBUG;
unless (@next) {
unless ( @{ $self->{ roots } } ) {
my $first = $self->{ first_root };
if (defined $first) {
@next =
ref $first eq 'CODE' ?
$self->{ first_root }->( $self, $self->{ unseen } ) :
$first;
return unless @next;
}
}
unless (@next) {
return unless defined $self->{ next_root };
return unless @next =
$self->{ next_root }->( $self, $self->{ unseen } );
}
return if exists $self->{ seen }->{ $next[0] }; # Sanity check.
print "next.5 - @next\n" if DEBUG;
push @{ $self->{ roots } }, $next[0];
}
print "next.6 - @next\n" if DEBUG;
if (@next) {
$self->visit_preorder( @next );
}
return $next[0];
}
sub _order {
my ($self, $order) = @_;
1 while defined $self->next;
my $wantarray = wantarray;
if ($wantarray) {
@{ $self->{ $order } };
} elsif (defined $wantarray) {
shift @{ $self->{ $order } };
}
}
sub preorder {
my $self = shift;
$self->_order( 'preorder' );
}
sub postorder {
my $self = shift;
$self->_order( 'postorder' );
}
sub unseen {
my $self = shift;
values %{ $self->{ unseen } };
}
sub seen {
my $self = shift;
values %{ $self->{ seen } };
}
sub seeing {
my $self = shift;
@{ $self->{ order } };
}
sub roots {
my $self = shift;
@{ $self->{ roots } };
}
sub is_root {
my ($self, $v) = @_;
for my $u (@{ $self->{ roots } }) {
return 1 if $u eq $v;
}
return 0;
}
sub tree {
my $self = shift;
$self->{ tree };
}
sub graph {
my $self = shift;
$self->{ graph };
}
sub vertex_by_postorder {
my ($self, $i) = @_;
exists $self->{ postorder } && $self->{ postorder }->[ $i ];
}
sub postorder_by_vertex {
my ($self, $v) = @_;
exists $self->{ postordern } && $self->{ postordern }->{ $v };
}
sub postorder_vertices {
my ($self, $v) = @_;
exists $self->{ postordern } ? %{ $self->{ postordern } } : ();
}
sub vertex_by_preorder {
my ($self, $i) = @_;
exists $self->{ preorder } && $self->{ preorder }->[ $i ];
}
sub preorder_by_vertex {
my ($self, $v) = @_;
exists $self->{ preordern } && $self->{ preordern }->{ $v };
}
sub preorder_vertices {
my ($self, $v) = @_;
exists $self->{ preordern } ? %{ $self->{ preordern } } : ();
}
sub has_state {
my ($self, $var) = @_;
exists $self->{ state } && exists $self->{ state }->{ $var };
}
sub get_state {
my ($self, $var) = @_;
exists $self->{ state } ? $self->{ state }->{ $var } : undef;
}
sub set_state {
my ($self, $var, $val) = @_;
$self->{ state }->{ $var } = $val;
return 1;
}
sub delete_state {
my ($self, $var) = @_;
delete $self->{ state }->{ $var };
delete $self->{ state } unless keys %{ $self->{ state } };
return 1;
}
1;
__END__
=pod
=head1 NAME
Graph::Traversal - traverse graphs
=head1 SYNOPSIS
Don't use Graph::Traversal directly, use Graph::Traversal::DFS
or Graph::Traversal::BFS instead.
use Graph;
my $g = Graph->new;
$g->add_edge(...);
use Graph::Traversal::...;
my $t = Graph::Traversal::...->new(%opt);
$t->...
=head1 DESCRIPTION
You can control how the graph is traversed by the various callback
parameters in the C<%opt>. In the parameters descriptions below the
$u and $v are vertices, and the $self is the traversal object itself.
=head2 Callback parameters
The following callback parameters are available:
=over 4
=item tree_edge
Called when traversing an edge that belongs to the traversal tree.
Called with arguments ($u, $v, $self).
=item non_tree_edge
Called when an edge is met which either leads back to the traversal tree
(either a C<back_edge>, a C<down_edge>, or a C<cross_edge>).
Called with arguments ($u, $v, $self).
=item pre_edge
Called for edges in preorder.
Called with arguments ($u, $v, $self).
=item post_edge
Called for edges in postorder.
Called with arguments ($u, $v, $self).
=item back_edge
Called for back edges.
Called with arguments ($u, $v, $self).
=item down_edge
Called for down edges.
Called with arguments ($u, $v, $self).
=item cross_edge
Called for cross edges.
Called with arguments ($u, $v, $self).
=item pre
=item pre_vertex
Called for vertices in preorder.
Called with arguments ($v, $self).
=item post
=item post_vertex
Called for vertices in postorder.
Called with arguments ($v, $self).
=item first_root
Called when choosing the first root (start) vertex for traversal.
Called with arguments ($self, $unseen) where $unseen is a hash
reference with the unseen vertices as keys.
=item next_root
Called when choosing the next root (after the first one) vertex for
traversal (useful when the graph is not connected). Called with
arguments ($self, $unseen) where $unseen is a hash reference with
the unseen vertices as keys. If you want only the first reachable
subgraph to be processed, set the next_root to C<undef>.
=item start
Identical to defining C<first_root> and undefining C<next_root>.
=item next_alphabetic
Set this to true if you want the vertices to be processed in
alphabetic order (and leave first_root/next_root undefined).
=item next_numeric
Set this to true if you want the vertices to be processed in
numeric order (and leave first_root/next_root undefined).
=item next_successor
Called when choosing the next vertex to visit. Called with arguments
($self, $next) where $next is a hash reference with the possible
next vertices as keys. Use this to provide a custom ordering for
choosing vertices, as opposed to C<next_numeric> or C<next_alphabetic>.
=back
The parameters C<first_root> and C<next_successor> have a 'hierarchy'
of how they are determined: if they have been explicitly defined, use
that value. If not, use the value of C<next_alphabetic>, if that has
been defined. If not, use the value of C<next_numeric>, if that has
been defined. If not, the next vertex to be visited is chose randomly.
=head2 Methods
The following methods are available:
=over 4
=item unseen
Return the unseen vertices in random order.
=item seen
Return the seen vertices in random order.
=item seeing
Return the active fringe vertices in random order.
=item preorder
Return the vertices in preorder traversal order.
=item postorder
Return the vertices in postorder traversal order.
=item vertex_by_preorder
$v = $t->vertex_by_preorder($i)
Return the ith (0..$V-1) vertex by preorder.
=item preorder_by_vertex
$i = $t->preorder_by_vertex($v)
Return the preorder index (0..$V-1) by vertex.
=item vertex_by_postorder
$v = $t->vertex_by_postorder($i)
Return the ith (0..$V-1) vertex by postorder.
=item postorder_by_vertex
$i = $t->postorder_by_vertex($v)
Return the postorder index (0..$V-1) by vertex.
=item preorder_vertices
Return a hash with the vertices as the keys and their preorder indices
as the values.
=item postorder_vertices
Return a hash with the vertices as the keys and their postorder
indices as the values.
=item tree
Return the traversal tree as a graph.
=item has_state
$t->has_state('s')
Test whether the traversal has state 's' attached to it.
=item get_state
$t->get_state('s')
Get the state 's' attached to the traversal (C<undef> if none).
=item set_state
$t->set_state('s', $s)
Set the state 's' attached to the traversal.
=item delete_state
$t->delete_state('s')
Delete the state 's' from the traversal.
=back
=head2 Backward compatibility
The following parameters are for backward compatibility to Graph 0.2xx:
=over 4
=item get_next_root
Like C<next_root>.
=item successor
Identical to having C<tree_edge> both C<non_tree_edge> defined
to be the same.
=item unseen_successor
Like C<tree_edge>.
=item seen_successor
Like C<seed_edge>.
=back
=head2 Special callbacks
If in a callback you call the special C<terminate> method,
the traversal is terminated, no more vertices are traversed.
=head1 SEE ALSO
L<Graph::Traversal::DFS>, L<Graph::Traversal::BFS>
=head1 AUTHOR AND COPYRIGHT
Jarkko Hietaniemi F<jhi@iki.fi>
=head1 LICENSE
This module is licensed under the same terms as Perl itself.
=cut

59
perllib/Graph/Traversal/BFS.pm Normal file
View file

@ -0,0 +1,59 @@
package Graph::Traversal::BFS;
use strict;
use Graph::Traversal;
use base 'Graph::Traversal';
sub current {
my $self = shift;
$self->{ order }->[ 0 ];
}
sub see {
my $self = shift;
shift @{ $self->{ order } };
}
*bfs = \&Graph::Traversal::postorder;
1;
__END__
=pod
=head1 NAME
Graph::Traversal::BFS - breadth-first traversal of graphs
=head1 SYNOPSIS
use Graph;
my $g = Graph->new;
$g->add_edge(...);
use Graph::Traversal::BFS;
my $b = Graph::Traversal::BFS->new(%opt);
$b->bfs; # Do the traversal.
=head1 DESCRIPTION
With this class one can traverse a Graph in breadth-first order.
The callback parameters %opt are explained in L<Graph::Traversal>.
=head2 Methods
The following methods are available:
=over 4
=item dfs
Traverse the graph in depth-first order.
=back
=head1 SEE ALSO
L<Graph::Traversal>, L<Graph::Traversal::DFS>, L<Graph>.
=cut

59
perllib/Graph/Traversal/DFS.pm Normal file
View file

@ -0,0 +1,59 @@
package Graph::Traversal::DFS;
use strict;
use Graph::Traversal;
use base 'Graph::Traversal';
sub current {
my $self = shift;
$self->{ order }->[ -1 ];
}
sub see {
my $self = shift;
pop @{ $self->{ order } };
}
*dfs = \&Graph::Traversal::postorder;
1;
__END__
=pod
=head1 NAME
Graph::Traversal::DFS - depth-first traversal of graphs
=head1 SYNOPSIS
use Graph;
my $g = Graph->new;
$g->add_edge(...);
use Graph::Traversal::DFS;
my $d = Graph::Traversal::DFS->new(%opt);
$d->dfs; # Do the traversal.
=head1 DESCRIPTION
With this class one can traverse a Graph in depth-first order.
The callback parameters %opt are explained in L<Graph::Traversal>.
=head2 Methods
The following methods are available:
=over 4
=item dfs
Traverse the graph in depth-first order.
=back
=head1 SEE ALSO
L<Graph::Traversal>, L<Graph::Traversal::BFS>, L<Graph>.
=cut

49
perllib/Graph/Undirected.pm Normal file
View file

@ -0,0 +1,49 @@
package Graph::Undirected;
use Graph;
use base 'Graph';
use strict;
=pod
=head1 NAME
Graph::Undirected - undirected graphs
=head1 SYNOPSIS
use Graph::Undirected;
my $g = Graph::Undirected->new;
# Or alternatively:
use Graph;
my $g = Graph->new(undirected => 1);
my $g = Graph->new(directed => 0);
=head1 DESCRIPTION
Graph::Undirected allows you to create undirected graphs.
For the available methods, see L<Graph>.
=head1 SEE ALSO
L<Graph>, L<Graph::Directed>
=head1 AUTHOR AND COPYRIGHT
Jarkko Hietaniemi F<jhi@iki.fi>
=head1 LICENSE
This module is licensed under the same terms as Perl itself.
=cut
sub new {
my $class = shift;
bless Graph->new(undirected => 1, @_), ref $class || $class;
}
1;

183
perllib/Graph/UnionFind.pm Normal file
View file

@ -0,0 +1,183 @@
package Graph::UnionFind;
use strict;
sub _PARENT () { 0 }
sub _RANK () { 1 }
sub new {
my $class = shift;
bless { }, $class;
}
sub add {
my ($self, $elem) = @_;
$self->{ $elem } = [ $elem, 0 ];
}
sub has {
my ($self, $elem) = @_;
exists $self->{ $elem };
}
sub _parent {
return undef unless defined $_[1];
if (@_ == 2) {
exists $_[0]->{ $_[ 1 ] } ? $_[0]->{ $_[1] }->[ _PARENT ] : undef;
} elsif (@_ == 3) {
$_[0]->{ $_[1] }->[ _PARENT ] = $_[2];
} else {
require Carp;
Carp::croak(__PACKAGE__ . "::_parent: bad arity");
}
}
sub _rank {
return unless defined $_[1];
if (@_ == 2) {
exists $_[0]->{ $_[1] } ? $_[0]->{ $_[1] }->[ _RANK ] : undef;
} elsif (@_ == 3) {
$_[0]->{ $_[1] }->[ _RANK ] = $_[2];
} else {
require Carp;
Carp::croak(__PACKAGE__ . "::_rank: bad arity");
}
}
sub find {
my ($self, $x) = @_;
my $px = $self->_parent( $x );
return unless defined $px;
$self->_parent( $x, $self->find( $px ) ) if $px ne $x;
$self->_parent( $x );
}
sub union {
my ($self, $x, $y) = @_;
$self->add($x) unless $self->has($x);
$self->add($y) unless $self->has($y);
my $px = $self->find( $x );
my $py = $self->find( $y );
return if $px eq $py;
my $rx = $self->_rank( $px );
my $ry = $self->_rank( $py );
# print "union($x, $y): px = $px, py = $py, rx = $rx, ry = $ry\n";
if ( $rx > $ry ) {
$self->_parent( $py, $px );
} else {
$self->_parent( $px, $py );
$self->_rank( $py, $ry + 1 ) if $rx == $ry;
}
}
sub same {
my ($uf, $u, $v) = @_;
my $fu = $uf->find($u);
return undef unless defined $fu;
my $fv = $uf->find($v);
return undef unless defined $fv;
$fu eq $fv;
}
1;
__END__
=pod
=head1 NAME
Graph::UnionFind - union-find data structures
=head1 SYNOPSIS
use Graph::UnionFind;
my $uf = Graph::UnionFind->new;
# Add the vertices to the data structure.
$uf->add($u);
$uf->add($v);
# Join the partitions of the vertices.
$uf->union( $u, $v );
# Find the partitions the vertices belong to
# in the union-find data structure. If they
# are equal, they are in the same partition.
# If the vertex has not been seen,
# undef is returned.
my $pu = $uf->find( $u );
my $pv = $uf->find( $v );
$uf->same($u, $v) # Equal to $pu eq $pv.
# Has the union-find seen this vertex?
$uf->has( $v )
=head1 DESCRIPTION
I<Union-find> is a special data structure that can be used to track the
partitioning of a set into subsets (a problem known also as I<disjoint sets>).
Graph::UnionFind() is used for Graph::connected_components(),
Graph::connected_component(), and Graph::same_connected_components()
if you specify a true C<union_find> parameter when you create an undirected
graph.
Note that union-find is one way: you cannot (easily) 'ununion'
vertices once you have 'unioned' them. This means that if you
delete edges from a C<union_find> graph, you will get wrong results
from the Graph::connected_components(), Graph::connected_component(),
and Graph::same_connected_components().
=head2 API
=over 4
=item add
$uf->add($v)
Add the vertex v to the union-find.
=item union
$uf->union($u, $v)
Add the edge u-v to the union-find. Also implicitly adds the vertices.
=item has
$uf->has($v)
Return true if the vertex v has been added to the union-find, false otherwise.
=item find
$uf->find($v)
Return the union-find partition the vertex v belongs to,
or C<undef> if it has not been added.
=item new
$uf = Graph::UnionFind->new()
The constructor.
=item same
$uf->same($u, $v)
Return true of the vertices belong to the same union-find partition
the vertex v belongs to, false otherwise.
=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

159
perllib/Heap071/Elem.pm Normal file
View file

@ -0,0 +1,159 @@
package Heap071::Elem;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
require Exporter;
require AutoLoader;
@ISA = qw(Exporter AutoLoader);
# No names exported.
# No names available for export.
@EXPORT = ( );
$VERSION = '0.71';
# Preloaded methods go here.
# new will usually be superceded by child,
# but provide an empty hash as default and
# accept any provided filling for it.
sub new {
my $self = shift;
my $class = ref($self) || $self;
return bless { heap=>undef, @_ }, $class;
}
sub heap {
my $self = shift;
@_ ? ($self->{heap} = shift) : $self->{heap};
}
sub cmp {
die "This cmp method must be superceded by one that knows how to compare elements."
}
# Autoload methods go after =cut, and are processed by the autosplit program.
1;
__END__
# Below is the stub of documentation for your module. You better edit it!
=head1 NAME
Heap::Elem - Perl extension for elements to be put in Heaps
=head1 SYNOPSIS
use Heap::Elem::SomeInheritor;
use Heap::SomeHeapClass;
$elem = Heap::Elem::SomeInheritor->new( $value );
$heap = Heap::SomeHeapClass->new;
$heap->add($elem);
=head1 DESCRIPTION
This is an inheritable class for Heap Elements. It provides
the interface documentation and some inheritable methods.
Only a child classes can be used - this class is not complete.
=head1 METHODS
=over 4
=item $elem = Heap::Elem::SomeInheritor->new( [args] );
Creates a new Elem.
=item $elem->heap( $val ); $elem->heap;
Provides a method for use by the Heap processing routines.
If a value argument is provided, it will be saved. The
new saved value is always returned. If no value argument
is provided, the old saved value is returned.
The Heap processing routines use this method to map an element
into its internal structure. This is needed to support the
Heap methods that affect elements that are not are the top
of the heap - I<decrease_key> and I<delete>.
The Heap processing routines will ensure that this value is
undef when this elem is removed from a heap, and is not undef
after it is inserted into a heap. This means that you can
check whether an element is currently contained within a heap
or not. (It cannot be used to determine which heap an element
is contained in, if you have multiple heaps. Keeping that
information accurate would make the operation of merging two
heaps into a single one take longer - it would have to traverse
all of the elements in the merged heap to update them; for
Binomial and Fibonacci heaps that would turn an O(1) operation
into an O(n) one.)
=item $elem1->cmp($elem2)
A routine to compare two elements. It must return a negative
value if this element should go higher on the heap than I<$elem2>,
0 if they are equal, or a positive value if this element should
go lower on the heap than I<$elem2>. Just as with sort, the
Perl operators <=> and cmp cause the smaller value to be returned
first; similarly you can negate the meaning to reverse the order
- causing the heap to always return the largest element instead
of the smallest.
=back
=head1 INHERITING
This class can be inherited to provide an oject with the
ability to be heaped. If the object is implemented as
a hash, and if it can deal with a key of I<heap>, leaving
it unchanged for use by the heap routines, then the following
implemetation will work.
package myObject;
require Exporter;
@ISA = qw(Heap::Elem);
sub new {
my $self = shift;
my $class = ref($self) || $self;
my $self = SUPER::new($class);
# set $self->{key} = $value;
}
sub cmp {
my $self = shift;
my $other = shift;
$self->{key} cmp $other->{key};
}
# other methods for the rest of myObject's functionality
=head1 AUTHOR
John Macdonald, jmm@perlwolf.com
=head1 COPYRIGHT
Copyright 1998-2003, O'Reilly & Associates.
This code is distributed under the same copyright terms as perl itself.
=head1 SEE ALSO
Heap(3), Heap::Elem::Num(3), Heap::Elem::NumRev(3),
Heap::Elem::Str(3), Heap::Elem::StrRev(3).
=cut

482
perllib/Heap071/Fibonacci.pm Normal file
View file

@ -0,0 +1,482 @@
package Heap071::Fibonacci;
use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
require Exporter;
require AutoLoader;
@ISA = qw(Exporter AutoLoader);
# No names exported.
# No names available for export.
@EXPORT = ( );
$VERSION = '0.71';
# Preloaded methods go here.
# common names
# h - heap head
# el - linkable element, contains user-provided value
# v - user-provided value
################################################# debugging control
my $debug = 0;
my $validate = 0;
# enable/disable debugging output
sub debug {
@_ ? ($debug = shift) : $debug;
}
# enable/disable validation checks on values
sub validate {
@_ ? ($validate = shift) : $validate;
}
my $width = 3;
my $bar = ' | ';
my $corner = ' +-';
my $vfmt = "%3d";
sub set_width {
$width = shift;
$width = 2 if $width < 2;
$vfmt = "%${width}d";
$bar = $corner = ' ' x $width;
substr($bar,-2,1) = '|';
substr($corner,-2,2) = '+-';
}
sub hdump;
sub hdump {
my $el = shift;
my $l1 = shift;
my $b = shift;
my $ch;
my $ch1;
unless( $el ) {
print $l1, "\n";
return;
}
hdump $ch1 = $el->{child},
$l1 . sprintf( $vfmt, $el->{val}->val),
$b . $bar;
if( $ch1 ) {
for( $ch = $ch1->{right}; $ch != $ch1; $ch = $ch->{right} ) {
hdump $ch, $b . $corner, $b . $bar;
}
}
}
sub heapdump {
my $h;
while( $h = shift ) {
my $top = $$h or last;
my $el = $top;
do {
hdump $el, sprintf( "%02d: ", $el->{degree}), ' ';
$el = $el->{right};
} until $el == $top;
print "\n";
}
}
sub bhcheck;
sub bhcheck {
my $el = shift;
my $p = shift;
my $cur = $el;
my $prev;
my $ch;
do {
$prev = $cur;
$cur = $cur->{right};
die "bad back link" unless $cur->{left} == $prev;
die "bad parent link"
unless (defined $p && defined $cur->{p} && $cur->{p} == $p)
|| (!defined $p && !defined $cur->{p});
die "bad degree( $cur->{degree} > $p->{degree} )"
if $p && $p->{degree} <= $cur->{degree};
die "not heap ordered"
if $p && $p->{val}->cmp($cur->{val}) > 0;
$ch = $cur->{child} and bhcheck $ch, $cur;
} until $cur == $el;
}
sub heapcheck {
my $h;
my $el;
while( $h = shift ) {
heapdump $h if $validate >= 2;
$el = $$h and bhcheck $el, undef;
}
}
################################################# forward declarations
sub ascending_cut;
sub elem;
sub elem_DESTROY;
sub link_to_left_of;
################################################# heap methods
# Cormen et al. use two values for the heap, a pointer to an element in the
# list at the top, and a count of the number of elements. The count is only
# used to determine the size of array required to hold log(count) pointers,
# but perl can set array sizes as needed and doesn't need to know their size
# when they are created, so we're not maintaining that field.
sub new {
my $self = shift;
my $class = ref($self) || $self;
my $h = undef;
bless \$h, $class;
}
sub DESTROY {
my $h = shift;
elem_DESTROY $$h;
}
sub add {
my $h = shift;
my $v = shift;
$validate && do {
die "Method 'heap' required for element on heap"
unless $v->can('heap');
die "Method 'cmp' required for element on heap"
unless $v->can('cmp');
};
my $el = elem $v;
my $top;
if( !($top = $$h) ) {
$$h = $el;
} else {
link_to_left_of $top->{left}, $el ;
link_to_left_of $el,$top;
$$h = $el if $v->cmp($top->{val}) < 0;
}
}
sub top {
my $h = shift;
$$h && $$h->{val};
}
*minimum = \&top;
sub extract_top {
my $h = shift;
my $el = $$h or return undef;
my $ltop = $el->{left};
my $cur;
my $next;
# $el is the heap with the lowest value on it
# move all of $el's children (if any) to the top list (between
# $ltop and $el)
if( $cur = $el->{child} ) {
# remember the beginning of the list of children
my $first = $cur;
do {
# the children are moving to the top, clear the p
# pointer for all of them
$cur->{p} = undef;
} until ($cur = $cur->{right}) == $first;
# remember the end of the list
$cur = $cur->{left};
link_to_left_of $ltop, $first;
link_to_left_of $cur, $el;
}
if( $el->{right} == $el ) {
# $el had no siblings or children, the top only contains $el
# and $el is being removed
$$h = undef;
} else {
link_to_left_of $el->{left}, $$h = $el->{right};
# now all those loose ends have to be merged together as we
# search for the
# new smallest element
$h->consolidate;
}
# extract the actual value and return that, $el is no longer used
# but break all of its links so that it won't be pointed to...
my $top = $el->{val};
$top->heap(undef);
$el->{left} = $el->{right} = $el->{p} = $el->{child} = $el->{val} =
undef;
$top;
}
*extract_minimum = \&extract_top;
sub absorb {
my $h = shift;
my $h2 = shift;
my $el = $$h;
unless( $el ) {
$$h = $$h2;
$$h2 = undef;
return $h;
}
my $el2 = $$h2 or return $h;
# add $el2 and its siblings to the head list for $h
# at start, $ell -> $el -> ... -> $ell is on $h (where $ell is
# $el->{left})
# $el2l -> $el2 -> ... -> $el2l are on $h2
# at end, $ell -> $el2l -> ... -> $el2 -> $el -> ... -> $ell are
# all on $h
my $el2l = $el2->{left};
link_to_left_of $el->{left}, $el2;
link_to_left_of $el2l, $el;
# change the top link if needed
$$h = $el2 if $el->{val}->cmp( $el2->{val} ) > 0;
# clean out $h2
$$h2 = undef;
# return the heap
$h;
}
# a key has been decreased, it may have to percolate up in its heap
sub decrease_key {
my $h = shift;
my $top = $$h;
my $v = shift;
my $el = $v->heap or return undef;
my $p;
# first, link $h to $el if it is now the smallest (we will
# soon link $el to $top to properly put it up to the top list,
# if it isn't already there)
$$h = $el if $top->{val}->cmp( $v ) > 0;
if( $p = $el->{p} and $v->cmp($p->{val}) < 0 ) {
# remove $el from its parent's list - it is now smaller
ascending_cut $top, $p, $el;
}
$v;
}
# to delete an item, we bubble it to the top of its heap (as if its key
# had been decreased to -infinity), and then remove it (as in extract_top)
sub delete {
my $h = shift;
my $v = shift;
my $el = $v->heap or return undef;
# if there is a parent, cut $el to the top (as if it had just had its
# key decreased to a smaller value than $p's value
my $p;
$p = $el->{p} and ascending_cut $$h, $p, $el;
# $el is in the top list now, make it look like the smallest and
# remove it
$$h = $el;
$h->extract_top;
}
################################################# internal utility functions
sub elem {
my $v = shift;
my $el = undef;
$el = {
p => undef,
degree => 0,
mark => 0,
child => undef,
val => $v,
left => undef,
right => undef,
};
$el->{left} = $el->{right} = $el;
$v->heap($el);
$el;
}
sub elem_DESTROY {
my $el = shift;
my $ch;
my $next;
$el->{left}->{right} = undef;
while( $el ) {
$ch = $el->{child} and elem_DESTROY $ch;
$next = $el->{right};
defined $el->{val} and $el->{val}->heap(undef);
$el->{child} = $el->{right} = $el->{left} = $el->{p} = $el->{val}
= undef;
$el = $next;
}
}
sub link_to_left_of {
my $l = shift;
my $r = shift;
$l->{right} = $r;
$r->{left} = $l;
}
sub link_as_parent_of {
my $p = shift;
my $c = shift;
my $pc;
if( $pc = $p->{child} ) {
link_to_left_of $pc->{left}, $c;
link_to_left_of $c, $pc;
} else {
link_to_left_of $c, $c;
}
$p->{child} = $c;
$c->{p} = $p;
$p->{degree}++;
$c->{mark} = 0;
$p;
}
sub consolidate {
my $h = shift;
my $cur;
my $this;
my $next = $$h;
my $last = $next->{left};
my @a;
do {
# examine next item on top list
$this = $cur = $next;
$next = $cur->{right};
my $d = $cur->{degree};
my $alt;
while( $alt = $a[$d] ) {
# we already saw another item of the same degree,
# put the larger valued one under the smaller valued
# one - switch $cur and $alt if necessary so that $cur
# is the smaller
($cur,$alt) = ($alt,$cur)
if $cur->{val}->cmp( $alt->{val} ) > 0;
# remove $alt from the top list
link_to_left_of $alt->{left}, $alt->{right};
# and put it under $cur
link_as_parent_of $cur, $alt;
# make sure that $h still points to a node at the top
$$h = $cur;
# we've removed the old $d degree entry
$a[$d] = undef;
# and we now have a $d+1 degree entry to try to insert
# into @a
++$d;
}
# found a previously unused degree
$a[$d] = $cur;
} until $this == $last;
$cur = $$h;
for $cur (grep defined, @a) {
$$h = $cur if $$h->{val}->cmp( $cur->{val} ) > 0;
}
}
sub ascending_cut {
my $top = shift;
my $p = shift;
my $el = shift;
while( 1 ) {
if( --$p->{degree} ) {
# there are still other children below $p
my $l = $el->{left};
$p->{child} = $l;
link_to_left_of $l, $el->{right};
} else {
# $el was the only child of $p
$p->{child} = undef;
}
link_to_left_of $top->{left}, $el;
link_to_left_of $el, $top;
$el->{p} = undef;
$el->{mark} = 0;
# propagate up the list
$el = $p;
# quit at the top
last unless $p = $el->{p};
# quit if we can mark $el
$el->{mark} = 1, last unless $el->{mark};
}
}
1;
__END__
=head1 NAME
Heap::Fibonacci - a Perl extension for keeping data partially sorted
=head1 SYNOPSIS
use Heap::Fibonacci;
$heap = Heap::Fibonacci->new;
# see Heap(3) for usage
=head1 DESCRIPTION
Keeps elements in heap order using a linked list of Fibonacci trees.
The I<heap> method of an element is used to store a reference to
the node in the list that refers to the element.
See L<Heap> for details on using this module.
=head1 AUTHOR
John Macdonald, jmm@perlwolf.com
=head1 COPYRIGHT
Copyright 1998-2003, O'Reilly & Associates.
This code is distributed under the same copyright terms as perl itself.
=head1 SEE ALSO
Heap(3), Heap::Elem(3).
=cut