mirror of
https://github.com/netwide-assembler/nasm.git
synced 2024-11-21 03:14:19 +08:00
phash: massively speed up the perfect hash generator
Make the perfect hash generator about 200x faster by using a very simple custom graph adjacency representation instead of using Graph::Undirected.
This commit is contained in:
H. Peter Anvin
parent
216fea010d
commit
c593173e11
3851
perllib/Graph.pm
3851
perllib/Graph.pm
File diff suppressed because it is too large
Load Diff
2768
perllib/Graph.pod
2768
perllib/Graph.pod
File diff suppressed because it is too large
Load Diff
@ -1,473 +0,0 @@
|
||||
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
|
||||
@ -1,253 +0,0 @@
|
||||
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__
|
||||
@ -1,247 +0,0 @@
|
||||
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;
|
||||
@ -1,216 +0,0 @@
|
||||
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
|
||||
@ -1,223 +0,0 @@
|
||||
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
|
||||
@ -1,130 +0,0 @@
|
||||
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;
|
||||
@ -1,227 +0,0 @@
|
||||
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
|
||||
@ -1,44 +0,0 @@
|
||||
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;
|
||||
@ -1,24 +0,0 @@
|
||||
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;
|
||||
@ -1,82 +0,0 @@
|
||||
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
|
||||
@ -1,26 +0,0 @@
|
||||
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;
|
||||
@ -1,155 +0,0 @@
|
||||
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
|
||||
@ -1,488 +0,0 @@
|
||||
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
|
||||
@ -1,714 +0,0 @@
|
||||
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
|
||||
@ -1,59 +0,0 @@
|
||||
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
|
||||
@ -1,59 +0,0 @@
|
||||
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
|
||||
@ -1,49 +0,0 @@
|
||||
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;
|
||||
@ -1,183 +0,0 @@
|
||||
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
|
||||
|
||||
@ -1,159 +0,0 @@
|
||||
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
|
||||
@ -1,482 +0,0 @@
|
||||
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 = \⊤
|
||||
|
||||
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
|
||||
@ -6,7 +6,6 @@
|
||||
# Requires the CPAN Graph module (tested against 0.81, 0.83, 0.84)
|
||||
#
|
||||
|
||||
use Graph::Undirected;
|
||||
require 'random_sv_vectors.ph';
|
||||
require 'crc64.ph';
|
||||
|
||||
@ -27,28 +26,34 @@ sub prehash($$$) {
|
||||
}
|
||||
|
||||
#
|
||||
# Walk the assignment graph
|
||||
# Walk the assignment graph, return true on success
|
||||
#
|
||||
sub walk_graph($$$) {
|
||||
my($gr,$n,$v) = @_;
|
||||
sub walk_graph($$$$) {
|
||||
my($nodeval,$nodeneigh,$n,$v) = @_;
|
||||
my $nx;
|
||||
|
||||
# print STDERR "Vertex $n value $v\n";
|
||||
$gr->set_vertex_attribute($n,"val",$v);
|
||||
$$nodeval[$n] = $v;
|
||||
|
||||
foreach $nx ($gr->neighbors($n)) {
|
||||
die unless ($gr->has_edge_attribute($n, $nx, "hash"));
|
||||
my $e = $gr->get_edge_attribute($n, $nx, "hash");
|
||||
foreach $nx (@{$$nodeneigh[$n]}) {
|
||||
# $nx -> [neigh, hash]
|
||||
my ($o, $e) = @$nx;
|
||||
|
||||
# print STDERR "Edge $n=$nx value $e: ";
|
||||
|
||||
if ($gr->has_vertex_attribute($nx, "val")) {
|
||||
die if ($v+$gr->get_vertex_attribute($nx, "val") != $e);
|
||||
# print STDERR "ok\n";
|
||||
# print STDERR "Edge $n,$o value $e: ";
|
||||
my $ov;
|
||||
if (defined($ov = $$nodeval[$o])) {
|
||||
if ($v+$ov != $e) {
|
||||
# Cyclic graph with collision
|
||||
# print STDERR "error, should be ", $v+$ov, "\n";
|
||||
return 0;
|
||||
} else {
|
||||
# print STDERR "ok\n";
|
||||
}
|
||||
} else {
|
||||
walk_graph($gr, $nx, $e-$v);
|
||||
return 0 unless (walk_graph($nodeval, $nodeneigh, $o, $e-$v));
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
#
|
||||
@ -59,63 +64,57 @@ sub walk_graph($$$) {
|
||||
sub gen_hash_n($$$$) {
|
||||
my($n, $sv, $href, $run) = @_;
|
||||
my @keys = keys(%{$href});
|
||||
my $i, $sv, @g;
|
||||
my $i, $sv;
|
||||
my $gr;
|
||||
my $k, $v;
|
||||
my $gsize = 2*$n;
|
||||
my @nodeval;
|
||||
my @nodeneigh;
|
||||
my %edges;
|
||||
|
||||
$gr = Graph::Undirected->new;
|
||||
for ($i = 0; $i < $gsize; $i++) {
|
||||
$gr->add_vertex($i);
|
||||
$nodeneigh[$i] = [];
|
||||
}
|
||||
|
||||
%edges = ();
|
||||
foreach $k (@keys) {
|
||||
my ($pf1, $pf2) = prehash($k, $n, $sv);
|
||||
my $pf = "$pf1,$pf2";
|
||||
my $e = ${$href}{$k};
|
||||
my $xkey;
|
||||
|
||||
if ($gr->has_edge($pf1, $pf2)) {
|
||||
my $xkey = $gr->get_edge_attribute($pf1, $pf2, "key");
|
||||
my ($xp1, $xp2) = prehash($xkey, $n, $sv);
|
||||
if (defined($xkey = $edges{$pf})) {
|
||||
if (defined($run)) {
|
||||
print STDERR "$run: Collision: $pf1=$pf2 $k with ";
|
||||
print STDERR "$xkey ($xp1,$xp2)\n";
|
||||
print STDERR "$run: Collision: $pf: $k with $xkey\n";
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
# print STDERR "Edge $pf1=$pf2 value $e from $k\n";
|
||||
# print STDERR "Edge $pf value $e from $k\n";
|
||||
|
||||
$gr->add_edge($pf1, $pf2);
|
||||
$gr->set_edge_attribute($pf1, $pf2, "hash", $e);
|
||||
$gr->set_edge_attribute($pf1, $pf2, "key", $k);
|
||||
}
|
||||
|
||||
# At this point, we're good if the graph is acyclic.
|
||||
if ($gr->is_cyclic) {
|
||||
if (defined($run)) {
|
||||
print STDERR "$run: Graph is cyclic\n";
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
if (defined($run)) {
|
||||
print STDERR "$run: Graph OK, computing vertices...\n";
|
||||
$edges{$pf} = $k;
|
||||
push(@{$nodeneigh[$pf1]}, [$pf2, $e]);
|
||||
push(@{$nodeneigh[$pf2]}, [$pf1, $e]);
|
||||
}
|
||||
|
||||
# Now we need to assign values to each vertex, so that for each
|
||||
# edge, the sum of the values for the two vertices give the value
|
||||
# for the edge (which is our hash index.) Since the graph is
|
||||
# acyclic, this is always doable.
|
||||
# for the edge (which is our hash index.) If we find an impossible
|
||||
# sitation, the graph was cyclic.
|
||||
@nodeval = (undef) x $gsize;
|
||||
|
||||
for ($i = 0; $i < $gsize; $i++) {
|
||||
if ($gr->degree($i)) {
|
||||
if (scalar(@{$nodeneigh[$i]})) {
|
||||
# This vertex has neighbors (is used)
|
||||
if (!$gr->has_vertex_attribute($i, "val")) {
|
||||
walk_graph($gr,$i,0); # First vertex in a cluster
|
||||
if (!defined($nodeval[$i])) {
|
||||
# First vertex in a cluster
|
||||
unless (walk_graph(\@nodeval, \@nodeneigh, $i, 0)) {
|
||||
if (defined($run)) {
|
||||
print STDERR "$run: Graph is cyclic\n";
|
||||
}
|
||||
return;
|
||||
}
|
||||
}
|
||||
push(@g, $gr->get_vertex_attribute($i, "val"));
|
||||
} else {
|
||||
# Unused vertex
|
||||
push(@g, undef);
|
||||
}
|
||||
}
|
||||
|
||||
@ -128,7 +127,7 @@ sub gen_hash_n($$$$) {
|
||||
$$sv[0], $$sv[1];
|
||||
}
|
||||
|
||||
return ($n, $sv, \@g);
|
||||
return ($n, $sv, \@nodeval);
|
||||
}
|
||||
|
||||
#
|
||||
@ -180,7 +179,7 @@ sub read_input() {
|
||||
while (defined($l = <STDIN>)) {
|
||||
chomp $l;
|
||||
$l =~ s/\s*(\#.*|)$//;
|
||||
|
||||
|
||||
next if ($l eq '');
|
||||
|
||||
if ($l =~ /^([^=]+)\=([^=]+)$/) {
|
||||
|
||||
Loading…
Reference in New Issue
Block a user