summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorH. Peter Anvin <hpa@zytor.com>2008-05-25 18:10:57 -0700
committerH. Peter Anvin <hpa@zytor.com>2008-05-25 18:10:57 -0700
commitc593173e110244f99a3498cb3e23d6c3c07bae35 (patch)
treeb1a587f1dfbad9e33a06a6efc42394e9b25f58ef
parent216fea010dea4322996be0189e38668132545dc6 (diff)
downloadnasm-c593173e110244f99a3498cb3e23d6c3c07bae35.tar.gz
nasm-c593173e110244f99a3498cb3e23d6c3c07bae35.tar.bz2
nasm-c593173e110244f99a3498cb3e23d6c3c07bae35.zip
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.
-rw-r--r--perllib/Graph.pm3851
-rw-r--r--perllib/Graph.pod2768
-rw-r--r--perllib/Graph/AdjacencyMap.pm473
-rw-r--r--perllib/Graph/AdjacencyMap/Heavy.pm253
-rw-r--r--perllib/Graph/AdjacencyMap/Light.pm247
-rw-r--r--perllib/Graph/AdjacencyMap/Vertex.pm216
-rw-r--r--perllib/Graph/AdjacencyMatrix.pm223
-rw-r--r--perllib/Graph/Attribute.pm130
-rw-r--r--perllib/Graph/BitMatrix.pm227
-rw-r--r--perllib/Graph/Directed.pm44
-rw-r--r--perllib/Graph/MSTHeapElem.pm24
-rw-r--r--perllib/Graph/Matrix.pm82
-rw-r--r--perllib/Graph/SPTHeapElem.pm26
-rw-r--r--perllib/Graph/TransitiveClosure.pm155
-rw-r--r--perllib/Graph/TransitiveClosure/Matrix.pm488
-rw-r--r--perllib/Graph/Traversal.pm714
-rw-r--r--perllib/Graph/Traversal/BFS.pm59
-rw-r--r--perllib/Graph/Traversal/DFS.pm59
-rw-r--r--perllib/Graph/Undirected.pm49
-rw-r--r--perllib/Graph/UnionFind.pm183
-rw-r--r--perllib/Heap071/Elem.pm159
-rw-r--r--perllib/Heap071/Fibonacci.pm482
-rw-r--r--perllib/phash.ph101
23 files changed, 50 insertions, 10963 deletions
diff --git a/perllib/Graph.pm b/perllib/Graph.pm
deleted file mode 100644
index 3d1ad33..0000000
--- a/perllib/Graph.pm
+++ /dev/null
@@ -1,3851 +0,0 @@
-package Graph;
-
-use strict;
-
-BEGIN {
- if (0) { # SET THIS TO ZERO FOR TESTING AND RELEASES!
- $SIG{__DIE__ } = \&__carp_confess;
- $SIG{__WARN__} = \&__carp_confess;
- }
- sub __carp_confess { require Carp; Carp::confess(@_) }
-}
-
-use Graph::AdjacencyMap qw(:flags :fields);
-
-use vars qw($VERSION);
-
-$VERSION = '0.84';
-
-require 5.006; # Weak references are absolutely required.
-
-use Graph::AdjacencyMap::Heavy;
-use Graph::AdjacencyMap::Light;
-use Graph::AdjacencyMap::Vertex;
-use Graph::UnionFind;
-use Graph::TransitiveClosure;
-use Graph::Traversal::DFS;
-use Graph::MSTHeapElem;
-use Graph::SPTHeapElem;
-use Graph::Undirected;
-
-use Heap071::Fibonacci;
-use List::Util qw(shuffle first);
-use Scalar::Util qw(weaken);
-
-sub _F () { 0 } # Flags.
-sub _G () { 1 } # Generation.
-sub _V () { 2 } # Vertices.
-sub _E () { 3 } # Edges.
-sub _A () { 4 } # Attributes.
-sub _U () { 5 } # Union-Find.
-
-my $Inf;
-
-BEGIN {
- local $SIG{FPE};
- eval { $Inf = exp(999) } ||
- eval { $Inf = 9**9**9 } ||
- eval { $Inf = 1e+999 } ||
- { $Inf = 1e+99 }; # Close enough for most practical purposes.
-}
-
-sub Infinity () { $Inf }
-
-# Graphs are blessed array references.
-# - The first element contains the flags.
-# - The second element is the vertices.
-# - The third element is the edges.
-# - The fourth element is the attributes of the whole graph.
-# The defined flags for Graph are:
-# - _COMPAT02 for user API compatibility with the Graph 0.20xxx series.
-# The vertices are contained in either a "simplemap"
-# (if no hypervertices) or in a "map".
-# The edges are always in a "map".
-# The defined flags for maps are:
-# - _COUNT for countedness: more than one instance
-# - _HYPER for hyperness: a different number of "coordinates" than usual;
-# expects one for vertices and two for edges
-# - _UNORD for unordered coordinates (a set): if _UNORD is not set
-# the coordinates are assumed to be meaningfully ordered
-# - _UNIQ for unique coordinates: if set duplicates are removed,
-# if not, duplicates are assumed to meaningful
-# - _UNORDUNIQ: just a union of _UNORD and UNIQ
-# Vertices are assumed to be _UNORDUNIQ; edges assume none of these flags.
-
-use Graph::Attribute array => _A, map => 'graph';
-
-sub _COMPAT02 () { 0x00000001 }
-
-sub stringify {
- my $g = shift;
- my $o = $g->is_undirected;
- my $e = $o ? '=' : '-';
- my @e =
- map {
- my @v =
- map {
- ref($_) eq 'ARRAY' ? "[" . join(" ", @$_) . "]" : "$_"
- }
- @$_;
- join($e, $o ? sort { "$a" cmp "$b" } @v : @v) } $g->edges05;
- my @s = sort { "$a" cmp "$b" } @e;
- push @s, sort { "$a" cmp "$b" } $g->isolated_vertices;
- join(",", @s);
-}
-
-sub eq {
- "$_[0]" eq "$_[1]"
-}
-
-sub ne {
- "$_[0]" ne "$_[1]"
-}
-
-use overload
- '""' => \&stringify,
- 'eq' => \&eq,
- 'ne' => \&ne;
-
-sub _opt {
- my ($opt, $flags, %flags) = @_;
- while (my ($flag, $FLAG) = each %flags) {
- if (exists $opt->{$flag}) {
- $$flags |= $FLAG if $opt->{$flag};
- delete $opt->{$flag};
- }
- if (exists $opt->{my $non = "non$flag"}) {
- $$flags &= ~$FLAG if $opt->{$non};
- delete $opt->{$non};
- }
- }
-}
-
-sub is_compat02 {
- my ($g) = @_;
- $g->[ _F ] & _COMPAT02;
-}
-
-*compat02 = \&is_compat02;
-
-sub has_union_find {
- my ($g) = @_;
- ($g->[ _F ] & _UNIONFIND) && defined $g->[ _U ];
-}
-
-sub _get_union_find {
- my ($g) = @_;
- $g->[ _U ];
-}
-
-sub _opt_get {
- my ($opt, $key, $var) = @_;
- if (exists $opt->{$key}) {
- $$var = $opt->{$key};
- delete $opt->{$key};
- }
-}
-
-sub _opt_unknown {
- my ($opt) = @_;
- if (my @opt = keys %$opt) {
- my $f = (caller(1))[3];
- require Carp;
- Carp::confess(sprintf
- "$f: Unknown option%s: @{[map { qq['$_'] } sort @opt]}",
- @opt > 1 ? 's' : '');
- }
-}
-
-sub new {
- my $class = shift;
- my $gflags = 0;
- my $vflags;
- my $eflags;
- my %opt = _get_options( \@_ );
-
- if (ref $class && $class->isa('Graph')) {
- no strict 'refs';
- for my $c (qw(undirected refvertexed compat02
- hypervertexed countvertexed multivertexed
- hyperedged countedged multiedged omniedged)) {
-# $opt{$c}++ if $class->$c; # 5.00504-incompatible
- if (&{"Graph::$c"}($class)) { $opt{$c}++ }
- }
-# $opt{unionfind}++ if $class->has_union_find; # 5.00504-incompatible
- if (&{"Graph::has_union_find"}($class)) { $opt{unionfind}++ }
- }
-
- _opt_get(\%opt, undirected => \$opt{omniedged});
- _opt_get(\%opt, omnidirected => \$opt{omniedged});
-
- if (exists $opt{directed}) {
- $opt{omniedged} = !$opt{directed};
- delete $opt{directed};
- }
-
- my $vnonomni =
- $opt{nonomnivertexed} ||
- (exists $opt{omnivertexed} && !$opt{omnivertexed});
- my $vnonuniq =
- $opt{nonuniqvertexed} ||
- (exists $opt{uniqvertexed} && !$opt{uniqvertexed});
-
- _opt(\%opt, \$vflags,
- countvertexed => _COUNT,
- multivertexed => _MULTI,
- hypervertexed => _HYPER,
- omnivertexed => _UNORD,
- uniqvertexed => _UNIQ,
- refvertexed => _REF,
- );
-
- _opt(\%opt, \$eflags,
- countedged => _COUNT,
- multiedged => _MULTI,
- hyperedged => _HYPER,
- omniedged => _UNORD,
- uniqedged => _UNIQ,
- );
-
- _opt(\%opt, \$gflags,
- compat02 => _COMPAT02,
- unionfind => _UNIONFIND,
- );
-
- if (exists $opt{vertices_unsorted}) { # Graph 0.20103 compat.
- my $unsorted = $opt{vertices_unsorted};
- delete $opt{vertices_unsorted};
- require Carp;
- Carp::confess("Graph: vertices_unsorted must be true")
- unless $unsorted;
- }
-
- my @V;
- if ($opt{vertices}) {
- require Carp;
- Carp::confess("Graph: vertices should be an array ref")
- unless ref $opt{vertices} eq 'ARRAY';
- @V = @{ $opt{vertices} };
- delete $opt{vertices};
- }
-
- my @E;
- if ($opt{edges}) {
- unless (ref $opt{edges} eq 'ARRAY') {
- require Carp;
- Carp::confess("Graph: edges should be an array ref of array refs");
- }
- @E = @{ $opt{edges} };
- delete $opt{edges};
- }
-
- _opt_unknown(\%opt);
-
- my $uflags;
- if (defined $vflags) {
- $uflags = $vflags;
- $uflags |= _UNORD unless $vnonomni;
- $uflags |= _UNIQ unless $vnonuniq;
- } else {
- $uflags = _UNORDUNIQ;
- $vflags = 0;
- }
-
- if (!($vflags & _HYPER) && ($vflags & _UNORDUNIQ)) {
- my @but;
- push @but, 'unordered' if ($vflags & _UNORD);
- push @but, 'unique' if ($vflags & _UNIQ);
- require Carp;
- Carp::confess(sprintf "Graph: not hypervertexed but %s",
- join(' and ', @but));
- }
-
- unless (defined $eflags) {
- $eflags = ($gflags & _COMPAT02) ? _COUNT : 0;
- }
-
- if (!($vflags & _HYPER) && ($vflags & _UNIQ)) {
- require Carp;
- Carp::confess("Graph: not hypervertexed but uniqvertexed");
- }
-
- if (($vflags & _COUNT) && ($vflags & _MULTI)) {
- require Carp;
- Carp::confess("Graph: both countvertexed and multivertexed");
- }
-
- if (($eflags & _COUNT) && ($eflags & _MULTI)) {
- require Carp;
- Carp::confess("Graph: both countedged and multiedged");
- }
-
- my $g = bless [ ], ref $class || $class;
-
- $g->[ _F ] = $gflags;
- $g->[ _G ] = 0;
- $g->[ _V ] = ($vflags & (_HYPER | _MULTI)) ?
- Graph::AdjacencyMap::Heavy->_new($uflags, 1) :
- (($vflags & ~_UNORD) ?
- Graph::AdjacencyMap::Vertex->_new($uflags, 1) :
- Graph::AdjacencyMap::Light->_new($g, $uflags, 1));
- $g->[ _E ] = (($vflags & _HYPER) || ($eflags & ~_UNORD)) ?
- Graph::AdjacencyMap::Heavy->_new($eflags, 2) :
- Graph::AdjacencyMap::Light->_new($g, $eflags, 2);
-
- $g->add_vertices(@V) if @V;
-
- if (@E) {
- for my $e (@E) {
- unless (ref $e eq 'ARRAY') {
- require Carp;
- Carp::confess("Graph: edges should be array refs");
- }
- $g->add_edge(@$e);
- }
- }
-
- if (($gflags & _UNIONFIND)) {
- $g->[ _U ] = Graph::UnionFind->new;
- }
-
- return $g;
-}
-
-sub countvertexed { $_[0]->[ _V ]->_is_COUNT }
-sub multivertexed { $_[0]->[ _V ]->_is_MULTI }
-sub hypervertexed { $_[0]->[ _V ]->_is_HYPER }
-sub omnivertexed { $_[0]->[ _V ]->_is_UNORD }
-sub uniqvertexed { $_[0]->[ _V ]->_is_UNIQ }
-sub refvertexed { $_[0]->[ _V ]->_is_REF }
-
-sub countedged { $_[0]->[ _E ]->_is_COUNT }
-sub multiedged { $_[0]->[ _E ]->_is_MULTI }
-sub hyperedged { $_[0]->[ _E ]->_is_HYPER }
-sub omniedged { $_[0]->[ _E ]->_is_UNORD }
-sub uniqedged { $_[0]->[ _E ]->_is_UNIQ }
-
-*undirected = \&omniedged;
-*omnidirected = \&omniedged;
-sub directed { ! $_[0]->[ _E ]->_is_UNORD }
-
-*is_directed = \&directed;
-*is_undirected = \&undirected;
-
-*is_countvertexed = \&countvertexed;
-*is_multivertexed = \&multivertexed;
-*is_hypervertexed = \&hypervertexed;
-*is_omnidirected = \&omnidirected;
-*is_uniqvertexed = \&uniqvertexed;
-*is_refvertexed = \&refvertexed;
-
-*is_countedged = \&countedged;
-*is_multiedged = \&multiedged;
-*is_hyperedged = \&hyperedged;
-*is_omniedged = \&omniedged;
-*is_uniqedged = \&uniqedged;
-
-sub _union_find_add_vertex {
- my ($g, $v) = @_;
- my $UF = $g->[ _U ];
- $UF->add( $g->[ _V ]->_get_path_id( $v ) );
-}
-
-sub add_vertex {
- my $g = shift;
- if ($g->is_multivertexed) {
- return $g->add_vertex_by_id(@_, _GEN_ID);
- }
- my @r;
- if (@_ > 1) {
- unless ($g->is_countvertexed || $g->is_hypervertexed) {
- require Carp;
- Carp::croak("Graph::add_vertex: use add_vertices for more than one vertex or use hypervertexed");
- }
- for my $v ( @_ ) {
- if (defined $v) {
- $g->[ _V ]->set_path( $v ) unless $g->has_vertex( $v );
- } else {
- require Carp;
- Carp::croak("Graph::add_vertex: undef vertex");
- }
- }
- }
- for my $v ( @_ ) {
- unless (defined $v) {
- require Carp;
- Carp::croak("Graph::add_vertex: undef vertex");
- }
- }
- $g->[ _V ]->set_path( @_ );
- $g->[ _G ]++;
- $g->_union_find_add_vertex( @_ ) if $g->has_union_find;
- return $g;
-}
-
-sub has_vertex {
- my $g = shift;
- my $V = $g->[ _V ];
- return exists $V->[ _s ]->{ $_[0] } if ($V->[ _f ] & _LIGHT);
- $V->has_path( @_ );
-}
-
-sub vertices05 {
- my $g = shift;
- my @v = $g->[ _V ]->paths( @_ );
- if (wantarray) {
- return $g->[ _V ]->_is_HYPER ?
- @v : map { ref $_ eq 'ARRAY' ? @$_ : $_ } @v;
- } else {
- return scalar @v;
- }
-}
-
-sub vertices {
- my $g = shift;
- my @v = $g->vertices05;
- if ($g->is_compat02) {
- wantarray ? sort @v : scalar @v;
- } else {
- if ($g->is_multivertexed || $g->is_countvertexed) {
- if (wantarray) {
- my @V;
- for my $v ( @v ) {
- push @V, ($v) x $g->get_vertex_count($v);
- }
- return @V;
- } else {
- my $V = 0;
- for my $v ( @v ) {
- $V += $g->get_vertex_count($v);
- }
- return $V;
- }
- } else {
- return @v;
- }
- }
-}
-
-*vertices_unsorted = \&vertices_unsorted; # Graph 0.20103 compat.
-
-sub unique_vertices {
- my $g = shift;
- my @v = $g->vertices05;
- if ($g->is_compat02) {
- wantarray ? sort @v : scalar @v;
- } else {
- return @v;
- }
-}
-
-sub has_vertices {
- my $g = shift;
- scalar $g->[ _V ]->has_paths( @_ );
-}
-
-sub _add_edge {
- my $g = shift;
- my $V = $g->[ _V ];
- my @e;
- if (($V->[ _f ]) & _LIGHT) {
- for my $v ( @_ ) {
- $g->add_vertex( $v ) unless exists $V->[ _s ]->{ $v };
- push @e, $V->[ _s ]->{ $v };
- }
- } else {
- my $h = $g->[ _V ]->_is_HYPER;
- for my $v ( @_ ) {
- my @v = ref $v eq 'ARRAY' && $h ? @$v : $v;
- $g->add_vertex( @v ) unless $V->has_path( @v );
- push @e, $V->_get_path_id( @v );
- }
- }
- return @e;
-}
-
-sub _union_find_add_edge {
- my ($g, $u, $v) = @_;
- $g->[ _U ]->union($u, $v);
-}
-
-sub add_edge {
- my $g = shift;
- if ($g->is_multiedged) {
- unless (@_ == 2 || $g->is_hyperedged) {
- require Carp;
- Carp::croak("Graph::add_edge: use add_edges for more than one edge");
- }
- return $g->add_edge_by_id(@_, _GEN_ID);
- }
- unless (@_ == 2) {
- unless ($g->is_hyperedged) {
- require Carp;
- Carp::croak("Graph::add_edge: graph is not hyperedged");
- }
- }
- my @e = $g->_add_edge( @_ );
- $g->[ _E ]->set_path( @e );
- $g->[ _G ]++;
- $g->_union_find_add_edge( @e ) if $g->has_union_find;
- return $g;
-}
-
-sub _vertex_ids {
- my $g = shift;
- my $V = $g->[ _V ];
- my @e;
- if (($V->[ _f ] & _LIGHT)) {
- for my $v ( @_ ) {
- return () unless exists $V->[ _s ]->{ $v };
- push @e, $V->[ _s ]->{ $v };
- }
- } else {
- my $h = $g->[ _V ]->_is_HYPER;
- for my $v ( @_ ) {
- my @v = ref $v eq 'ARRAY' && $h ? @$v : $v;
- return () unless $V->has_path( @v );
- push @e, $V->_get_path_id( @v );
- }
- }
- return @e;
-}
-
-sub has_edge {
- my $g = shift;
- my $E = $g->[ _E ];
- my $V = $g->[ _V ];
- my @i;
- if (($V->[ _f ] & _LIGHT) && @_ == 2) {
- return 0 unless
- exists $V->[ _s ]->{ $_[0] } &&
- exists $V->[ _s ]->{ $_[1] };
- @i = @{ $V->[ _s ] }{ @_[ 0, 1 ] };
- } else {
- @i = $g->_vertex_ids( @_ );
- return 0 if @i == 0 && @_;
- }
- my $f = $E->[ _f ];
- if ($E->[ _a ] == 2 && @i == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
- @i = sort @i if ($f & _UNORD);
- return exists $E->[ _s ]->{ $i[0] } &&
- exists $E->[ _s ]->{ $i[0] }->{ $i[1] } ? 1 : 0;
- } else {
- return defined $E->_get_path_id( @i ) ? 1 : 0;
- }
-}
-
-sub edges05 {
- my $g = shift;
- my $V = $g->[ _V ];
- my @e = $g->[ _E ]->paths( @_ );
- wantarray ?
- map { [ map { my @v = $V->_get_id_path($_);
- @v == 1 ? $v[0] : [ @v ] }
- @$_ ] }
- @e : @e;
-}
-
-sub edges02 {
- my $g = shift;
- if (@_ && defined $_[0]) {
- unless (defined $_[1]) {
- my @e = $g->edges_at($_[0]);
- wantarray ?
- map { @$_ }
- sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @e
- : @e;
- } else {
- die "edges02: unimplemented option";
- }
- } else {
- my @e = map { ($_) x $g->get_edge_count(@$_) } $g->edges05( @_ );
- wantarray ?
- map { @$_ }
- sort { $a->[0] cmp $b->[0] || $a->[1] cmp $b->[1] } @e
- : @e;
- }
-}
-
-sub unique_edges {
- my $g = shift;
- ($g->is_compat02) ? $g->edges02( @_ ) : $g->edges05( @_ );
-}
-
-sub edges {
- my $g = shift;
- if ($g->is_compat02) {
- return $g->edges02( @_ );
- } else {
- if ($g->is_multiedged || $g->is_countedged) {
- if (wantarray) {
- my @E;
- for my $e ( $g->edges05 ) {
- push @E, ($e) x $g->get_edge_count(@$e);
- }
- return @E;
- } else {
- my $E = 0;
- for my $e ( $g->edges05 ) {
- $E += $g->get_edge_count(@$e);
- }
- return $E;
- }
- } else {
- return $g->edges05;
- }
- }
-}
-
-sub has_edges {
- my $g = shift;
- scalar $g->[ _E ]->has_paths( @_ );
-}
-
-###
-# by_id
-#
-
-sub add_vertex_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- $g->[ _V ]->set_path_by_multi_id( @_ );
- $g->[ _G ]++;
- $g->_union_find_add_vertex( @_ ) if $g->has_union_find;
- return $g;
-}
-
-sub add_vertex_get_id {
- my $g = shift;
- $g->expect_multivertexed;
- my $id = $g->[ _V ]->set_path_by_multi_id( @_, _GEN_ID );
- $g->[ _G ]++;
- $g->_union_find_add_vertex( @_ ) if $g->has_union_find;
- return $id;
-}
-
-sub has_vertex_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- $g->[ _V ]->has_path_by_multi_id( @_ );
-}
-
-sub delete_vertex_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- my $V = $g->[ _V ];
- return unless $V->has_path_by_multi_id( @_ );
- # TODO: what to about the edges at this vertex?
- # If the multiness of this vertex goes to zero, delete the edges?
- $V->del_path_by_multi_id( @_ );
- $g->[ _G ]++;
- return $g;
-}
-
-sub get_multivertex_ids {
- my $g = shift;
- $g->expect_multivertexed;
- $g->[ _V ]->get_multi_ids( @_ );
-}
-
-sub add_edge_by_id {
- my $g = shift;
- $g->expect_multiedged;
- my $id = pop;
- my @e = $g->_add_edge( @_ );
- $g->[ _E ]->set_path( @e, $id );
- $g->[ _G ]++;
- $g->_union_find_add_edge( @e ) if $g->has_union_find;
- return $g;
-}
-
-sub add_edge_get_id {
- my $g = shift;
- $g->expect_multiedged;
- my @i = $g->_add_edge( @_ );
- my $id = $g->[ _E ]->set_path_by_multi_id( @i, _GEN_ID );
- $g->_union_find_add_edge( @i ) if $g->has_union_find;
- $g->[ _G ]++;
- return $id;
-}
-
-sub has_edge_by_id {
- my $g = shift;
- $g->expect_multiedged;
- my $id = pop;
- my @i = $g->_vertex_ids( @_ );
- return 0 if @i == 0 && @_;
- $g->[ _E ]->has_path_by_multi_id( @i, $id );
-}
-
-sub delete_edge_by_id {
- my $g = shift;
- $g->expect_multiedged;
- my $V = $g->[ _E ];
- my $id = pop;
- my @i = $g->_vertex_ids( @_ );
- return unless $V->has_path_by_multi_id( @i, $id );
- $V->del_path_by_multi_id( @i, $id );
- $g->[ _G ]++;
- return $g;
-}
-
-sub get_multiedge_ids {
- my $g = shift;
- $g->expect_multiedged;
- my @id = $g->_vertex_ids( @_ );
- return unless @id;
- $g->[ _E ]->get_multi_ids( @id );
-}
-
-###
-# Neighbourhood.
-#
-
-sub vertices_at {
- my $g = shift;
- my $V = $g->[ _V ];
- return @_ unless ($V->[ _f ] & _HYPER);
- my %v;
- my @i;
- for my $v ( @_ ) {
- my $i = $V->_get_path_id( $v );
- return unless defined $i;
- push @i, ( $v{ $v } = $i );
- }
- my $Vi = $V->_ids;
- my @v;
- while (my ($i, $v) = each %{ $Vi }) {
- my %i;
- my $h = $V->[_f ] & _HYPER;
- @i{ @i } = @i if @i; # @todo: nonuniq hyper vertices?
- for my $u (ref $v eq 'ARRAY' && $h ? @$v : $v) {
- my $j = exists $v{ $u } ? $v{ $u } : ( $v{ $u } = $i );
- if (defined $j && exists $i{ $j }) {
- delete $i{ $j };
- unless (keys %i) {
- push @v, $v;
- last;
- }
- }
- }
- }
- return @v;
-}
-
-sub _edges_at {
- my $g = shift;
- my $V = $g->[ _V ];
- my $E = $g->[ _E ];
- my @e;
- my $en = 0;
- my %ev;
- my $h = $V->[_f ] & _HYPER;
- for my $v ( $h ? $g->vertices_at( @_ ) : @_ ) {
- my $vi = $V->_get_path_id( ref $v eq 'ARRAY' && $h ? @$v : $v );
- next unless defined $vi;
- my $Ei = $E->_ids;
- while (my ($ei, $ev) = each %{ $Ei }) {
- if (wantarray) {
- for my $j (@$ev) {
- push @e, [ $ei, $ev ]
- if $j == $vi && !$ev{$ei}++;
- }
- } else {
- for my $j (@$ev) {
- $en++ if $j == $vi;
- }
- }
- }
- }
- return wantarray ? @e : $en;
-}
-
-sub _edges_from {
- my $g = shift;
- my $V = $g->[ _V ];
- my $E = $g->[ _E ];
- my @e;
- my $o = $E->[ _f ] & _UNORD;
- my $en = 0;
- my %ev;
- my $h = $V->[_f ] & _HYPER;
- for my $v ( $h ? $g->vertices_at( @_ ) : @_ ) {
- my $vi = $V->_get_path_id( ref $v eq 'ARRAY' && $h ? @$v : $v );
- next unless defined $vi;
- my $Ei = $E->_ids;
- if (wantarray) {
- if ($o) {
- while (my ($ei, $ev) = each %{ $Ei }) {
- next unless @$ev;
- push @e, [ $ei, $ev ]
- if ($ev->[0] == $vi || $ev->[-1] == $vi) && !$ev{$ei}++;
- }
- } else {
- while (my ($ei, $ev) = each %{ $Ei }) {
- next unless @$ev;
- push @e, [ $ei, $ev ]
- if $ev->[0] == $vi && !$ev{$ei}++;
- }
- }
- } else {
- if ($o) {
- while (my ($ei, $ev) = each %{ $Ei }) {
- next unless @$ev;
- $en++ if ($ev->[0] == $vi || $ev->[-1] == $vi);
- }
- } else {
- while (my ($ei, $ev) = each %{ $Ei }) {
- next unless @$ev;
- $en++ if $ev->[0] == $vi;
- }
- }
- }
- }
- if (wantarray && $g->is_undirected) {
- my @i = map { $V->_get_path_id( $_ ) } @_;
- for my $e ( @e ) {
- unless ( $e->[ 1 ]->[ 0 ] == $i[ 0 ] ) { # @todo
- $e = [ $e->[ 0 ], [ reverse @{ $e->[ 1 ] } ] ];
- }
- }
- }
- return wantarray ? @e : $en;
-}
-
-sub _edges_to {
- my $g = shift;
- my $V = $g->[ _V ];
- my $E = $g->[ _E ];
- my @e;
- my $o = $E->[ _f ] & _UNORD;
- my $en = 0;
- my %ev;
- my $h = $V->[_f ] & _HYPER;
- for my $v ( $h ? $g->vertices_at( @_ ) : @_ ) {
- my $vi = $V->_get_path_id( ref $v eq 'ARRAY' && $h ? @$v : $v );
- next unless defined $vi;
- my $Ei = $E->_ids;
- if (wantarray) {
- if ($o) {
- while (my ($ei, $ev) = each %{ $Ei }) {
- next unless @$ev;
- push @e, [ $ei, $ev ]
- if ($ev->[-1] == $vi || $ev->[0] == $vi) && !$ev{$ei}++;
- }
- } else {
- while (my ($ei, $ev) = each %{ $Ei }) {
- next unless @$ev;
- push @e, [ $ei, $ev ]
- if $ev->[-1] == $vi && !$ev{$ei}++;
- }
- }
- } else {
- if ($o) {
- while (my ($ei, $ev) = each %{ $Ei }) {
- next unless @$ev;
- $en++ if $ev->[-1] == $vi || $ev->[0] == $vi;
- }
- } else {
- while (my ($ei, $ev) = each %{ $Ei }) {
- next unless @$ev;
- $en++ if $ev->[-1] == $vi;
- }
- }
- }
- }
- if (wantarray && $g->is_undirected) {
- my @i = map { $V->_get_path_id( $_ ) } @_;
- for my $e ( @e ) {
- unless ( $e->[ 1 ]->[ -1 ] == $i[ -1 ] ) { # @todo
- $e = [ $e->[ 0 ], [ reverse @{ $e->[ 1 ] } ] ];
- }
- }
- }
- return wantarray ? @e : $en;
-}
-
-sub _edges_id_path {
- my $g = shift;
- my $V = $g->[ _V ];
- [ map { my @v = $V->_get_id_path($_);
- @v == 1 ? $v[0] : [ @v ] }
- @{ $_[0]->[1] } ];
-}
-
-sub edges_at {
- my $g = shift;
- map { $g->_edges_id_path($_ ) } $g->_edges_at( @_ );
-}
-
-sub edges_from {
- my $g = shift;
- map { $g->_edges_id_path($_ ) } $g->_edges_from( @_ );
-}
-
-sub edges_to {
- my $g = shift;
- map { $g->_edges_id_path($_ ) } $g->_edges_to( @_ );
-}
-
-sub successors {
- my $g = shift;
- my $E = $g->[ _E ];
- ($E->[ _f ] & _LIGHT) ?
- $E->_successors($g, @_) :
- Graph::AdjacencyMap::_successors($E, $g, @_);
-}
-
-sub predecessors {
- my $g = shift;
- my $E = $g->[ _E ];
- ($E->[ _f ] & _LIGHT) ?
- $E->_predecessors($g, @_) :
- Graph::AdjacencyMap::_predecessors($E, $g, @_);
-}
-
-sub neighbours {
- my $g = shift;
- my $V = $g->[ _V ];
- my @s = map { my @v = @{ $_->[ 1 ] }; shift @v; @v } $g->_edges_from( @_ );
- my @p = map { my @v = @{ $_->[ 1 ] }; pop @v; @v } $g->_edges_to ( @_ );
- my %n;
- @n{ @s } = @s;
- @n{ @p } = @p;
- map { $V->_get_id_path($_) } keys %n;
-}
-
-*neighbors = \&neighbours;
-
-sub delete_edge {
- my $g = shift;
- my @i = $g->_vertex_ids( @_ );
- return $g unless @i;
- my $i = $g->[ _E ]->_get_path_id( @i );
- return $g unless defined $i;
- $g->[ _E ]->_del_id( $i );
- $g->[ _G ]++;
- return $g;
-}
-
-sub delete_vertex {
- my $g = shift;
- my $V = $g->[ _V ];
- return $g unless $V->has_path( @_ );
- my $E = $g->[ _E ];
- for my $e ( $g->_edges_at( @_ ) ) {
- $E->_del_id( $e->[ 0 ] );
- }
- $V->del_path( @_ );
- $g->[ _G ]++;
- return $g;
-}
-
-sub get_vertex_count {
- my $g = shift;
- $g->[ _V ]->_get_path_count( @_ ) || 0;
-}
-
-sub get_edge_count {
- my $g = shift;
- my @e = $g->_vertex_ids( @_ );
- return 0 unless @e;
- $g->[ _E ]->_get_path_count( @e ) || 0;
-}
-
-sub delete_vertices {
- my $g = shift;
- while (@_) {
- my $v = shift @_;
- $g->delete_vertex($v);
- }
- return $g;
-}
-
-sub delete_edges {
- my $g = shift;
- while (@_) {
- my ($u, $v) = splice @_, 0, 2;
- $g->delete_edge($u, $v);
- }
- return $g;
-}
-
-###
-# Degrees.
-#
-
-sub _in_degree {
- my $g = shift;
- return undef unless @_ && $g->has_vertex( @_ );
- my $in = $g->is_undirected && $g->is_self_loop_vertex( @_ ) ? 1 : 0;
- $in += $g->get_edge_count( @$_ ) for $g->edges_to( @_ );
- return $in;
-}
-
-sub in_degree {
- my $g = shift;
- $g->_in_degree( @_ );
-}
-
-sub _out_degree {
- my $g = shift;
- return undef unless @_ && $g->has_vertex( @_ );
- my $out = $g->is_undirected && $g->is_self_loop_vertex( @_ ) ? 1 : 0;
- $out += $g->get_edge_count( @$_ ) for $g->edges_from( @_ );
- return $out;
-}
-
-sub out_degree {
- my $g = shift;
- $g->_out_degree( @_ );
-}
-
-sub _total_degree {
- my $g = shift;
- return undef unless @_ && $g->has_vertex( @_ );
- $g->is_undirected ?
- $g->_in_degree( @_ ) :
- $g-> in_degree( @_ ) - $g-> out_degree( @_ );
-}
-
-sub degree {
- my $g = shift;
- if (@_) {
- $g->_total_degree( @_ );
- } else {
- if ($g->is_undirected) {
- my $total = 0;
- $total += $g->_total_degree( $_ ) for $g->vertices05;
- return $total;
- } else {
- return 0;
- }
- }
-}
-
-*vertex_degree = \&degree;
-
-sub is_sink_vertex {
- my $g = shift;
- return 0 unless @_;
- $g->successors( @_ ) == 0 && $g->predecessors( @_ ) > 0;
-}
-
-sub is_source_vertex {
- my $g = shift;
- return 0 unless @_;
- $g->predecessors( @_ ) == 0 && $g->successors( @_ ) > 0;
-}
-
-sub is_successorless_vertex {
- my $g = shift;
- return 0 unless @_;
- $g->successors( @_ ) == 0;
-}
-
-sub is_predecessorless_vertex {
- my $g = shift;
- return 0 unless @_;
- $g->predecessors( @_ ) == 0;
-}
-
-sub is_successorful_vertex {
- my $g = shift;
- return 0 unless @_;
- $g->successors( @_ ) > 0;
-}
-
-sub is_predecessorful_vertex {
- my $g = shift;
- return 0 unless @_;
- $g->predecessors( @_ ) > 0;
-}
-
-sub is_isolated_vertex {
- my $g = shift;
- return 0 unless @_;
- $g->predecessors( @_ ) == 0 && $g->successors( @_ ) == 0;
-}
-
-sub is_interior_vertex {
- my $g = shift;
- return 0 unless @_;
- my $p = $g->predecessors( @_ );
- my $s = $g->successors( @_ );
- if ($g->is_self_loop_vertex( @_ )) {
- $p--;
- $s--;
- }
- $p > 0 && $s > 0;
-}
-
-sub is_exterior_vertex {
- my $g = shift;
- return 0 unless @_;
- $g->predecessors( @_ ) == 0 || $g->successors( @_ ) == 0;
-}
-
-sub is_self_loop_vertex {
- my $g = shift;
- return 0 unless @_;
- for my $s ( $g->successors( @_ ) ) {
- return 1 if $s eq $_[0]; # @todo: hypervertices
- }
- return 0;
-}
-
-sub sink_vertices {
- my $g = shift;
- grep { $g->is_sink_vertex($_) } $g->vertices05;
-}
-
-sub source_vertices {
- my $g = shift;
- grep { $g->is_source_vertex($_) } $g->vertices05;
-}
-
-sub successorless_vertices {
- my $g = shift;
- grep { $g->is_successorless_vertex($_) } $g->vertices05;
-}
-
-sub predecessorless_vertices {
- my $g = shift;
- grep { $g->is_predecessorless_vertex($_) } $g->vertices05;
-}
-
-sub successorful_vertices {
- my $g = shift;
- grep { $g->is_successorful_vertex($_) } $g->vertices05;
-}
-
-sub predecessorful_vertices {
- my $g = shift;
- grep { $g->is_predecessorful_vertex($_) } $g->vertices05;
-}
-
-sub isolated_vertices {
- my $g = shift;
- grep { $g->is_isolated_vertex($_) } $g->vertices05;
-}
-
-sub interior_vertices {
- my $g = shift;
- grep { $g->is_interior_vertex($_) } $g->vertices05;
-}
-
-sub exterior_vertices {
- my $g = shift;
- grep { $g->is_exterior_vertex($_) } $g->vertices05;
-}
-
-sub self_loop_vertices {
- my $g = shift;
- grep { $g->is_self_loop_vertex($_) } $g->vertices05;
-}
-
-###
-# Paths and cycles.
-#
-
-sub add_path {
- my $g = shift;
- my $u = shift;
- while (@_) {
- my $v = shift;
- $g->add_edge($u, $v);
- $u = $v;
- }
- return $g;
-}
-
-sub delete_path {
- my $g = shift;
- my $u = shift;
- while (@_) {
- my $v = shift;
- $g->delete_edge($u, $v);
- $u = $v;
- }
- return $g;
-}
-
-sub has_path {
- my $g = shift;
- my $u = shift;
- while (@_) {
- my $v = shift;
- return 0 unless $g->has_edge($u, $v);
- $u = $v;
- }
- return $g;
-}
-
-sub add_cycle {
- my $g = shift;
- $g->add_path(@_, $_[0]);
-}
-
-sub delete_cycle {
- my $g = shift;
- $g->delete_path(@_, $_[0]);
-}
-
-sub has_cycle {
- my $g = shift;
- @_ ? ($g->has_path(@_, $_[0]) ? 1 : 0) : 0;
-}
-
-sub has_a_cycle {
- my $g = shift;
- my @r = ( back_edge => \&Graph::Traversal::has_a_cycle );
- push @r,
- down_edge => \&Graph::Traversal::has_a_cycle
- if $g->is_undirected;
- my $t = Graph::Traversal::DFS->new($g, @r, @_);
- $t->dfs;
- return $t->get_state('has_a_cycle');
-}
-
-sub find_a_cycle {
- my $g = shift;
- my @r = ( back_edge => \&Graph::Traversal::find_a_cycle);
- push @r,
- down_edge => \&Graph::Traversal::find_a_cycle
- if $g->is_undirected;
- my $t = Graph::Traversal::DFS->new($g, @r, @_);
- $t->dfs;
- $t->has_state('a_cycle') ? @{ $t->get_state('a_cycle') } : ();
-}
-
-###
-# Attributes.
-
-# Vertex attributes.
-
-sub set_vertex_attribute {
- my $g = shift;
- $g->expect_non_multivertexed;
- my $value = pop;
- my $attr = pop;
- $g->add_vertex( @_ ) unless $g->has_vertex( @_ );
- $g->[ _V ]->_set_path_attr( @_, $attr, $value );
-}
-
-sub set_vertex_attribute_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- my $value = pop;
- my $attr = pop;
- $g->add_vertex_by_id( @_ ) unless $g->has_vertex_by_id( @_ );
- $g->[ _V ]->_set_path_attr( @_, $attr, $value );
-}
-
-sub set_vertex_attributes {
- my $g = shift;
- $g->expect_non_multivertexed;
- my $attr = pop;
- $g->add_vertex( @_ ) unless $g->has_vertex( @_ );
- $g->[ _V ]->_set_path_attrs( @_, $attr );
-}
-
-sub set_vertex_attributes_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- my $attr = pop;
- $g->add_vertex_by_id( @_ ) unless $g->has_vertex_by_id( @_ );
- $g->[ _V ]->_set_path_attrs( @_, $attr );
-}
-
-sub has_vertex_attributes {
- my $g = shift;
- $g->expect_non_multivertexed;
- return 0 unless $g->has_vertex( @_ );
- $g->[ _V ]->_has_path_attrs( @_ );
-}
-
-sub has_vertex_attributes_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- return 0 unless $g->has_vertex_by_id( @_ );
- $g->[ _V ]->_has_path_attrs( @_ );
-}
-
-sub has_vertex_attribute {
- my $g = shift;
- $g->expect_non_multivertexed;
- my $attr = pop;
- return 0 unless $g->has_vertex( @_ );
- $g->[ _V ]->_has_path_attr( @_, $attr );
-}
-
-sub has_vertex_attribute_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- my $attr = pop;
- return 0 unless $g->has_vertex_by_id( @_ );
- $g->[ _V ]->_has_path_attr( @_, $attr );
-}
-
-sub get_vertex_attributes {
- my $g = shift;
- $g->expect_non_multivertexed;
- return unless $g->has_vertex( @_ );
- my $a = $g->[ _V ]->_get_path_attrs( @_ );
- ($g->is_compat02) ? (defined $a ? %{ $a } : ()) : $a;
-}
-
-sub get_vertex_attributes_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- return unless $g->has_vertex_by_id( @_ );
- $g->[ _V ]->_get_path_attrs( @_ );
-}
-
-sub get_vertex_attribute {
- my $g = shift;
- $g->expect_non_multivertexed;
- my $attr = pop;
- return unless $g->has_vertex( @_ );
- $g->[ _V ]->_get_path_attr( @_, $attr );
-}
-
-sub get_vertex_attribute_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- my $attr = pop;
- return unless $g->has_vertex_by_id( @_ );
- $g->[ _V ]->_get_path_attr( @_, $attr );
-}
-
-sub get_vertex_attribute_names {
- my $g = shift;
- $g->expect_non_multivertexed;
- return unless $g->has_vertex( @_ );
- $g->[ _V ]->_get_path_attr_names( @_ );
-}
-
-sub get_vertex_attribute_names_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- return unless $g->has_vertex_by_id( @_ );
- $g->[ _V ]->_get_path_attr_names( @_ );
-}
-
-sub get_vertex_attribute_values {
- my $g = shift;
- $g->expect_non_multivertexed;
- return unless $g->has_vertex( @_ );
- $g->[ _V ]->_get_path_attr_values( @_ );
-}
-
-sub get_vertex_attribute_values_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- return unless $g->has_vertex_by_id( @_ );
- $g->[ _V ]->_get_path_attr_values( @_ );
-}
-
-sub delete_vertex_attributes {
- my $g = shift;
- $g->expect_non_multivertexed;
- return undef unless $g->has_vertex( @_ );
- $g->[ _V ]->_del_path_attrs( @_ );
-}
-
-sub delete_vertex_attributes_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- return undef unless $g->has_vertex_by_id( @_ );
- $g->[ _V ]->_del_path_attrs( @_ );
-}
-
-sub delete_vertex_attribute {
- my $g = shift;
- $g->expect_non_multivertexed;
- my $attr = pop;
- return undef unless $g->has_vertex( @_ );
- $g->[ _V ]->_del_path_attr( @_, $attr );
-}
-
-sub delete_vertex_attribute_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- my $attr = pop;
- return undef unless $g->has_vertex_by_id( @_ );
- $g->[ _V ]->_del_path_attr( @_, $attr );
-}
-
-# Edge attributes.
-
-sub _set_edge_attribute {
- my $g = shift;
- my $value = pop;
- my $attr = pop;
- my $E = $g->[ _E ];
- my $f = $E->[ _f ];
- my @i;
- if ($E->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
- @_ = sort @_ if ($f & _UNORD);
- my $s = $E->[ _s ];
- $g->add_edge( @_ ) unless exists $s->{ $_[0] } && exists $s->{ $_[0] }->{ $_[1] };
- @i = @{ $g->[ _V ]->[ _s ] }{ @_ };
- } else {
- $g->add_edge( @_ ) unless $g->has_edge( @_ );
- @i = $g->_vertex_ids( @_ );
- }
- $g->[ _E ]->_set_path_attr( @i, $attr, $value );
-}
-
-sub set_edge_attribute {
- my $g = shift;
- $g->expect_non_multiedged;
- my $value = pop;
- my $attr = pop;
- my $E = $g->[ _E ];
- $g->add_edge( @_ ) unless $g->has_edge( @_ );
- $E->_set_path_attr( $g->_vertex_ids( @_ ), $attr, $value );
-}
-
-sub set_edge_attribute_by_id {
- my $g = shift;
- $g->expect_multiedged;
- my $value = pop;
- my $attr = pop;
- # $g->add_edge_by_id( @_ ) unless $g->has_edge_by_id( @_ );
- my $id = pop;
- $g->[ _E ]->_set_path_attr( $g->_vertex_ids( @_ ), $id, $attr, $value );
-}
-
-sub set_edge_attributes {
- my $g = shift;
- $g->expect_non_multiedged;
- my $attr = pop;
- $g->add_edge( @_ ) unless $g->has_edge( @_ );
- $g->[ _E ]->_set_path_attrs( $g->_vertex_ids( @_ ), $attr );
-}
-
-sub set_edge_attributes_by_id {
- my $g = shift;
- $g->expect_multiedged;
- my $attr = pop;
- $g->add_edge_by_id( @_ ) unless $g->has_edge_by_id( @_ );
- my $id = pop;
- $g->[ _E ]->_set_path_attrs( $g->_vertex_ids( @_ ), $id, $attr );
-}
-
-sub has_edge_attributes {
- my $g = shift;
- $g->expect_non_multiedged;
- return 0 unless $g->has_edge( @_ );
- $g->[ _E ]->_has_path_attrs( $g->_vertex_ids( @_ ) );
-}
-
-sub has_edge_attributes_by_id {
- my $g = shift;
- $g->expect_multiedged;
- return 0 unless $g->has_edge_by_id( @_ );
- my $id = pop;
- $g->[ _E ]->_has_path_attrs( $g->_vertex_ids( @_ ), $id );
-}
-
-sub has_edge_attribute {
- my $g = shift;
- $g->expect_non_multiedged;
- my $attr = pop;
- return 0 unless $g->has_edge( @_ );
- $g->[ _E ]->_has_path_attr( $g->_vertex_ids( @_ ), $attr );
-}
-
-sub has_edge_attribute_by_id {
- my $g = shift;
- $g->expect_multiedged;
- my $attr = pop;
- return 0 unless $g->has_edge_by_id( @_ );
- my $id = pop;
- $g->[ _E ]->_has_path_attr( $g->_vertex_ids( @_ ), $id, $attr );
-}
-
-sub get_edge_attributes {
- my $g = shift;
- $g->expect_non_multiedged;
- return unless $g->has_edge( @_ );
- my $a = $g->[ _E ]->_get_path_attrs( $g->_vertex_ids( @_ ) );
- ($g->is_compat02) ? (defined $a ? %{ $a } : ()) : $a;
-}
-
-sub get_edge_attributes_by_id {
- my $g = shift;
- $g->expect_multiedged;
- return unless $g->has_edge_by_id( @_ );
- my $id = pop;
- return $g->[ _E ]->_get_path_attrs( $g->_vertex_ids( @_ ), $id );
-}
-
-sub _get_edge_attribute { # Fast path; less checks.
- my $g = shift;
- my $attr = pop;
- my $E = $g->[ _E ];
- my $f = $E->[ _f ];
- if ($E->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path.
- @_ = sort @_ if ($f & _UNORD);
- my $s = $E->[ _s ];
- return unless exists $s->{ $_[0] } && exists $s->{ $_[0] }->{ $_[1] };
- } else {
- return unless $g->has_edge( @_ );
- }
- my @i = $g->_vertex_ids( @_ );
- $E->_get_path_attr( @i, $attr );
-}
-
-sub get_edge_attribute {
- my $g = shift;
- $g->expect_non_multiedged;
- my $attr = pop;
- return undef unless $g->has_edge( @_ );
- my @i = $g->_vertex_ids( @_ );
- return undef if @i == 0 && @_;
- my $E = $g->[ _E ];
- $E->_get_path_attr( @i, $attr );
-}
-
-sub get_edge_attribute_by_id {
- my $g = shift;
- $g->expect_multiedged;
- my $attr = pop;
- return unless $g->has_edge_by_id( @_ );
- my $id = pop;
- $g->[ _E ]->_get_path_attr( $g->_vertex_ids( @_ ), $id, $attr );
-}
-
-sub get_edge_attribute_names {
- my $g = shift;
- $g->expect_non_multiedged;
- return unless $g->has_edge( @_ );
- $g->[ _E ]->_get_path_attr_names( $g->_vertex_ids( @_ ) );
-}
-
-sub get_edge_attribute_names_by_id {
- my $g = shift;
- $g->expect_multiedged;
- return unless $g->has_edge_by_id( @_ );
- my $id = pop;
- $g->[ _E ]->_get_path_attr_names( $g->_vertex_ids( @_ ), $id );
-}
-
-sub get_edge_attribute_values {
- my $g = shift;
- $g->expect_non_multiedged;
- return unless $g->has_edge( @_ );
- $g->[ _E ]->_get_path_attr_values( $g->_vertex_ids( @_ ) );
-}
-
-sub get_edge_attribute_values_by_id {
- my $g = shift;
- $g->expect_multiedged;
- return unless $g->has_edge_by_id( @_ );
- my $id = pop;
- $g->[ _E ]->_get_path_attr_values( $g->_vertex_ids( @_ ), $id );
-}
-
-sub delete_edge_attributes {
- my $g = shift;
- $g->expect_non_multiedged;
- return unless $g->has_edge( @_ );
- $g->[ _E ]->_del_path_attrs( $g->_vertex_ids( @_ ) );
-}
-
-sub delete_edge_attributes_by_id {
- my $g = shift;
- $g->expect_multiedged;
- return unless $g->has_edge_by_id( @_ );
- my $id = pop;
- $g->[ _E ]->_del_path_attrs( $g->_vertex_ids( @_ ), $id );
-}
-
-sub delete_edge_attribute {
- my $g = shift;
- $g->expect_non_multiedged;
- my $attr = pop;
- return unless $g->has_edge( @_ );
- $g->[ _E ]->_del_path_attr( $g->_vertex_ids( @_ ), $attr );
-}
-
-sub delete_edge_attribute_by_id {
- my $g = shift;
- $g->expect_multiedged;
- my $attr = pop;
- return unless $g->has_edge_by_id( @_ );
- my $id = pop;
- $g->[ _E ]->_del_path_attr( $g->_vertex_ids( @_ ), $id, $attr );
-}
-
-###
-# Compat.
-#
-
-sub vertex {
- my $g = shift;
- $g->has_vertex( @_ ) ? @_ : undef;
-}
-
-sub out_edges {
- my $g = shift;
- return unless @_ && $g->has_vertex( @_ );
- my @e = $g->edges_from( @_ );
- wantarray ? map { @$_ } @e : @e;
-}
-
-sub in_edges {
- my $g = shift;
- return unless @_ && $g->has_vertex( @_ );
- my @e = $g->edges_to( @_ );
- wantarray ? map { @$_ } @e : @e;
-}
-
-sub add_vertices {
- my $g = shift;
- $g->add_vertex( $_ ) for @_;
-}
-
-sub add_edges {
- my $g = shift;
- while (@_) {
- my $u = shift @_;
- if (ref $u eq 'ARRAY') {
- $g->add_edge( @$u );
- } else {
- if (@_) {
- my $v = shift @_;
- $g->add_edge( $u, $v );
- } else {
- require Carp;
- Carp::croak("Graph::add_edges: missing end vertex");
- }
- }
- }
-}
-
-###
-# More constructors.
-#
-
-sub copy {
- my $g = shift;
- my %opt = _get_options( \@_ );
-
- my $c = (ref $g)->new(directed => $g->directed ? 1 : 0,
- compat02 => $g->compat02 ? 1 : 0);
- for my $v ($g->isolated_vertices) { $c->add_vertex($v) }
- for my $e ($g->edges05) { $c->add_edge(@$e) }
- return $c;
-}
-
-*copy_graph = \&copy;
-
-sub deep_copy {
- require Data::Dumper;
- my $g = shift;
- my $d = Data::Dumper->new([$g]);
- use vars qw($VAR1);
- $d->Purity(1)->Terse(1)->Deepcopy(1);
- $d->Deparse(1) if $] >= 5.008;
- eval $d->Dump;
-}
-
-*deep_copy_graph = \&deep_copy;
-
-sub transpose_edge {
- my $g = shift;
- if ($g->is_directed) {
- return undef unless $g->has_edge( @_ );
- my $c = $g->get_edge_count( @_ );
- my $a = $g->get_edge_attributes( @_ );
- my @e = reverse @_;
- $g->delete_edge( @_ ) unless $g->has_edge( @e );
- $g->add_edge( @e ) for 1..$c;
- $g->set_edge_attributes(@e, $a) if $a;
- }
- return $g;
-}
-
-sub transpose_graph {
- my $g = shift;
- my $t = $g->copy;
- if ($t->directed) {
- for my $e ($t->edges05) {
- $t->transpose_edge(@$e);
- }
- }
- return $t;
-}
-
-*transpose = \&transpose_graph;
-
-sub complete_graph {
- my $g = shift;
- my $c = $g->new( directed => $g->directed );
- my @v = $g->vertices05;
- for (my $i = 0; $i <= $#v; $i++ ) {
- for (my $j = 0; $j <= $#v; $j++ ) {
- next if $i >= $j;
- if ($g->is_undirected) {
- $c->add_edge($v[$i], $v[$j]);
- } else {
- $c->add_edge($v[$i], $v[$j]);
- $c->add_edge($v[$j], $v[$i]);
- }
- }
- }
- return $c;
-}
-
-*complement = \&complement_graph;
-
-sub complement_graph {
- my $g = shift;
- my $c = $g->new( directed => $g->directed );
- my @v = $g->vertices05;
- for (my $i = 0; $i <= $#v; $i++ ) {
- for (my $j = 0; $j <= $#v; $j++ ) {
- next if $i >= $j;
- if ($g->is_undirected) {
- $c->add_edge($v[$i], $v[$j])
- unless $g->has_edge($v[$i], $v[$j]);
- } else {
- $c->add_edge($v[$i], $v[$j])
- unless $g->has_edge($v[$i], $v[$j]);
- $c->add_edge($v[$j], $v[$i])
- unless $g->has_edge($v[$j], $v[$i]);
- }
- }
- }
- return $c;
-}
-
-*complete = \&complete_graph;
-
-###
-# Transitivity.
-#
-
-sub is_transitive {
- my $g = shift;
- Graph::TransitiveClosure::is_transitive($g);
-}
-
-###
-# Weighted vertices.
-#
-
-my $defattr = 'weight';
-
-sub _defattr {
- return $defattr;
-}
-
-sub add_weighted_vertex {
- my $g = shift;
- $g->expect_non_multivertexed;
- my $w = pop;
- $g->add_vertex(@_);
- $g->set_vertex_attribute(@_, $defattr, $w);
-}
-
-sub add_weighted_vertices {
- my $g = shift;
- $g->expect_non_multivertexed;
- while (@_) {
- my ($v, $w) = splice @_, 0, 2;
- $g->add_vertex($v);
- $g->set_vertex_attribute($v, $defattr, $w);
- }
-}
-
-sub get_vertex_weight {
- my $g = shift;
- $g->expect_non_multivertexed;
- $g->get_vertex_attribute(@_, $defattr);
-}
-
-sub has_vertex_weight {
- my $g = shift;
- $g->expect_non_multivertexed;
- $g->has_vertex_attribute(@_, $defattr);
-}
-
-sub set_vertex_weight {
- my $g = shift;
- $g->expect_non_multivertexed;
- my $w = pop;
- $g->set_vertex_attribute(@_, $defattr, $w);
-}
-
-sub delete_vertex_weight {
- my $g = shift;
- $g->expect_non_multivertexed;
- $g->delete_vertex_attribute(@_, $defattr);
-}
-
-sub add_weighted_vertex_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- my $w = pop;
- $g->add_vertex_by_id(@_);
- $g->set_vertex_attribute_by_id(@_, $defattr, $w);
-}
-
-sub add_weighted_vertices_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- my $id = pop;
- while (@_) {
- my ($v, $w) = splice @_, 0, 2;
- $g->add_vertex_by_id($v, $id);
- $g->set_vertex_attribute_by_id($v, $id, $defattr, $w);
- }
-}
-
-sub get_vertex_weight_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- $g->get_vertex_attribute_by_id(@_, $defattr);
-}
-
-sub has_vertex_weight_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- $g->has_vertex_attribute_by_id(@_, $defattr);
-}
-
-sub set_vertex_weight_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- my $w = pop;
- $g->set_vertex_attribute_by_id(@_, $defattr, $w);
-}
-
-sub delete_vertex_weight_by_id {
- my $g = shift;
- $g->expect_multivertexed;
- $g->delete_vertex_attribute_by_id(@_, $defattr);
-}
-
-###
-# Weighted edges.
-#
-
-sub add_weighted_edge {
- my $g = shift;
- $g->expect_non_multiedged;
- if ($g->is_compat02) {
- my $w = splice @_, 1, 1;
- $g->add_edge(@_);
- $g->set_edge_attribute(@_, $defattr, $w);
- } else {
- my $w = pop;
- $g->add_edge(@_);
- $g->set_edge_attribute(@_, $defattr, $w);
- }
-}
-
-sub add_weighted_edges {
- my $g = shift;
- $g->expect_non_multiedged;
- if ($g->is_compat02) {
- while (@_) {
- my ($u, $w, $v) = splice @_, 0, 3;
- $g->add_edge($u, $v);
- $g->set_edge_attribute($u, $v, $defattr, $w);
- }
- } else {
- while (@_) {
- my ($u, $v, $w) = splice @_, 0, 3;
- $g->add_edge($u, $v);
- $g->set_edge_attribute($u, $v, $defattr, $w);
- }
- }
-}
-
-sub add_weighted_edges_by_id {
- my $g = shift;
- $g->expect_multiedged;
- my $id = pop;
- while (@_) {
- my ($u, $v, $w) = splice @_, 0, 3;
- $g->add_edge_by_id($u, $v, $id);
- $g->set_edge_attribute_by_id($u, $v, $id, $defattr, $w);
- }
-}
-
-sub add_weighted_path {
- my $g = shift;
- $g->expect_non_multiedged;
- my $u = shift;
- while (@_) {
- my ($w, $v) = splice @_, 0, 2;
- $g->add_edge($u, $v);
- $g->set_edge_attribute($u, $v, $defattr, $w);
- $u = $v;
- }
-}
-
-sub get_edge_weight {
- my $g = shift;
- $g->expect_non_multiedged;
- $g->get_edge_attribute(@_, $defattr);
-}
-
-sub has_edge_weight {
- my $g = shift;
- $g->expect_non_multiedged;
- $g->has_edge_attribute(@_, $defattr);
-}
-
-sub set_edge_weight {
- my $g = shift;
- $g->expect_non_multiedged;
- my $w = pop;
- $g->set_edge_attribute(@_, $defattr, $w);
-}
-
-sub delete_edge_weight {
- my $g = shift;
- $g->expect_non_multiedged;
- $g->delete_edge_attribute(@_, $defattr);
-}
-
-sub add_weighted_edge_by_id {
- my $g = shift;
- $g->expect_multiedged;
- if ($g->is_compat02) {
- my $w = splice @_, 1, 1;
- $g->add_edge_by_id(@_);
- $g->set_edge_attribute_by_id(@_, $defattr, $w);
- } else {
- my $w = pop;
- $g->add_edge_by_id(@_);
- $g->set_edge_attribute_by_id(@_, $defattr, $w);
- }
-}
-
-sub add_weighted_path_by_id {
- my $g = shift;
- $g->expect_multiedged;
- my $id = pop;
- my $u = shift;
- while (@_) {
- my ($w, $v) = splice @_, 0, 2;
- $g->add_edge_by_id($u, $v, $id);
- $g->set_edge_attribute_by_id($u, $v, $id, $defattr, $w);
- $u = $v;
- }
-}
-
-sub get_edge_weight_by_id {
- my $g = shift;
- $g->expect_multiedged;
- $g->get_edge_attribute_by_id(@_, $defattr);
-}
-
-sub has_edge_weight_by_id {
- my $g = shift;
- $g->expect_multiedged;
- $g->has_edge_attribute_by_id(@_, $defattr);
-}
-
-sub set_edge_weight_by_id {
- my $g = shift;
- $g->expect_multiedged;
- my $w = pop;
- $g->set_edge_attribute_by_id(@_, $defattr, $w);
-}
-
-sub delete_edge_weight_by_id {
- my $g = shift;
- $g->expect_multiedged;
- $g->delete_edge_attribute_by_id(@_, $defattr);
-}
-
-###
-# Error helpers.
-#
-
-my %expected;
-@expected{qw(directed undirected acyclic)} = qw(undirected directed cyclic);
-
-sub _expected {
- my $exp = shift;
- my $got = @_ ? shift : $expected{$exp};
- $got = defined $got ? ", got $got" : "";
- if (my @caller2 = caller(2)) {
- die "$caller2[3]: expected $exp graph$got, at $caller2[1] line $caller2[2].\n";
- } else {
- my @caller1 = caller(1);
- die "$caller1[3]: expected $exp graph$got, at $caller1[1] line $caller1[2].\n";
- }
-}
-
-sub expect_undirected {
- my $g = shift;
- _expected('undirected') unless $g->is_undirected;
-}
-
-sub expect_directed {
- my $g = shift;
- _expected('directed') unless $g->is_directed;
-}
-
-sub expect_acyclic {
- my $g = shift;
- _expected('acyclic') unless $g->is_acyclic;
-}
-
-sub expect_dag {
- my $g = shift;
- my @got;
- push @got, 'undirected' unless $g->is_directed;
- push @got, 'cyclic' unless $g->is_acyclic;
- _expected('directed acyclic', "@got") if @got;
-}
-
-sub expect_multivertexed {
- my $g = shift;
- _expected('multivertexed') unless $g->is_multivertexed;
-}
-
-sub expect_non_multivertexed {
- my $g = shift;
- _expected('non-multivertexed') if $g->is_multivertexed;
-}
-
-sub expect_non_multiedged {
- my $g = shift;
- _expected('non-multiedged') if $g->is_multiedged;
-}
-
-sub expect_multiedged {
- my $g = shift;
- _expected('multiedged') unless $g->is_multiedged;
-}
-
-sub _get_options {
- my @caller = caller(1);
- unless (@_ == 1 && ref $_[0] eq 'ARRAY') {
- die "$caller[3]: internal error: should be called with only one array ref argument, at $caller[1] line $caller[2].\n";
- }
- my @opt = @{ $_[0] };
- unless (@opt % 2 == 0) {
- die "$caller[3]: expected an options hash, got a non-even number of arguments, at $caller[1] line $caller[2].\n";
- }
- return @opt;
-}
-
-###
-# Random constructors and accessors.
-#
-
-sub __fisher_yates_shuffle (@) {
- # From perlfaq4, but modified to be non-modifying.
- my @a = @_;
- my $i = @a;
- while ($i--) {
- my $j = int rand ($i+1);
- @a[$i,$j] = @a[$j,$i];
- }
- return @a;
-}
-
-BEGIN {
- sub _shuffle(@);
- # Workaround for the Perl bug [perl #32383] where -d:Dprof and
- # List::Util::shuffle do not like each other: if any debugging
- # (-d) flags are on, fall back to our own Fisher-Yates shuffle.
- # The bug was fixed by perl changes #26054 and #26062, which
- # went to Perl 5.9.3. If someone tests this with a pre-5.9.3
- # bleadperl that calls itself 5.9.3 but doesn't yet have the
- # patches, oh, well.
- *_shuffle = $^P && $] < 5.009003 ?
- \&__fisher_yates_shuffle : \&List::Util::shuffle;
-}
-
-sub random_graph {
- my $class = (@_ % 2) == 0 ? 'Graph' : shift;
- my %opt = _get_options( \@_ );
- my $random_edge;
- unless (exists $opt{vertices} && defined $opt{vertices}) {
- require Carp;
- Carp::croak("Graph::random_graph: argument 'vertices' missing or undef");
- }
- if (exists $opt{random_seed}) {
- srand($opt{random_seed});
- delete $opt{random_seed};
- }
- if (exists $opt{random_edge}) {
- $random_edge = $opt{random_edge};
- delete $opt{random_edge};
- }
- my @V;
- if (my $ref = ref $opt{vertices}) {
- if ($ref eq 'ARRAY') {
- @V = @{ $opt{vertices} };
- } else {
- Carp::croak("Graph::random_graph: argument 'vertices' illegal");
- }
- } else {
- @V = 0..($opt{vertices} - 1);
- }
- delete $opt{vertices};
- my $V = @V;
- my $C = $V * ($V - 1) / 2;
- my $E;
- if (exists $opt{edges} && exists $opt{edges_fill}) {
- Carp::croak("Graph::random_graph: both arguments 'edges' and 'edges_fill' specified");
- }
- $E = exists $opt{edges_fill} ? $opt{edges_fill} * $C : $opt{edges};
- delete $opt{edges};
- delete $opt{edges_fill};
- my $g = $class->new(%opt);
- $g->add_vertices(@V);
- return $g if $V < 2;
- $C *= 2 if $g->directed;
- $E = $C / 2 unless defined $E;
- $E = int($E + 0.5);
- my $p = $E / $C;
- $random_edge = sub { $p } unless defined $random_edge;
- # print "V = $V, E = $E, C = $C, p = $p\n";
- if ($p > 1.0 && !($g->countedged || $g->multiedged)) {
- require Carp;
- Carp::croak("Graph::random_graph: needs to be countedged or multiedged ($E > $C)");
- }
- my @V1 = @V;
- my @V2 = @V;
- # Shuffle the vertex lists so that the pairs at
- # the beginning of the lists are not more likely.
- @V1 = _shuffle @V1;
- @V2 = _shuffle @V2;
- LOOP:
- while ($E) {
- for my $v1 (@V1) {
- for my $v2 (@V2) {
- next if $v1 eq $v2; # TODO: allow self-loops?
- my $q = $random_edge->($g, $v1, $v2, $p);
- if ($q && ($q == 1 || rand() <= $q) &&
- !$g->has_edge($v1, $v2)) {
- $g->add_edge($v1, $v2);
- $E--;
- last LOOP unless $E;
- }
- }
- }
- }
- return $g;
-}
-
-sub random_vertex {
- my $g = shift;
- my @V = $g->vertices05;
- @V[rand @V];
-}
-
-sub random_edge {
- my $g = shift;
- my @E = $g->edges05;
- @E[rand @E];
-}
-
-sub random_successor {
- my ($g, $v) = @_;
- my @S = $g->successors($v);
- @S[rand @S];
-}
-
-sub random_predecessor {
- my ($g, $v) = @_;
- my @P = $g->predecessors($v);
- @P[rand @P];
-}
-
-###
-# Algorithms.
-#
-
-my $MST_comparator = sub { ($_[0] || 0) <=> ($_[1] || 0) };
-
-sub _MST_attr {
- my $attr = shift;
- my $attribute =
- exists $attr->{attribute} ?
- $attr->{attribute} : $defattr;
- my $comparator =
- exists $attr->{comparator} ?
- $attr->{comparator} : $MST_comparator;
- return ($attribute, $comparator);
-}
-
-sub _MST_edges {
- my ($g, $attr) = @_;
- my ($attribute, $comparator) = _MST_attr($attr);
- map { $_->[1] }
- sort { $comparator->($a->[0], $b->[0], $a->[1], $b->[1]) }
- map { [ $g->get_edge_attribute(@$_, $attribute), $_ ] }
- $g->edges05;
-}
-
-sub MST_Kruskal {
- my ($g, %attr) = @_;
-
- $g->expect_undirected;
-
- my $MST = Graph::Undirected->new;
-
- my $UF = Graph::UnionFind->new;
- for my $v ($g->vertices05) { $UF->add($v) }
-
- for my $e ($g->_MST_edges(\%attr)) {
- my ($u, $v) = @$e; # TODO: hyperedges
- my $t0 = $UF->find( $u );
- my $t1 = $UF->find( $v );
- unless ($t0 eq $t1) {
- $UF->union($u, $v);
- $MST->add_edge($u, $v);
- }
- }
-
- return $MST;
-}
-
-sub _MST_add {
- my ($g, $h, $HF, $r, $attr, $unseen) = @_;
- for my $s ( grep { exists $unseen->{ $_ } } $g->successors( $r ) ) {
- $HF->add( Graph::MSTHeapElem->new( $r, $s, $g->get_edge_attribute( $r, $s, $attr ) ) );
- }
-}
-
-sub _next_alphabetic { shift; (sort keys %{ $_[0] })[0] }
-sub _next_numeric { shift; (sort { $a <=> $b } keys %{ $_[0] })[0] }
-sub _next_random { shift; (values %{ $_[0] })[ rand keys %{ $_[0] } ] }
-
-sub _root_opt {
- my $g = shift;
- my %opt = @_ == 1 ? ( first_root => $_[0] ) : _get_options( \@_ );
- my %unseen;
- my @unseen = $g->vertices05;
- @unseen{ @unseen } = @unseen;
- @unseen = _shuffle @unseen;
- my $r;
- if (exists $opt{ start }) {
- $opt{ first_root } = $opt{ start };
- $opt{ next_root } = undef;
- }
- if (exists $opt{ get_next_root }) {
- $opt{ next_root } = $opt{ get_next_root }; # Graph 0.201 compat.
- }
- if (exists $opt{ first_root }) {
- if (ref $opt{ first_root } eq 'CODE') {
- $r = $opt{ first_root }->( $g, \%unseen );
- } else {
- $r = $opt{ first_root };
- }
- } else {
- $r = shift @unseen;
- }
- my $next =
- exists $opt{ next_root } ?
- $opt{ next_root } :
- $opt{ next_alphabetic } ?
- \&_next_alphabetic :
- $opt{ next_numeric } ? \&_next_numeric :
- \&_next_random;
- my $code = ref $next eq 'CODE';
- my $attr = exists $opt{ attribute } ? $opt{ attribute } : $defattr;
- return ( \%opt, \%unseen, \@unseen, $r, $next, $code, $attr );
-}
-
-sub _heap_walk {
- my ($g, $h, $add, $etc) = splice @_, 0, 4; # Leave %opt in @_.
-
- my ($opt, $unseenh, $unseena, $r, $next, $code, $attr) = $g->_root_opt(@_);
- my $HF = Heap071::Fibonacci->new;
-
- while (defined $r) {
- # print "r = $r\n";
- $add->($g, $h, $HF, $r, $attr, $unseenh, $etc);
- delete $unseenh->{ $r };
- while (defined $HF->top) {
- my $t = $HF->extract_top;
- # use Data::Dumper; print "t = ", Dumper($t);
- if (defined $t) {
- my ($u, $v, $w) = $t->val;
- # print "extracted top: $u $v $w\n";
- if (exists $unseenh->{ $v }) {
- $h->set_edge_attribute($u, $v, $attr, $w);
- delete $unseenh->{ $v };
- $add->($g, $h, $HF, $v, $attr, $unseenh, $etc);
- }
- }
- }
- return $h unless defined $next;
- $r = $code ? $next->( $g, $unseenh ) : shift @$unseena;
- }
-
- return $h;
-}
-
-sub MST_Prim {
- my $g = shift;
- $g->expect_undirected;
- $g->_heap_walk(Graph::Undirected->new(), \&_MST_add, undef, @_);
-}
-
-*MST_Dijkstra = \&MST_Prim;
-
-*minimum_spanning_tree = \&MST_Prim;
-
-###
-# Cycle detection.
-#
-
-*is_cyclic = \&has_a_cycle;
-
-sub is_acyclic {
- my $g = shift;
- return !$g->is_cyclic;
-}
-
-sub is_dag {
- my $g = shift;
- return $g->is_directed && $g->is_acyclic ? 1 : 0;
-}
-
-*is_directed_acyclic_graph = \&is_dag;
-
-###
-# Backward compat.
-#
-
-sub average_degree {
- my $g = shift;
- my $V = $g->vertices05;
-
- return $V ? $g->degree / $V : 0;
-}
-
-sub density_limits {
- my $g = shift;
-
- my $V = $g->vertices05;
- my $M = $V * ($V - 1);
-
- $M /= 2 if $g->is_undirected;
-
- return ( 0.25 * $M, 0.75 * $M, $M );
-}
-
-sub density {
- my $g = shift;
- my ($sparse, $dense, $complete) = $g->density_limits;
-
- return $complete ? $g->edges / $complete : 0;
-}
-
-###
-# Attribute backward compat
-#
-
-sub _attr02_012 {
- my ($g, $op, $ga, $va, $ea) = splice @_, 0, 5;
- if ($g->is_compat02) {
- if (@_ == 0) { return $ga->( $g ) }
- elsif (@_ == 1) { return $va->( $g, @_ ) }
- elsif (@_ == 2) { return $ea->( $g, @_ ) }
- else {
- die sprintf "$op: wrong number of arguments (%d)", scalar @_;
- }
- } else {
- die "$op: not a compat02 graph"
- }
-}
-
-sub _attr02_123 {
- my ($g, $op, $ga, $va, $ea) = splice @_, 0, 5;
- if ($g->is_compat02) {
- if (@_ == 1) { return $ga->( $g, @_ ) }
- elsif (@_ == 2) { return $va->( $g, @_[1, 0] ) }
- elsif (@_ == 3) { return $ea->( $g, @_[1, 2, 0] ) }
- else {
- die sprintf "$op: wrong number of arguments (%d)", scalar @_;
- }
- } else {
- die "$op: not a compat02 graph"
- }
-}
-
-sub _attr02_234 {
- my ($g, $op, $ga, $va, $ea) = splice @_, 0, 5;
- if ($g->is_compat02) {
- if (@_ == 2) { return $ga->( $g, @_ ) }
- elsif (@_ == 3) { return $va->( $g, @_[1, 0, 2] ) }
- elsif (@_ == 4) { return $ea->( $g, @_[1, 2, 0, 3] ) }
- else {
- die sprintf "$op: wrong number of arguments (%d)", scalar @_;
- }
- } else {
- die "$op: not a compat02 graph";
- }
-}
-
-sub set_attribute {
- my $g = shift;
- $g->_attr02_234('set_attribute',
- \&Graph::set_graph_attribute,
- \&Graph::set_vertex_attribute,
- \&Graph::set_edge_attribute,
- @_);
-
-}
-
-sub set_attributes {
- my $g = shift;
- my $a = pop;
- $g->_attr02_123('set_attributes',
- \&Graph::set_graph_attributes,
- \&Graph::set_vertex_attributes,
- \&Graph::set_edge_attributes,
- $a, @_);
-
-}
-
-sub get_attribute {
- my $g = shift;
- $g->_attr02_123('get_attribute',
- \&Graph::get_graph_attribute,
- \&Graph::get_vertex_attribute,
- \&Graph::get_edge_attribute,
- @_);
-
-}
-
-sub get_attributes {
- my $g = shift;
- $g->_attr02_012('get_attributes',
- \&Graph::get_graph_attributes,
- \&Graph::get_vertex_attributes,
- \&Graph::get_edge_attributes,
- @_);
-
-}
-
-sub has_attribute {
- my $g = shift;
- return 0 unless @_;
- $g->_attr02_123('has_attribute',
- \&Graph::has_graph_attribute,
- \&Graph::has_vertex_attribute,
- \&Graph::get_edge_attribute,
- @_);
-
-}
-
-sub has_attributes {
- my $g = shift;
- $g->_attr02_012('has_attributes',
- \&Graph::has_graph_attributes,
- \&Graph::has_vertex_attributes,
- \&Graph::has_edge_attributes,
- @_);
-
-}
-
-sub delete_attribute {
- my $g = shift;
- $g->_attr02_123('delete_attribute',
- \&Graph::delete_graph_attribute,
- \&Graph::delete_vertex_attribute,
- \&Graph::delete_edge_attribute,
- @_);
-
-}
-
-sub delete_attributes {
- my $g = shift;
- $g->_attr02_012('delete_attributes',
- \&Graph::delete_graph_attributes,
- \&Graph::delete_vertex_attributes,
- \&Graph::delete_edge_attributes,
- @_);
-
-}
-
-###
-# Simple DFS uses.
-#
-
-sub topological_sort {
- my $g = shift;
- my %opt = _get_options( \@_ );
- my $eic = $opt{ empty_if_cyclic };
- my $hac;
- if ($eic) {
- $hac = $g->has_a_cycle;
- } else {
- $g->expect_dag;
- }
- delete $opt{ empty_if_cyclic };
- my $t = Graph::Traversal::DFS->new($g, %opt);
- my @s = $t->dfs;
- $hac ? () : reverse @s;
-}
-
-*toposort = \&topological_sort;
-
-sub undirected_copy {
- my $g = shift;
-
- $g->expect_directed;
-
- my $c = Graph::Undirected->new;
- for my $v ($g->isolated_vertices) { # TODO: if iv ...
- $c->add_vertex($v);
- }
- for my $e ($g->edges05) {
- $c->add_edge(@$e);
- }
- return $c;
-}
-
-*undirected_copy_graph = \&undirected_copy;
-
-sub directed_copy {
- my $g = shift;
- $g->expect_undirected;
- my $c = Graph::Directed->new;
- for my $v ($g->isolated_vertices) { # TODO: if iv ...
- $c->add_vertex($v);
- }
- for my $e ($g->edges05) {
- my @e = @$e;
- $c->add_edge(@e);
- $c->add_edge(reverse @e);
- }
- return $c;
-}
-
-*directed_copy_graph = \&directed_copy;
-
-###
-# Cache or not.
-#
-
-my %_cache_type =
- (
- 'connectivity' => '_ccc',
- 'strong_connectivity' => '_scc',
- 'biconnectivity' => '_bcc',
- 'SPT_Dijkstra' => '_spt_di',
- 'SPT_Bellman_Ford' => '_spt_bf',
- );
-
-sub _check_cache {
- my ($g, $type, $code) = splice @_, 0, 3;
- my $c = $_cache_type{$type};
- if (defined $c) {
- my $a = $g->get_graph_attribute($c);
- unless (defined $a && $a->[ 0 ] == $g->[ _G ]) {
- $a->[ 0 ] = $g->[ _G ];
- $a->[ 1 ] = $code->( $g, @_ );
- $g->set_graph_attribute($c, $a);
- }
- return $a->[ 1 ];
- } else {
- Carp::croak("Graph: unknown cache type '$type'");
- }
-}
-
-sub _clear_cache {
- my ($g, $type) = @_;
- my $c = $_cache_type{$type};
- if (defined $c) {
- $g->delete_graph_attribute($c);
- } else {
- Carp::croak("Graph: unknown cache type '$type'");
- }
-}
-
-sub connectivity_clear_cache {
- my $g = shift;
- _clear_cache($g, 'connectivity');
-}
-
-sub strong_connectivity_clear_cache {
- my $g = shift;
- _clear_cache($g, 'strong_connectivity');
-}
-
-sub biconnectivity_clear_cache {
- my $g = shift;
- _clear_cache($g, 'biconnectivity');
-}
-
-sub SPT_Dijkstra_clear_cache {
- my $g = shift;
- _clear_cache($g, 'SPT_Dijkstra');
- $g->delete_graph_attribute('SPT_Dijkstra_first_root');
-}
-
-sub SPT_Bellman_Ford_clear_cache {
- my $g = shift;
- _clear_cache($g, 'SPT_Bellman_Ford');
-}
-
-###
-# Connected components.
-#
-
-sub _connected_components_compute {
- my $g = shift;
- my %cce;
- my %cci;
- my $cc = 0;
- if ($g->has_union_find) {
- my $UF = $g->_get_union_find();
- my $V = $g->[ _V ];
- my %icce; # Isolated vertices.
- my %icci;
- my $icc = 0;
- for my $v ( $g->unique_vertices ) {
- $cc = $UF->find( $V->_get_path_id( $v ) );
- if (defined $cc) {
- $cce{ $v } = $cc;
- push @{ $cci{ $cc } }, $v;
- } else {
- $icce{ $v } = $icc;
- push @{ $icci{ $icc } }, $v;
- $icc++;
- }
- }
- if ($icc) {
- @cce{ keys %icce } = values %icce;
- @cci{ keys %icci } = values %icci;
- }
- } else {
- my @u = $g->unique_vertices;
- my %r; @r{ @u } = @u;
- my $froot = sub {
- (each %r)[1];
- };
- my $nroot = sub {
- $cc++ if keys %r;
- (each %r)[1];
- };
- my $t = Graph::Traversal::DFS->new($g,
- first_root => $froot,
- next_root => $nroot,
- pre => sub {
- my ($v, $t) = @_;
- $cce{ $v } = $cc;
- push @{ $cci{ $cc } }, $v;
- delete $r{ $v };
- },
- @_);
- $t->dfs;
- }
- return [ \%cce, \%cci ];
-}
-
-sub _connected_components {
- my $g = shift;
- my $ccc = _check_cache($g, 'connectivity',
- \&_connected_components_compute, @_);
- return @{ $ccc };
-}
-
-sub connected_component_by_vertex {
- my ($g, $v) = @_;
- $g->expect_undirected;
- my ($CCE, $CCI) = $g->_connected_components();
- return $CCE->{ $v };
-}
-
-sub connected_component_by_index {
- my ($g, $i) = @_;
- $g->expect_undirected;
- my ($CCE, $CCI) = $g->_connected_components();
- return defined $CCI->{ $i } ? @{ $CCI->{ $i } } : ( );
-}
-
-sub connected_components {
- my $g = shift;
- $g->expect_undirected;
- my ($CCE, $CCI) = $g->_connected_components();
- return values %{ $CCI };
-}
-
-sub same_connected_components {
- my $g = shift;
- $g->expect_undirected;
- if ($g->has_union_find) {
- my $UF = $g->_get_union_find();
- my $V = $g->[ _V ];
- my $u = shift;
- my $c = $UF->find( $V->_get_path_id ( $u ) );
- my $d;
- for my $v ( @_) {
- return 0
- unless defined($d = $UF->find( $V->_get_path_id( $v ) )) &&
- $d eq $c;
- }
- return 1;
- } else {
- my ($CCE, $CCI) = $g->_connected_components();
- my $u = shift;
- my $c = $CCE->{ $u };
- for my $v ( @_) {
- return 0
- unless defined $CCE->{ $v } &&
- $CCE->{ $v } eq $c;
- }
- return 1;
- }
-}
-
-my $super_component = sub { join("+", sort @_) };
-
-sub connected_graph {
- my ($g, %opt) = @_;
- $g->expect_undirected;
- my $cg = Graph->new(undirected => 1);
- if ($g->has_union_find && $g->vertices == 1) {
- # TODO: super_component?
- $cg->add_vertices($g->vertices);
- } else {
- my $sc_cb =
- exists $opt{super_component} ?
- $opt{super_component} : $super_component;
- for my $cc ( $g->connected_components() ) {
- my $sc = $sc_cb->(@$cc);
- $cg->add_vertex($sc);
- $cg->set_vertex_attribute($sc, 'subvertices', [ @$cc ]);
- }
- }
- return $cg;
-}
-
-sub is_connected {
- my $g = shift;
- $g->expect_undirected;
- my ($CCE, $CCI) = $g->_connected_components();
- return keys %{ $CCI } == 1;
-}
-
-sub is_weakly_connected {
- my $g = shift;
- $g->expect_directed;
- $g->undirected_copy->is_connected(@_);
-}
-
-*weakly_connected = \&is_weakly_connected;
-
-sub weakly_connected_components {
- my $g = shift;
- $g->expect_directed;
- $g->undirected_copy->connected_components(@_);
-}
-
-sub weakly_connected_component_by_vertex {
- my $g = shift;
- $g->expect_directed;
- $g->undirected_copy->connected_component_by_vertex(@_);
-}
-
-sub weakly_connected_component_by_index {
- my $g = shift;
- $g->expect_directed;
- $g->undirected_copy->connected_component_by_index(@_);
-}
-
-sub same_weakly_connected_components {
- my $g = shift;
- $g->expect_directed;
- $g->undirected_copy->same_connected_components(@_);
-}
-
-sub weakly_connected_graph {
- my $g = shift;
- $g->expect_directed;
- $g->undirected_copy->connected_graph(@_);
-}
-
-sub _strongly_connected_components_compute {
- my $g = shift;
- my $t = Graph::Traversal::DFS->new($g);
- my @d = reverse $t->dfs;
- my @c;
- my $h = $g->transpose_graph;
- my $u =
- Graph::Traversal::DFS->new($h,
- next_root => sub {
- my ($t, $u) = @_;
- my $root;
- while (defined($root = shift @d)) {
- last if exists $u->{ $root };
- }
- if (defined $root) {
- push @c, [];
- return $root;
- } else {
- return;
- }
- },
- pre => sub {
- my ($v, $t) = @_;
- push @{ $c[-1] }, $v;
- },
- @_);
- $u->dfs;
- return \@c;
-}
-
-sub _strongly_connected_components {
- my $g = shift;
- my $scc = _check_cache($g, 'strong_connectivity',
- \&_strongly_connected_components_compute, @_);
- return defined $scc ? @$scc : ( );
-}
-
-sub strongly_connected_components {
- my $g = shift;
- $g->expect_directed;
- $g->_strongly_connected_components(@_);
-}
-
-sub strongly_connected_component_by_vertex {
- my $g = shift;
- my $v = shift;
- $g->expect_directed;
- my @scc = $g->_strongly_connected_components( next_alphabetic => 1, @_ );
- for (my $i = 0; $i <= $#scc; $i++) {
- for (my $j = 0; $j <= $#{ $scc[$i] }; $j++) {
- return $i if $scc[$i]->[$j] eq $v;
- }
- }
- return;
-}
-
-sub strongly_connected_component_by_index {
- my $g = shift;
- my $i = shift;
- $g->expect_directed;
- my $c = ( $g->_strongly_connected_components(@_) )[ $i ];
- return defined $c ? @{ $c } : ();
-}
-
-sub same_strongly_connected_components {
- my $g = shift;
- $g->expect_directed;
- my @scc = $g->_strongly_connected_components( next_alphabetic => 1, @_ );
- my @i;
- while (@_) {
- my $v = shift;
- for (my $i = 0; $i <= $#scc; $i++) {
- for (my $j = 0; $j <= $#{ $scc[$i] }; $j++) {
- if ($scc[$i]->[$j] eq $v) {
- push @i, $i;
- return 0 if @i > 1 && $i[-1] ne $i[0];
- }
- }
- }
- }
- return 1;
-}
-
-sub is_strongly_connected {
- my $g = shift;
- $g->expect_directed;
- my $t = Graph::Traversal::DFS->new($g);
- my @d = reverse $t->dfs;
- my @c;
- my $h = $g->transpose;
- my $u =
- Graph::Traversal::DFS->new($h,
- next_root => sub {
- my ($t, $u) = @_;
- my $root;
- while (defined($root = shift @d)) {
- last if exists $u->{ $root };
- }
- if (defined $root) {
- unless (@{ $t->{ roots } }) {
- push @c, [];
- return $root;
- } else {
- $t->terminate;
- return;
- }
- } else {
- return;
- }
- },
- pre => sub {
- my ($v, $t) = @_;
- push @{ $c[-1] }, $v;
- },
- @_);
- $u->dfs;
- return @{ $u->{ roots } } == 1 && keys %{ $u->{ unseen } } == 0;
-}
-
-*strongly_connected = \&is_strongly_connected;
-
-sub strongly_connected_graph {
- my $g = shift;
- my %attr = @_;
-
- $g->expect_directed;
-
- my $t = Graph::Traversal::DFS->new($g);
- my @d = reverse $t->dfs;
- my @c;
- my $h = $g->transpose;
- my $u =
- Graph::Traversal::DFS->new($h,
- next_root => sub {
- my ($t, $u) = @_;
- my $root;
- while (defined($root = shift @d)) {
- last if exists $u->{ $root };
- }
- if (defined $root) {
- push @c, [];
- return $root;
- } else {
- return;
- }
- },
- pre => sub {
- my ($v, $t) = @_;
- push @{ $c[-1] }, $v;
- }
- );
-
- $u->dfs;
-
- my $sc_cb;
- my $hv_cb;
-
- _opt_get(\%attr, super_component => \$sc_cb);
- _opt_get(\%attr, hypervertex => \$hv_cb);
- _opt_unknown(\%attr);
-
- if (defined $hv_cb && !defined $sc_cb) {
- $sc_cb = sub { $hv_cb->( [ @_ ] ) };
- }
- unless (defined $sc_cb) {
- $sc_cb = $super_component;
- }
-
- my $s = Graph->new;
-
- my %c;
- my @s;
- for (my $i = 0; $i < @c; $i++) {
- my $c = $c[$i];
- $s->add_vertex( $s[$i] = $sc_cb->(@$c) );
- $s->set_vertex_attribute($s[$i], 'subvertices', [ @$c ]);
- for my $v (@$c) {
- $c{$v} = $i;
- }
- }
-
- my $n = @c;
- for my $v ($g->vertices) {
- unless (exists $c{$v}) {
- $c{$v} = $n;
- $s[$n] = $v;
- $n++;
- }
- }
-
- for my $e ($g->edges05) {
- my ($u, $v) = @$e; # @TODO: hyperedges
- unless ($c{$u} == $c{$v}) {
- my ($p, $q) = ( $s[ $c{ $u } ], $s[ $c{ $v } ] );
- $s->add_edge($p, $q) unless $s->has_edge($p, $q);
- }
- }
-
- if (my @i = $g->isolated_vertices) {
- $s->add_vertices(map { $s[ $c{ $_ } ] } @i);
- }
-
- return $s;
-}
-
-###
-# Biconnectivity.
-#
-
-sub _make_bcc {
- my ($S, $v, $c) = @_;
- my %b;
- while (@$S) {
- my $t = pop @$S;
- $b{ $t } = $t;
- last if $t eq $v;
- }
- return [ values %b, $c ];
-}
-
-sub _biconnectivity_compute {
- my $g = shift;
- my ($opt, $unseenh, $unseena, $r, $next, $code, $attr) =
- $g->_root_opt(@_);
- return () unless defined $r;
- my %P;
- my %I;
- for my $v ($g->vertices) {
- $I{ $v } = 0;
- }
- $I{ $r } = 1;
- my %U;
- my %S; # Self-loops.
- for my $e ($g->edges) {
- my ($u, $v) = @$e;
- $U{ $u }{ $v } = 0;
- $U{ $v }{ $u } = 0;
- $S{ $u } = 1 if $u eq $v;
- }
- my $i = 1;
- my $v = $r;
- my %AP;
- my %L = ( $r => 1 );
- my @S = ( $r );
- my %A;
- my @V = $g->vertices;
-
- # print "V : @V\n";
- # print "r : $r\n";
-
- my %T; @T{ @V } = @V;
-
- for my $w (@V) {
- my @s = $g->successors( $w );
- if (@s) {
- @s = grep { $_ eq $w ? ( delete $T{ $w }, 0 ) : 1 } @s;
- @{ $A{ $w } }{ @s } = @s;
- } elsif ($g->predecessors( $w ) == 0) {
- delete $T{ $w };
- if ($w eq $r) {
- delete $I { $r };
- $r = $v = each %T;
- if (defined $r) {
- %L = ( $r => 1 );
- @S = ( $r );
- $I{ $r } = 1;
- # print "r : $r\n";
- }
- }
- }
- }
-
- # use Data::Dumper;
- # print "T : ", Dumper(\%T);
- # print "A : ", Dumper(\%A);
-
- my %V2BC;
- my @BR;
- my @BC;
-
- my @C;
- my $Avok;
-
- while (keys %T) {
- # print "T = ", Dumper(\%T);
- do {
- my $w;
- do {
- my @w = _shuffle values %{ $A{ $v } };
- # print "w = @w\n";
- $w = first { !$U{ $v }{ $_ } } @w;
- if (defined $w) {
- # print "w = $w\n";
- $U{ $v }{ $w }++;
- $U{ $w }{ $v }++;
- if ($I{ $w } == 0) {
- $P{ $w } = $v;
- $i++;
- $I{ $w } = $i;
- $L{ $w } = $i;
- push @S, $w;
- $v = $w;
- } else {
- $L{ $v } = $I{ $w } if $I{ $w } < $L{ $v };
- }
- }
- } while (defined $w);
- # print "U = ", Dumper(\%U);
- # print "P = ", Dumper(\%P);
- # print "L = ", Dumper(\%L);
- if (!defined $P{ $v }) {
- # Do nothing.
- } elsif ($P{ $v } ne $r) {
- if ($L{ $v } < $I{ $P{ $v } }) {
- $L{ $P{ $v } } = $L{ $v } if $L{ $v } < $L{ $P{ $v } };
- } else {
- $AP{ $P{ $v } } = $P{ $v };
- push @C, _make_bcc(\@S, $v, $P{ $v } );
- }
- } else {
- my $e;
- for my $w (_shuffle keys %{ $A{ $r } }) {
- # print "w = $w\n";
- unless ($U{ $r }{ $w }) {
- $e = $r;
- # print "e = $e\n";
- last;
- }
- }
- $AP{ $e } = $e if defined $e;
- push @C, _make_bcc(\@S, $v, $r);
- }
- # print "AP = ", Dumper(\%AP);
- # print "C = ", Dumper(\@C);
- # print "L = ", Dumper(\%L);
- $v = defined $P{ $v } ? $P{ $v } : $r;
- # print "v = $v\n";
- $Avok = 0;
- if (defined $v) {
- if (keys %{ $A{ $v } }) {
- if (!exists $P{ $v }) {
- for my $w (keys %{ $A{ $v } }) {
- $Avok++ if $U{ $v }{ $w };
- }
- # print "Avok/1 = $Avok\n";
- $Avok = 0 unless $Avok == keys %{ $A{ $v } };
- # print "Avok/2 = $Avok\n";
- }
- } else {
- $Avok = 1;
- # print "Avok/3 = $Avok\n";
- }
- }
- } until ($Avok);
-
- last if @C == 0 && !exists $S{$v};
-
- for (my $i = 0; $i < @C; $i++) {
- for my $v (@{ $C[ $i ]}) {
- $V2BC{ $v }{ $i }++;
- delete $T{ $v };
- }
- }
-
- for (my $i = 0; $i < @C; $i++) {
- if (@{ $C[ $i ] } == 2) {
- push @BR, $C[ $i ];
- } else {
- push @BC, $C[ $i ];
- }
- }
-
- if (keys %T) {
- $r = $v = each %T;
- }
- }
-
- return [ [values %AP], \@BC, \@BR, \%V2BC ];
-}
-
-sub biconnectivity {
- my $g = shift;
- $g->expect_undirected;
- my $bcc = _check_cache($g, 'biconnectivity',
- \&_biconnectivity_compute, @_);
- return defined $bcc ? @$bcc : ( );
-}
-
-sub is_biconnected {
- my $g = shift;
- my ($ap, $bc) = ($g->biconnectivity(@_))[0, 1];
- return defined $ap ? @$ap == 0 && $g->vertices >= 3 : undef;
-}
-
-sub is_edge_connected {
- my $g = shift;
- my ($br) = ($g->biconnectivity(@_))[2];
- return defined $br ? @$br == 0 && $g->edges : undef;
-}
-
-sub is_edge_separable {
- my $g = shift;
- my $c = $g->is_edge_connected;
- defined $c ? !$c && $g->edges : undef;
-}
-
-sub articulation_points {
- my $g = shift;
- my ($ap) = ($g->biconnectivity(@_))[0];
- return defined $ap ? @$ap : ();
-}
-
-*cut_vertices = \&articulation_points;
-
-sub biconnected_components {
- my $g = shift;
- my ($bc) = ($g->biconnectivity(@_))[1];
- return defined $bc ? @$bc : ();
-}
-
-sub biconnected_component_by_index {
- my $g = shift;
- my $i = shift;
- my ($bc) = ($g->biconnectivity(@_))[1];
- return defined $bc ? $bc->[ $i ] : undef;
-}
-
-sub biconnected_component_by_vertex {
- my $g = shift;
- my $v = shift;
- my ($v2bc) = ($g->biconnectivity(@_))[3];
- return defined $v2bc->{ $v } ? keys %{ $v2bc->{ $v } } : ();
-}
-
-sub same_biconnected_components {
- my $g = shift;
- my $u = shift;
- my @u = $g->biconnected_component_by_vertex($u, @_);
- return 0 unless @u;
- my %ubc; @ubc{ @u } = ();
- while (@_) {
- my $v = shift;
- my @v = $g->biconnected_component_by_vertex($v);
- if (@v) {
- my %vbc; @vbc{ @v } = ();
- my $vi;
- for my $ui (keys %ubc) {
- if (exists $vbc{ $ui }) {
- $vi = $ui;
- last;
- }
- }
- return 0 unless defined $vi;
- }
- }
- return 1;
-}
-
-sub biconnected_graph {
- my ($g, %opt) = @_;
- my ($bc, $v2bc) = ($g->biconnectivity, %opt)[1, 3];
- my $bcg = Graph::Undirected->new;
- my $sc_cb =
- exists $opt{super_component} ?
- $opt{super_component} : $super_component;
- for my $c (@$bc) {
- $bcg->add_vertex(my $s = $sc_cb->(@$c));
- $bcg->set_vertex_attribute($s, 'subvertices', [ @$c ]);
- }
- my %k;
- for my $i (0..$#$bc) {
- my @u = @{ $bc->[ $i ] };
- my %i; @i{ @u } = ();
- for my $j (0..$#$bc) {
- if ($i > $j) {
- my @v = @{ $bc->[ $j ] };
- my %j; @j{ @v } = ();
- for my $u (@u) {
- if (exists $j{ $u }) {
- unless ($k{ $i }{ $j }++) {
- $bcg->add_edge($sc_cb->(@{$bc->[$i]}),
- $sc_cb->(@{$bc->[$j]}));
- }
- last;
- }
- }
- }
- }
- }
- return $bcg;
-}
-
-sub bridges {
- my $g = shift;
- my ($br) = ($g->biconnectivity(@_))[2];
- return defined $br ? @$br : ();
-}
-
-###
-# SPT.
-#
-
-sub _SPT_add {
- my ($g, $h, $HF, $r, $attr, $unseen, $etc) = @_;
- my $etc_r = $etc->{ $r } || 0;
- for my $s ( grep { exists $unseen->{ $_ } } $g->successors( $r ) ) {
- my $t = $g->get_edge_attribute( $r, $s, $attr );
- $t = 1 unless defined $t;
- if ($t < 0) {
- require Carp;
- Carp::croak("Graph::SPT_Dijkstra: edge $r-$s is negative ($t)");
- }
- if (!defined($etc->{ $s }) || ($etc_r + $t) < $etc->{ $s }) {
- my $etc_s = $etc->{ $s } || 0;
- $etc->{ $s } = $etc_r + $t;
- # print "$r - $s : setting $s to $etc->{ $s } ($etc_r, $etc_s)\n";
- $h->set_vertex_attribute( $s, $attr, $etc->{ $s });
- $h->set_vertex_attribute( $s, 'p', $r );
- $HF->add( Graph::SPTHeapElem->new($r, $s, $etc->{ $s }) );
- }
- }
-}
-
-sub _SPT_Dijkstra_compute {
-}
-
-sub SPT_Dijkstra {
- my $g = shift;
- my %opt = @_ == 1 ? (first_root => $_[0]) : @_;
- my $first_root = $opt{ first_root };
- unless (defined $first_root) {
- $opt{ first_root } = $first_root = $g->random_vertex();
- }
- my $spt_di = $g->get_graph_attribute('_spt_di');
- unless (defined $spt_di && exists $spt_di->{ $first_root } && $spt_di->{ $first_root }->[ 0 ] == $g->[ _G ]) {
- my %etc;
- my $sptg = $g->_heap_walk($g->new, \&_SPT_add, \%etc, %opt);
- $spt_di->{ $first_root } = [ $g->[ _G ], $sptg ];
- $g->set_graph_attribute('_spt_di', $spt_di);
- }
-
- my $spt = $spt_di->{ $first_root }->[ 1 ];
-
- $spt->set_graph_attribute('SPT_Dijkstra_root', $first_root);
-
- return $spt;
-}
-
-*SSSP_Dijkstra = \&SPT_Dijkstra;
-
-*single_source_shortest_paths = \&SPT_Dijkstra;
-
-sub SP_Dijkstra {
- my ($g, $u, $v) = @_;
- my $sptg = $g->SPT_Dijkstra(first_root => $u);
- my @path = ($v);
- my %seen;
- my $V = $g->vertices;
- my $p;
- while (defined($p = $sptg->get_vertex_attribute($v, 'p'))) {
- last if exists $seen{$p};
- push @path, $p;
- $v = $p;
- $seen{$p}++;
- last if keys %seen == $V || $u eq $v;
- }
- @path = () if @path && $path[-1] ne $u;
- return reverse @path;
-}
-
-sub __SPT_Bellman_Ford {
- my ($g, $u, $v, $attr, $d, $p, $c0, $c1) = @_;
- return unless $c0->{ $u };
- my $w = $g->get_edge_attribute($u, $v, $attr);
- $w = 1 unless defined $w;
- if (defined $d->{ $v }) {
- if (defined $d->{ $u }) {
- if ($d->{ $v } > $d->{ $u } + $w) {
- $d->{ $v } = $d->{ $u } + $w;
- $p->{ $v } = $u;
- $c1->{ $v }++;
- }
- } # else !defined $d->{ $u } && defined $d->{ $v }
- } else {
- if (defined $d->{ $u }) {
- # defined $d->{ $u } && !defined $d->{ $v }
- $d->{ $v } = $d->{ $u } + $w;
- $p->{ $v } = $u;
- $c1->{ $v }++;
- } # else !defined $d->{ $u } && !defined $d->{ $v }
- }
-}
-
-sub _SPT_Bellman_Ford {
- my ($g, $opt, $unseenh, $unseena, $r, $next, $code, $attr) = @_;
- my %d;
- return unless defined $r;
- $d{ $r } = 0;
- my %p;
- my $V = $g->vertices;
- my %c0; # Changed during the last iteration?
- $c0{ $r }++;
- for (my $i = 0; $i < $V; $i++) {
- my %c1;
- for my $e ($g->edges) {
- my ($u, $v) = @$e;
- __SPT_Bellman_Ford($g, $u, $v, $attr, \%d, \%p, \%c0, \%c1);
- if ($g->undirected) {
- __SPT_Bellman_Ford($g, $v, $u, $attr, \%d, \%p, \%c0, \%c1);
- }
- }
- %c0 = %c1 unless $i == $V - 1;
- }
-
- for my $e ($g->edges) {
- my ($u, $v) = @$e;
- if (defined $d{ $u } && defined $d{ $v }) {
- my $d = $g->get_edge_attribute($u, $v, $attr);
- if (defined $d && $d{ $v } > $d{ $u } + $d) {
- require Carp;
- Carp::croak("Graph::SPT_Bellman_Ford: negative cycle exists");
- }
- }
- }
-
- return (\%p, \%d);
-}
-
-sub _SPT_Bellman_Ford_compute {
-}
-
-sub SPT_Bellman_Ford {
- my $g = shift;
-
- my ($opt, $unseenh, $unseena, $r, $next, $code, $attr) = $g->_root_opt(@_);
-
- unless (defined $r) {
- $r = $g->random_vertex();
- return unless defined $r;
- }
-
- my $spt_bf = $g->get_graph_attribute('_spt_bf');
- unless (defined $spt_bf &&
- exists $spt_bf->{ $r } && $spt_bf->{ $r }->[ 0 ] == $g->[ _G ]) {
- my ($p, $d) =
- $g->_SPT_Bellman_Ford($opt, $unseenh, $unseena,
- $r, $next, $code, $attr);
- my $h = $g->new;
- for my $v (keys %$p) {
- my $u = $p->{ $v };
- $h->add_edge( $u, $v );
- $h->set_edge_attribute( $u, $v, $attr,
- $g->get_edge_attribute($u, $v, $attr));
- $h->set_vertex_attribute( $v, $attr, $d->{ $v } );
- $h->set_vertex_attribute( $v, 'p', $u );
- }
- $spt_bf->{ $r } = [ $g->[ _G ], $h ];
- $g->set_graph_attribute('_spt_bf', $spt_bf);
- }
-
- my $spt = $spt_bf->{ $r }->[ 1 ];
-
- $spt->set_graph_attribute('SPT_Bellman_Ford_root', $r);
-
- return $spt;
-}
-
-*SSSP_Bellman_Ford = \&SPT_Bellman_Ford;
-
-sub SP_Bellman_Ford {
- my ($g, $u, $v) = @_;
- my $sptg = $g->SPT_Bellman_Ford(first_root => $u);
- my @path = ($v);
- my %seen;
- my $V = $g->vertices;
- my $p;
- while (defined($p = $sptg->get_vertex_attribute($v, 'p'))) {
- last if exists $seen{$p};
- push @path, $p;
- $v = $p;
- $seen{$p}++;
- last if keys %seen == $V;
- }
- # @path = () if @path && "$path[-1]" ne "$u";
- return reverse @path;
-}
-
-###
-# Transitive Closure.
-#
-
-sub TransitiveClosure_Floyd_Warshall {
- my $self = shift;
- my $class = ref $self || $self;
- $self = shift unless ref $self;
- bless Graph::TransitiveClosure->new($self, @_), $class;
-}
-
-*transitive_closure = \&TransitiveClosure_Floyd_Warshall;
-
-sub APSP_Floyd_Warshall {
- my $self = shift;
- my $class = ref $self || $self;
- $self = shift unless ref $self;
- bless Graph::TransitiveClosure->new($self, path => 1, @_), $class;
-}
-
-*all_pairs_shortest_paths = \&APSP_Floyd_Warshall;
-
-sub _transitive_closure_matrix_compute {
-}
-
-sub transitive_closure_matrix {
- my $g = shift;
- my $tcm = $g->get_graph_attribute('_tcm');
- if (defined $tcm) {
- if (ref $tcm eq 'ARRAY') { # YECHHH!
- if ($tcm->[ 0 ] == $g->[ _G ]) {
- $tcm = $tcm->[ 1 ];
- } else {
- undef $tcm;
- }
- }
- }
- unless (defined $tcm) {
- my $apsp = $g->APSP_Floyd_Warshall(@_);
- $tcm = $apsp->get_graph_attribute('_tcm');
- $g->set_graph_attribute('_tcm', [ $g->[ _G ], $tcm ]);
- }
-
- return $tcm;
-}
-
-sub path_length {
- my $g = shift;
- my $tcm = $g->transitive_closure_matrix;
- $tcm->path_length(@_);
-}
-
-sub path_predecessor {
- my $g = shift;
- my $tcm = $g->transitive_closure_matrix;
- $tcm->path_predecessor(@_);
-}
-
-sub path_vertices {
- my $g = shift;
- my $tcm = $g->transitive_closure_matrix;
- $tcm->path_vertices(@_);
-}
-
-sub is_reachable {
- my $g = shift;
- my $tcm = $g->transitive_closure_matrix;
- $tcm->is_reachable(@_);
-}
-
-sub for_shortest_paths {
- my $g = shift;
- my $c = shift;
- my $t = $g->transitive_closure_matrix;
- my @v = $g->vertices;
- my $n = 0;
- for my $u (@v) {
- for my $v (@v) {
- next unless $t->is_reachable($u, $v);
- $n++;
- $c->($t, $u, $v, $n);
- }
- }
- return $n;
-}
-
-sub _minmax_path {
- my $g = shift;
- my $min;
- my $max;
- my $minp;
- my $maxp;
- $g->for_shortest_paths(sub {
- my ($t, $u, $v, $n) = @_;
- my $l = $t->path_length($u, $v);
- return unless defined $l;
- my $p;
- if ($u ne $v && (!defined $max || $l > $max)) {
- $max = $l;
- $maxp = $p = [ $t->path_vertices($u, $v) ];
- }
- if ($u ne $v && (!defined $min || $l < $min)) {
- $min = $l;
- $minp = $p || [ $t->path_vertices($u, $v) ];
- }
- });
- return ($min, $max, $minp, $maxp);
-}
-
-sub diameter {
- my $g = shift;
- my ($min, $max, $minp, $maxp) = $g->_minmax_path(@_);
- return defined $maxp ? (wantarray ? @$maxp : $max) : undef;
-}
-
-*graph_diameter = \&diameter;
-
-sub longest_path {
- my ($g, $u, $v) = @_;
- my $t = $g->transitive_closure_matrix;
- if (defined $u) {
- if (defined $v) {
- return wantarray ?
- $t->path_vertices($u, $v) : $t->path_length($u, $v);
- } else {
- my $max;
- my @max;
- for my $v ($g->vertices) {
- next if $u eq $v;
- my $l = $t->path_length($u, $v);
- if (defined $l && (!defined $max || $l > $max)) {
- $max = $l;
- @max = $t->path_vertices($u, $v);
- }
- }
- return wantarray ? @max : $max;
- }
- } else {
- if (defined $v) {
- my $max;
- my @max;
- for my $u ($g->vertices) {
- next if $u eq $v;
- my $l = $t->path_length($u, $v);
- if (defined $l && (!defined $max || $l > $max)) {
- $max = $l;
- @max = $t->path_vertices($u, $v);
- }
- }
- return wantarray ? @max : @max - 1;
- } else {
- my ($min, $max, $minp, $maxp) = $g->_minmax_path(@_);
- return defined $maxp ? (wantarray ? @$maxp : $max) : undef;
- }
- }
-}
-
-sub vertex_eccentricity {
- my ($g, $u) = @_;
- $g->expect_undirected;
- if ($g->is_connected) {
- my $max;
- for my $v ($g->vertices) {
- next if $u eq $v;
- my $l = $g->path_length($u, $v);
- if (defined $l && (!defined $max || $l > $max)) {
- $max = $l;
- }
- }
- return $max;
- } else {
- return Infinity();
- }
-}
-
-sub shortest_path {
- my ($g, $u, $v) = @_;
- $g->expect_undirected;
- my $t = $g->transitive_closure_matrix;
- if (defined $u) {
- if (defined $v) {
- return wantarray ?
- $t->path_vertices($u, $v) : $t->path_length($u, $v);
- } else {
- my $min;
- my @min;
- for my $v ($g->vertices) {
- next if $u eq $v;
- my $l = $t->path_length($u, $v);
- if (defined $l && (!defined $min || $l < $min)) {
- $min = $l;
- @min = $t->path_vertices($u, $v);
- }
- }
- return wantarray ? @min : $min;
- }
- } else {
- if (defined $v) {
- my $min;
- my @min;
- for my $u ($g->vertices) {
- next if $u eq $v;
- my $l = $t->path_length($u, $v);
- if (defined $l && (!defined $min || $l < $min)) {
- $min = $l;
- @min = $t->path_vertices($u, $v);
- }
- }
- return wantarray ? @min : $min;
- } else {
- my ($min, $max, $minp, $maxp) = $g->_minmax_path(@_);
- return defined $minp ? (wantarray ? @$minp : $min) : undef;
- }
- }
-}
-
-sub radius {
- my $g = shift;
- $g->expect_undirected;
- my ($center, $radius) = (undef, Infinity());
- for my $v ($g->vertices) {
- my $x = $g->vertex_eccentricity($v);
- ($center, $radius) = ($v, $x) if defined $x && $x < $radius;
- }
- return $radius;
-}
-
-sub center_vertices {
- my ($g, $delta) = @_;
- $g->expect_undirected;
- $delta = 0 unless defined $delta;
- $delta = abs($delta);
- my @c;
- my $r = $g->radius;
- if (defined $r) {
- for my $v ($g->vertices) {
- my $e = $g->vertex_eccentricity($v);
- next unless defined $e;
- push @c, $v if abs($e - $r) <= $delta;
- }
- }
- return @c;
-}
-
-*centre_vertices = \&center_vertices;
-
-sub average_path_length {
- my $g = shift;
- my @A = @_;
- my $d = 0;
- my $m = 0;
- my $n = $g->for_shortest_paths(sub {
- my ($t, $u, $v, $n) = @_;
- my $l = $t->path_length($u, $v);
- if ($l) {
- my $c = @A == 0 ||
- (@A == 1 && $u eq $A[0]) ||
- ((@A == 2) &&
- (defined $A[0] &&
- $u eq $A[0]) ||
- (defined $A[1] &&
- $v eq $A[1]));
- if ($c) {
- $d += $l;
- $m++;
- }
- }
- });
- return $m ? $d / $m : undef;
-}
-
-###
-# Simple tests.
-#
-
-sub is_multi_graph {
- my $g = shift;
- return 0 unless $g->is_multiedged || $g->is_countedged;
- my $multiedges = 0;
- for my $e ($g->edges05) {
- my ($u, @v) = @$e;
- for my $v (@v) {
- return 0 if $u eq $v;
- }
- $multiedges++ if $g->get_edge_count(@$e) > 1;
- }
- return $multiedges;
-}
-
-sub is_simple_graph {
- my $g = shift;
- return 1 unless $g->is_countedged || $g->is_multiedged;
- for my $e ($g->edges05) {
- return 0 if $g->get_edge_count(@$e) > 1;
- }
- return 1;
-}
-
-sub is_pseudo_graph {
- my $g = shift;
- my $m = $g->is_countedged || $g->is_multiedged;
- for my $e ($g->edges05) {
- my ($u, @v) = @$e;
- for my $v (@v) {
- return 1 if $u eq $v;
- }
- return 1 if $m && $g->get_edge_count($u, @v) > 1;
- }
- return 0;
-}
-
-###
-# Rough isomorphism guess.
-#
-
-my %_factorial = (0 => 1, 1 => 1);
-
-sub __factorial {
- my $n = shift;
- for (my $i = 2; $i <= $n; $i++) {
- next if exists $_factorial{$i};
- $_factorial{$i} = $i * $_factorial{$i - 1};
- }
- $_factorial{$n};
-}
-
-sub _factorial {
- my $n = int(shift);
- if ($n < 0) {
- require Carp;
- Carp::croak("factorial of a negative number");
- }
- __factorial($n) unless exists $_factorial{$n};
- return $_factorial{$n};
-}
-
-sub could_be_isomorphic {
- my ($g0, $g1) = @_;
- return 0 unless $g0->vertices == $g1->vertices;
- return 0 unless $g0->edges05 == $g1->edges05;
- my %d0;
- for my $v0 ($g0->vertices) {
- $d0{ $g0->in_degree($v0) }{ $g0->out_degree($v0) }++
- }
- my %d1;
- for my $v1 ($g1->vertices) {
- $d1{ $g1->in_degree($v1) }{ $g1->out_degree($v1) }++
- }
- return 0 unless keys %d0 == keys %d1;
- for my $da (keys %d0) {
- return 0
- unless exists $d1{$da} &&
- keys %{ $d0{$da} } == keys %{ $d1{$da} };
- for my $db (keys %{ $d0{$da} }) {
- return 0
- unless exists $d1{$da}{$db} &&
- $d0{$da}{$db} == $d1{$da}{$db};
- }
- }
- for my $da (keys %d0) {
- for my $db (keys %{ $d0{$da} }) {
- return 0 unless $d1{$da}{$db} == $d0{$da}{$db};
- }
- delete $d1{$da};
- }
- return 0 unless keys %d1 == 0;
- my $f = 1;
- for my $da (keys %d0) {
- for my $db (keys %{ $d0{$da} }) {
- $f *= _factorial(abs($d0{$da}{$db}));
- }
- }
- return $f;
-}
-
-###
-# Debugging.
-#
-
-sub _dump {
- require Data::Dumper;
- my $d = Data::Dumper->new([$_[0]],[ref $_[0]]);
- defined wantarray ? $d->Dump : print $d->Dump;
-}
-
-1;
diff --git a/perllib/Graph.pod b/perllib/Graph.pod
deleted file mode 100644
index 9452d51..0000000
--- a/perllib/Graph.pod
+++ /dev/null
@@ -1,2768 +0,0 @@
-=pod
-
-=head1 NAME
-
-Graph - graph data structures and algorithms
-
-=head1 SYNOPSIS
-
- use Graph;
- my $g0 = Graph->new; # A directed graph.
-
- use Graph::Directed;
- my $g1 = Graph::Directed->new; # A directed graph.
-
- use Graph::Undirected;
- my $g2 = Graph::Undirected->new; # An undirected graph.
-
- $g->add_edge(...);
- $g->has_edge(...)
- $g->delete_edge(...);
-
- $g->add_vertex(...);
- $g->has_vertex(...);
- $g->delete_vertex(...);
-
- $g->vertices(...)
- $g->edges(...)
-
- # And many, many more, see below.
-
-=head1 DESCRIPTION
-
-=head2 Non-Description
-
-This module is not for B<drawing> any sort of I<graphics>, business or
-otherwise.
-
-=head2 Description
-
-Instead, this module is for creating I<abstract data structures>
-called graphs, and for doing various operations on those.
-
-=head2 Perl 5.6.0 minimum
-
-The implementation depends on a Perl feature called "weak references"
-and Perl 5.6.0 was the first to have those.
-
-=head2 Constructors
-
-=over 4
-
-=item new
-
-Create an empty graph.
-
-=item Graph->new(%options)
-
-The options are a hash with option names as the hash keys and the option
-values as the hash values.
-
-The following options are available:
-
-=over 8
-
-=item *
-
-directed
-
-A boolean option telling that a directed graph should be created.
-Often somewhat redundant because a directed graph is the default
-for the Graph class or one could simply use the C<new()> constructor
-of the Graph::Directed class.
-
-You can test the directness of a graph with $g->is_directed() and
-$g->is_undirected().
-
-=item *
-
-undirected
-
-A boolean option telling that an undirected graph should be created.
-One could also use the C<new()> constructor the Graph::Undirected class
-instead.
-
-Note that while often it is possible to think undirected graphs as
-bidirectional graphs, or as directed graphs with edges going both ways,
-in this module directed graphs and undirected graphs are two different
-things that often behave differently.
-
-You can test the directness of a graph with $g->is_directed() and
-$g->is_undirected().
-
-=item *
-
-refvertexed
-
-If you want to use references (including Perl objects) as vertices.
-
-=item *
-
-unionfind
-
-If the graph is undirected, you can specify the C<unionfind> parameter
-to use the so-called union-find scheme to speed up the computation of
-I<connected components> of the graph (see L</is_connected>,
-L</connected_components>, L</connected_component_by_vertex>,
-L</connected_component_by_index>, and L</same_connected_components>).
-If C<unionfind> is used, adding edges (and vertices) becomes slower,
-but connectedness queries become faster. You can test a graph for
-"union-findness" with
-
-=over 8
-
-=item has_union_find
-
- has_union_find
-
-=back
-
-=item *
-
-vertices
-
-An array reference of vertices to add.
-
-=item *
-
-edges
-
-An array reference of array references of edge vertices to add.
-
-=back
-
-=item copy
-
-=item copy_graph
-
- my $c = $g->copy_graph;
-
-Create a shallow copy of the structure (vertices and edges) of the graph.
-If you want a deep copy that includes attributes, see L</deep_copy>.
-The copy will have the same directedness as the original.
-
-=item deep_copy
-
-=item deep_copy_graph
-
- my $c = $g->deep_copy_graph;
-
-Create a deep copy of the graph (vertices, edges, and attributes) of
-the graph. If you want a shallow copy that does not include attributes,
-see L</copy>. (Uses Data::Dumper behind the scenes. Note that copying
-code references only works with Perls 5.8 or later, and even then only
-if B::Deparse can reconstruct your code.)
-
-=item undirected_copy
-
-=item undirected_copy_graph
-
- my $c = $g->undirected_copy_graph;
-
-Create an undirected shallow copy (vertices and edges) of the directed graph
-so that for any directed edge (u, v) there is an undirected edge (u, v).
-
-=item directed_copy
-
-=item directed_copy_graph
-
- my $c = $g->directed_copy_graph;
-
-Create a directed shallow copy (vertices and edges) of the undirected graph
-so that for any undirected edge (u, v) there are two directed edges (u, v)
-and (v, u).
-
-=item transpose
-
-=item transpose_graph
-
- my $t = $g->transpose_graph;
-
-Create a directed shallow transposed copy (vertices and edges) of the
-directed graph so that for any directed edge (u, v) there is a directed
-edge (v, u).
-
-You can also transpose a single edge with
-
-=over 8
-
-=item transpose_edge
-
- $g->transpose_edge($u, $v)
-
-=back
-
-=item complete_graph
-
-=item complete
-
- my $c = $g->complete_graph;
-
-Create a complete graph that has the same vertices as the original graph.
-A complete graph has an edge between every pair of vertices.
-
-=item complement_graph
-
-=item complement
-
- my $c = $g->complement_graph;
-
-Create a complement graph that has the same vertices as the original graph.
-A complement graph has an edge (u,v) if and only if the original
-graph does not have edge (u,v).
-
-=back
-
-See also L</random_graph> for a random constructor.
-
-=head2 Basics
-
-=over 4
-
-=item add_vertex
-
- $g->add_vertex($v)
-
-Add the vertex to the graph. Returns the graph.
-
-By default idempotent, but a graph can be created I<countvertexed>.
-
-A vertex is also known as a I<node>.
-
-Adding C<undef> as vertex is not allowed.
-
-Note that unless you have isolated vertices (or I<countvertexed>
-vertices), you do not need to explicitly use C<add_vertex> since
-L</add_edge> will implicitly add its vertices.
-
-=item add_edge
-
- $g->add_edge($u, $v)
-
-Add the edge to the graph. Implicitly first adds the vertices if the
-graph does not have them. Returns the graph.
-
-By default idempotent, but a graph can be created I<countedged>.
-
-An edge is also known as an I<arc>.
-
-=item has_vertex
-
- $g->has_vertex($v)
-
-Return true if the vertex exists in the graph, false otherwise.
-
-=item has_edge
-
- $g->has_edge($u, $v)
-
-Return true if the edge exists in the graph, false otherwise.
-
-=item delete_vertex
-
- $g->delete_vertex($v)
-
-Delete the vertex from the graph. Returns the graph, even
-if the vertex did not exist in the graph.
-
-If the graph has been created I<multivertexed> or I<countvertexed>
-and a vertex has been added multiple times, the vertex will require
-at least an equal number of deletions to become completely deleted.
-
-=item delete_vertices
-
- $g->delete_vertices($v1, $v2, ...)
-
-Delete the vertices from the graph. Returns the graph.
-
-If the graph has been created I<multivertexed> or I<countvertexed>
-and a vertex has been added multiple times, the vertex will require
-at least an equal number of deletions to become completely deleteted.
-
-=item delete_edge
-
- $g->delete_edge($u, $v)
-
-Delete the edge from the graph. Returns the graph, even
-if the edge did not exist in the graph.
-
-If the graph has been created I<multivertexed> or I<countedged>
-and an edge has been added multiple times, the edge will require
-at least an equal number of deletions to become completely deleted.
-
-=item delete_edges
-
- $g->delete_edges($u1, $v1, $u2, $v2, ...)
-
-Delete the edges from the graph. Returns the graph.
-
-If the graph has been created I<multivertexed> or I<countedged>
-and an edge has been added multiple times, the edge will require
-at least an equal number of deletions to become completely deleted.
-
-=back
-
-=head2 Displaying
-
-Graphs have stringification overload, so you can do things like
-
- print "The graph is $g\n"
-
-One-way (directed, unidirected) edges are shown as '-', two-way
-(undirected, bidirected) edges are shown as '='. If you want to,
-you can call the stringification via the method
-
-=over 4
-
-=item stringify
-
-=back
-
-=head2 Comparing
-
-Testing for equality can be done either by the overloaded C<eq>
-operator
-
- $g eq "a-b,a-c,d"
-
-or by the method
-
-=over 4
-
-=item eq
-
- $g->eq("a-b,a-c,d")
-
-=back
-
-The equality testing compares the stringified forms, and therefore it
-assumes total equality, not isomorphism: all the vertices must be
-named the same, and they must have identical edges between them.
-
-For unequality there are correspondingly the overloaded C<ne>
-operator and the method
-
-=over 4
-
-=item ne
-
- $g->ne("a-b,a-c,d")
-
-=back
-
-See also L</Isomorphism>.
-
-=head2 Paths and Cycles
-
-Paths and cycles are simple extensions of edges: paths are edges
-starting from where the previous edge ended, and cycles are paths
-returning back to the start vertex of the first edge.
-
-=over 4
-
-=item add_path
-
- $g->add_path($a, $b, $c, ..., $x, $y, $z)
-
-Add the edges $a-$b, $b-$c, ..., $x-$y, $y-$z to the graph.
-Returns the graph.
-
-=item has_path
-
- $g->has_path($a, $b, $c, ..., $x, $y, $z)
-
-Return true if the graph has all the edges $a-$b, $b-$c, ..., $x-$y, $y-$z,
-false otherwise.
-
-=item delete_path
-
- $g->delete_path($a, $b, $c, ..., $x, $y, $z)
-
-Delete all the edges edges $a-$b, $b-$c, ..., $x-$y, $y-$z
-(regardless of whether they exist or not). Returns the graph.
-
-=item add_cycle
-
- $g->add_cycle($a, $b, $c, ..., $x, $y, $z)
-
-Add the edges $a-$b, $b-$c, ..., $x-$y, $y-$z, and $z-$a to the graph.
-Returns the graph.
-
-=item has_cycle
-
- $g->has_cycle($a, $b, $c, ..., $x, $y, $z)
-
-Return true if the graph has all the edges $a-$b, $b-$c, ..., $x-$y, $y-$z,
-and $z-$a, false otherwise.
-
-B<NOTE:> This does not I<detect> cycles, see L</has_a_cycle> and
-L</find_a_cycle>.
-
-=item delete_cycle
-
- $g->delete_cycle($a, $b, $c, ..., $x, $y, $z)
-
-Delete all the edges edges $a-$b, $b-$c, ..., $x-$y, $y-$z, and $z-$a
-(regardless of whether they exist or not). Returns the graph.
-
-=item has_a_cycle
-
- $g->has_a_cycle
-
-Returns true if the graph has a cycle, false if not.
-
-=item find_a_cycle
-
- $g->find_a_cycle
-
-Returns a cycle if the graph has one (as a list of vertices), an empty
-list if no cycle can be found.
-
-Note that this just returns the vertices of I<a cycle>: not any
-particular cycle, just the first one it finds. A repeated call
-might find the same cycle, or it might find a different one, and
-you cannot call this repeatedly to find all the cycles.
-
-=back
-
-=head2 Graph Types
-
-=over 4
-
-=item is_simple_graph
-
- $g->is_simple_graph
-
-Return true if the graph has no multiedges, false otherwise.
-
-=item is_pseudo_graph
-
- $g->is_pseudo_graph
-
-Return true if the graph has any multiedges or any self-loops,
-false otherwise.
-
-=item is_multi_graph
-
- $g->is_multi_graph
-
-Return true if the graph has any multiedges but no self-loops,
-false otherwise.
-
-=item is_directed_acyclic_graph
-
-=item is_dag
-
- $g->is_directed_acyclic_graph
- $g->is_dag
-
-Return true if the graph is directed and acyclic, false otherwise.
-
-=item is_cyclic
-
- $g->is_cyclic
-
-Return true if the graph is cyclic (contains at least one cycle).
-(This is identical to C<has_a_cycle>.)
-
-To find at least that one cycle, see L</find_a_cycle>.
-
-=item is_acyclic
-
-Return true if the graph is acyclic (does not contain any cycles).
-
-=back
-
-To find a cycle, use L<find_a_cycle>.
-
-=head2 Transitivity
-
-=over 4
-
-=item is_transitive
-
- $g->is_transitive
-
-Return true if the graph is transitive, false otherwise.
-
-=item TransitiveClosure_Floyd_Warshall
-
-=item transitive_closure
-
- $tcg = $g->TransitiveClosure_Floyd_Warshall
-
-Return the transitive closure graph of the graph.
-
-=back
-
-You can query the reachability from $u to $v with
-
-=over 4
-
-=item is_reachable
-
- $tcg->is_reachable($u, $v)
-
-=back
-
-See L<Graph::TransitiveClosure> for more information about creating
-and querying transitive closures.
-
-With
-
-=over 4
-
-=item transitive_closure_matrix
-
- $tcm = $g->transitive_closure_matrix;
-
-=back
-
-you can (create if not existing and) query the transitive closure
-matrix that underlies the transitive closure graph. See
-L<Graph::TransitiveClosure::Matrix> for more information.
-
-=head2 Mutators
-
-=over 4
-
-=item add_vertices
-
- $g->add_vertices('d', 'e', 'f')
-
-Add zero or more vertices to the graph.
-
-=item add_edges
-
- $g->add_edges(['d', 'e'], ['f', 'g'])
- $g->add_edges(qw(d e f g));
-
-Add zero or more edges to the graph. The edges are specified as
-a list of array references, or as a list of vertices where the
-even (0th, 2nd, 4th, ...) items are start vertices and the odd
-(1st, 3rd, 5th, ...) are the corresponding end vertices.
-
-=back
-
-=head2 Accessors
-
-=over 4
-
-=item is_directed
-
-=item directed
-
- $g->is_directed()
- $g->directed()
-
-Return true if the graph is directed, false otherwise.
-
-=item is_undirected
-
-=item undirected
-
- $g->is_undirected()
- $g->undirected()
-
-Return true if the graph is undirected, false otherwise.
-
-=item is_refvertexed
-
-=item refvertexed
-
-Return true if the graph can handle references (including Perl objects)
-as vertices.
-
-=item vertices
-
- my $V = $g->vertices
- my @V = $g->vertices
-
-In scalar context, return the number of vertices in the graph.
-In list context, return the vertices, in no particular order.
-
-=item has_vertices
-
- $g->has_vertices()
-
-Return true if the graph has any vertices, false otherwise.
-
-=item edges
-
- my $E = $g->edges
- my @E = $g->edges
-
-In scalar context, return the number of edges in the graph.
-In list context, return the edges, in no particular order.
-I<The edges are returned as anonymous arrays listing the vertices.>
-
-=item has_edges
-
- $g->has_edges()
-
-Return true if the graph has any edges, false otherwise.
-
-=item is_connected
-
- $g->is_connected
-
-For an undirected graph, return true is the graph is connected, false
-otherwise. Being connected means that from every vertex it is possible
-to reach every other vertex.
-
-If the graph has been created with a true C<unionfind> parameter,
-the time complexity is (essentially) O(V), otherwise O(V log V).
-
-See also L</connected_components>, L</connected_component_by_index>,
-L</connected_component_by_vertex>, and L</same_connected_components>,
-and L</biconnectivity>.
-
-For directed graphs, see L</is_strongly_connected>
-and L</is_weakly_connected>.
-
-=item connected_components
-
- @cc = $g->connected_components()
-
-For an undirected graph, returns the vertices of the connected
-components of the graph as a list of anonymous arrays. The ordering
-of the anonymous arrays or the ordering of the vertices inside the
-anonymous arrays (the components) is undefined.
-
-For directed graphs, see L</strongly_connected_components>
-and L</weakly_connected_components>.
-
-=item connected_component_by_vertex
-
- $i = $g->connected_component_by_vertex($v)
-
-For an undirected graph, return an index identifying the connected
-component the vertex belongs to, the indexing starting from zero.
-
-For the inverse, see L</connected_component_by_index>.
-
-If the graph has been created with a true C<unionfind> parameter,
-the time complexity is (essentially) O(1), otherwise O(V log V).
-
-See also L</biconnectivity>.
-
-For directed graphs, see L</strongly_connected_component_by_vertex>
-and L</weakly_connected_component_by_vertex>.
-
-=item connected_component_by_index
-
- @v = $g->connected_component_by_index($i)
-
-For an undirected graph, return the vertices of the ith connected
-component, the indexing starting from zero. The order of vertices is
-undefined, while the order of the connected components is same as from
-connected_components().
-
-For the inverse, see L</connected_component_by_vertex>.
-
-For directed graphs, see L</strongly_connected_component_by_index>
-and L</weakly_connected_component_by_index>.
-
-=item same_connected_components
-
- $g->same_connected_components($u, $v, ...)
-
-For an undirected graph, return true if the vertices are in the same
-connected component.
-
-If the graph has been created with a true C<unionfind> parameter,
-the time complexity is (essentially) O(1), otherwise O(V log V).
-
-For directed graphs, see L</same_strongly_connected_components>
-and L</same_weakly_connected_components>.
-
-=item connected_graph
-
- $cg = $g->connected_graph
-
-For an undirected graph, return its connected graph.
-
-=item connectivity_clear_cache
-
- $g->connectivity_clear_cache
-
-See L</"Clearing cached results">.
-
-See L</"Connected Graphs and Their Components"> for further discussion.
-
-=item biconnectivity
-
- my ($ap, $bc, $br) = $g->biconnectivity
-
-For an undirected graph, return the various biconnectivity components
-of the graph: the articulation points (cut vertices), biconnected
-components, and bridges.
-
-Note: currently only handles connected graphs.
-
-=item is_biconnected
-
- $g->is_biconnected
-
-For an undirected graph, return true if the graph is biconnected
-(if it has no articulation points, also known as cut vertices).
-
-=item is_edge_connected
-
- $g->is_edge_connected
-
-For an undirected graph, return true if the graph is edge-connected
-(if it has no bridges).
-
-=item is_edge_separable
-
- $g->is_edge_separable
-
-For an undirected graph, return true if the graph is edge-separable
-(if it has bridges).
-
-=item articulation_points
-
-=item cut_vertices
-
- $g->articulation_points
-
-For an undirected graph, return the articulation points (cut vertices)
-of the graph as a list of vertices. The order is undefined.
-
-=item biconnected_components
-
- $g->biconnected_components
-
-For an undirected graph, return the biconnected components of the
-graph as a list of anonymous arrays of vertices in the components.
-The ordering of the anonymous arrays or the ordering of the vertices
-inside the anonymous arrays (the components) is undefined. Also note
-that one vertex can belong to more than one biconnected component.
-
-=item biconnected_component_by_vertex
-
- $i = $g->biconnected_component_by_index($v)
-
-For an undirected graph, return an index identifying the biconnected
-component the vertex belongs to, the indexing starting from zero.
-
-For the inverse, see L</connected_component_by_index>.
-
-For directed graphs, see L</strongly_connected_component_by_index>
-and L</weakly_connected_component_by_index>.
-
-=item biconnected_component_by_index
-
- @v = $g->biconnected_component_by_index($i)
-
-For an undirected graph, return the vertices in the ith biconnected
-component of the graph as an anonymous arrays of vertices in the
-component. The ordering of the vertices within a component is
-undefined. Also note that one vertex can belong to more than one
-biconnected component.
-
-=item same_biconnected_components
-
- $g->same_biconnected_components($u, $v, ...)
-
-For an undirected graph, return true if the vertices are in the same
-biconnected component.
-
-=item biconnected_graph
-
- $bcg = $g->biconnected_graph
-
-For an undirected graph, return its biconnected graph.
-
-See L</"Connected Graphs and Their Components"> for further discussion.
-
-=item bridges
-
- $g->bridges
-
-For an undirected graph, return the bridges of the graph as a list of
-anonymous arrays of vertices in the bridges. The order of bridges and
-the order of vertices in them is undefined.
-
-=item biconnectivity_clear_cache
-
- $g->biconnectivity_clear_cache
-
-See L</"Clearing cached results">.
-
-=item strongly_connected
-
-=item is_strongly_connected
-
- $g->is_strongly_connected
-
-For a directed graph, return true is the directed graph is strongly
-connected, false if not.
-
-See also L</is_weakly_connected>.
-
-For undirected graphs, see L</is_connected>, or L</is_biconnected>.
-
-=item strongly_connected_component_by_vertex
-
- $i = $g->strongly_connected_component_by_vertex($v)
-
-For a directed graph, return an index identifying the strongly
-connected component the vertex belongs to, the indexing starting from
-zero.
-
-For the inverse, see L</strongly_connected_component_by_index>.
-
-See also L</weakly_connected_component_by_vertex>.
-
-For undirected graphs, see L</connected_components> or
-L</biconnected_components>.
-
-=item strongly_connected_component_by_index
-
- @v = $g->strongly_connected_component_by_index($i)
-
-For a directed graph, return the vertices of the ith connected
-component, the indexing starting from zero. The order of vertices
-within a component is undefined, while the order of the connected
-components is the as from strongly_connected_components().
-
-For the inverse, see L</strongly_connected_component_by_vertex>.
-
-For undirected graphs, see L</weakly_connected_component_by_index>.
-
-=item same_strongly_connected_components
-
- $g->same_strongly_connected_components($u, $v, ...)
-
-For a directed graph, return true if the vertices are in the same
-strongly connected component.
-
-See also L</same_weakly_connected_components>.
-
-For undirected graphs, see L</same_connected_components> or
-L</same_biconnected_components>.
-
-=item strong_connectivity_clear_cache
-
- $g->strong_connectivity_clear_cache
-
-See L</"Clearing cached results">.
-
-=item weakly_connected
-
-=item is_weakly_connected
-
- $g->is_weakly_connected
-
-For a directed graph, return true is the directed graph is weakly
-connected, false if not.
-
-Weakly connected graph is also known as I<semiconnected> graph.
-
-See also L</is_strongly_connected>.
-
-For undirected graphs, see L</is_connected> or L</is_biconnected>.
-
-=item weakly_connected_components
-
- @wcc = $g->weakly_connected_components()
-
-For a directed graph, returns the vertices of the weakly connected
-components of the graph as a list of anonymous arrays. The ordering
-of the anonymous arrays or the ordering of the vertices inside the
-anonymous arrays (the components) is undefined.
-
-See also L</strongly_connected_components>.
-
-For undirected graphs, see L</connected_components> or
-L</biconnected_components>.
-
-=item weakly_connected_component_by_vertex
-
- $i = $g->weakly_connected_component_by_vertex($v)
-
-For a directed graph, return an index identifying the weakly connected
-component the vertex belongs to, the indexing starting from zero.
-
-For the inverse, see L</weakly_connected_component_by_index>.
-
-For undirected graphs, see L</connected_component_by_vertex>
-and L</biconnected_component_by_vertex>.
-
-=item weakly_connected_component_by_index
-
- @v = $g->weakly_connected_component_by_index($i)
-
-For a directed graph, return the vertices of the ith weakly connected
-component, the indexing starting zero. The order of vertices within
-a component is undefined, while the order of the weakly connected
-components is same as from weakly_connected_components().
-
-For the inverse, see L</weakly_connected_component_by_vertex>.
-
-For undirected graphs, see L<connected_component_by_index>
-and L<biconnected_component_by_index>.
-
-=item same_weakly_connected_components
-
- $g->same_weakly_connected_components($u, $v, ...)
-
-Return true if the vertices are in the same weakly connected component.
-
-=item weakly_connected_graph
-
- $wcg = $g->weakly_connected_graph
-
-For a directed graph, return its weakly connected graph.
-
-For undirected graphs, see L</connected_graph> and L</biconnected_graph>.
-
-=item strongly_connected_components
-
- my @scc = $g->strongly_connected_components;
-
-For a directed graph, return the strongly connected components as a
-list of anonymous arrays. The elements in the anonymous arrays are
-the vertices belonging to the strongly connected component; both the
-elements and the components are in no particular order.
-
-See also L</weakly_connected_components>.
-
-For undirected graphs, see L</connected_components>,
-or see L</biconnected_components>.
-
-=item strongly_connected_graph
-
- my $scg = $g->strongly_connected_graph;
-
-See L</"Connected Graphs and Their Components"> for further discussion.
-
-Strongly connected graphs are also known as I<kernel graphs>.
-
-See also L</weakly_connected_graph>.
-
-For undirected graphs, see L</connected_graph>, or L</biconnected_graph>.
-
-=item is_sink_vertex
-
- $g->is_sink_vertex($v)
-
-Return true if the vertex $v is a sink vertex, false if not. A sink
-vertex is defined as a vertex with predecessors but no successors:
-this definition means that isolated vertices are not sink vertices.
-If you want also isolated vertices, use is_successorless_vertex().
-
-=item is_source_vertex
-
- $g->is_source_vertex($v)
-
-Return true if the vertex $v is a source vertex, false if not. A source
-vertex is defined as a vertex with successors but no predecessors:
-the definition means that isolated vertices are not source vertices.
-If you want also isolated vertices, use is_predecessorless_vertex().
-
-=item is_successorless_vertex
-
- $g->is_successorless_vertex($v)
-
-Return true if the vertex $v has no succcessors (no edges
-leaving the vertex), false if it has.
-
-Isolated vertices will return true: if you do not want this,
-use is_sink_vertex().
-
-=item is_successorful_vertex
-
- $g->is_successorful_vertex($v)
-
-Return true if the vertex $v has successors, false if not.
-
-=item is_predecessorless_vertex
-
- $g->is_predecessorless_vertex($v)
-
-Return true if the vertex $v has no predecessors (no edges
-entering the vertex), false if it has.
-
-Isolated vertices will return true: if you do not want this,
-use is_source_vertex().
-
-=item is_predecessorful_vertex
-
- $g->is_predecessorful_vertex($v)
-
-Return true if the vertex $v has predecessors, false if not.
-
-=item is_isolated_vertex
-
- $g->is_isolated_vertex($v)
-
-Return true if the vertex $v is an isolated vertex: no successors
-and no predecessors.
-
-=item is_interior_vertex
-
- $g->is_interior_vertex($v)
-
-Return true if the vertex $v is an interior vertex: both successors
-and predecessors.
-
-=item is_exterior_vertex
-
- $g->is_exterior_vertex($v)
-
-Return true if the vertex $v is an exterior vertex: has either no
-successors or no predecessors, or neither.
-
-=item is_self_loop_vertex
-
- $g->is_self_loop_vertex($v)
-
-Return true if the vertex $v is a self loop vertex: has an edge
-from itself to itself.
-
-=item sink_vertices
-
- @v = $g->sink_vertices()
-
-Return the sink vertices of the graph.
-In scalar context return the number of sink vertices.
-See L</is_sink_vertex> for the definition of a sink vertex.
-
-=item source_vertices
-
- @v = $g->source_vertices()
-
-Return the source vertices of the graph.
-In scalar context return the number of source vertices.
-See L</is_source_vertex> for the definition of a source vertex.
-
-=item successorful_vertices
-
- @v = $g->successorful_vertices()
-
-Return the successorful vertices of the graph.
-In scalar context return the number of successorful vertices.
-
-=item successorless_vertices
-
- @v = $g->successorless_vertices()
-
-Return the successorless vertices of the graph.
-In scalar context return the number of successorless vertices.
-
-=item successors
-
- @s = $g->successors($v)
-
-Return the immediate successor vertices of the vertex.
-
-=item neighbors
-
-=item neighbours
-
-Return the neighbo(u)ring vertices. Also known as the I<adjacent vertices>.
-
-=item predecessorful_vertices
-
- @v = $g->predecessorful_vertices()
-
-Return the predecessorful vertices of the graph.
-In scalar context return the number of predecessorful vertices.
-
-=item predecessorless_vertices
-
- @v = $g->predecessorless_vertices()
-
-Return the predecessorless vertices of the graph.
-In scalar context return the number of predecessorless vertices.
-
-=item predecessors
-
- @s = $g->predecessors($v)
-
-Return the immediate predecessor vertices of the vertex.
-
-=item isolated_vertices
-
- @v = $g->isolated_vertices()
-
-Return the isolated vertices of the graph.
-In scalar context return the number of isolated vertices.
-See L</is_isolated_vertex> for the definition of an isolated vertex.
-
-=item interior_vertices
-
- @v = $g->interior_vertices()
-
-Return the interior vertices of the graph.
-In scalar context return the number of interior vertices.
-See L</is_interior_vertex> for the definition of an interior vertex.
-
-=item exterior_vertices
-
- @v = $g->exterior_vertices()
-
-Return the exterior vertices of the graph.
-In scalar context return the number of exterior vertices.
-See L</is_exterior_vertex> for the definition of an exterior vertex.
-
-=item self_loop_vertices
-
- @v = $g->self_loop_vertices()
-
-Return the self-loop vertices of the graph.
-In scalar context return the number of self-loop vertices.
-See L</is_self_loop_vertex> for the definition of a self-loop vertex.
-
-=back
-
-=head2 Connected Graphs and Their Components
-
-In this discussion I<connected graph> refers to any of
-I<connected graphs>, I<biconnected graphs>, and I<strongly
-connected graphs>.
-
-B<NOTE>: if the vertices of the original graph are Perl objects,
-(in other words, references, so you must be using C<refvertexed>)
-the vertices of the I<connected graph> are NOT by default usable
-as Perl objects because they are blessed into a package with
-a rather unusable name.
-
-By default, the vertex names of the I<connected graph> are formed from
-the names of the vertices of the original graph by (alphabetically
-sorting them and) concatenating their names with C<+>. The vertex
-attribute C<subvertices> is also used to store the list (as an array
-reference) of the original vertices. To change the 'supercomponent'
-vertex names and the whole logic of forming these supercomponents
-use the C<super_component>) option to the method calls:
-
- $g->connected_graph(super_component => sub { ... })
- $g->biconnected_graph(super_component => sub { ... })
- $g->strongly_connected_graph(super_component => sub { ... })
-
-The subroutine reference gets the 'subcomponents' (the vertices of the
-original graph) as arguments, and it is supposed to return the new
-supercomponent vertex, the "stringified" form of which is used as the
-vertex name.
-
-=head2 Degree
-
-A vertex has a degree based on the number of incoming and outgoing edges.
-This really makes sense only for directed graphs.
-
-=over 4
-
-=item degree
-
-=item vertex_degree
-
- $d = $g->degree($v)
- $d = $g->vertex_degree($v)
-
-For directed graphs: the in-degree minus the out-degree at the vertex.
-For undirected graphs: the number of edges at the vertex.
-
-=item in_degree
-
- $d = $g->in_degree($v)
-
-The number of incoming edges at the vertex.
-
-=item out_degree
-
- $o = $g->out_degree($v)
-
-The number of outgoing edges at the vertex.
-
-=item average_degree
-
- my $ad = $g->average_degree;
-
-Return the average degree taken over all vertices.
-
-=back
-
-Related methods are
-
-=over 4
-
-=item edges_at
-
- @e = $g->edges_at($v)
-
-The union of edges from and edges to at the vertex.
-
-=item edges_from
-
- @e = $g->edges_from($v)
-
-The edges leaving the vertex.
-
-=item edges_to
-
- @e = $g->edges_to($v)
-
-The edges entering the vertex.
-
-=back
-
-See also L</average_degree>.
-
-=head2 Counted Vertices
-
-I<Counted vertices> are vertices with more than one instance, normally
-adding vertices is idempotent. To enable counted vertices on a graph,
-give the C<countvertexed> parameter a true value
-
- use Graph;
- my $g = Graph->new(countvertexed => 1);
-
-To find out how many times the vertex has been added:
-
-=over 4
-
-=item get_vertex_count
-
- my $c = $g->get_vertex_count($v);
-
-Return the count of the vertex, or undef if the vertex does not exist.
-
-=back
-
-=head2 Multiedges, Multivertices, Multigraphs
-
-I<Multiedges> are edges with more than one "life", meaning that one
-has to delete them as many times as they have been added. Normally
-adding edges is idempotent (in other words, adding edges more than
-once makes no difference).
-
-There are two kinds or degrees of creating multiedges and multivertices.
-The two kinds are mutually exclusive.
-
-The weaker kind is called I<counted>, in which the edge or vertex has
-a count on it: add operations increase the count, and delete
-operations decrease the count, and once the count goes to zero, the
-edge or vertex is deleted. If there are attributes, they all are
-attached to the same vertex. You can think of this as the graph
-elements being I<refcounted>, or I<reference counted>, if that sounds
-more familiar.
-
-The stronger kind is called (true) I<multi>, in which the edge or vertex
-really has multiple separate identities, so that you can for example
-attach different attributes to different instances.
-
-To enable multiedges on a graph:
-
- use Graph;
- my $g0 = Graph->new(countedged => 1);
- my $g0 = Graph->new(multiedged => 1);
-
-Similarly for vertices
-
- use Graph;
- my $g1 = Graph->new(countvertexed => 1);
- my $g1 = Graph->new(multivertexed => 1);
-
-You can test for these by
-
-=over 4
-
-=item is_countedged
-
-=item countedged
-
- $g->is_countedged
- $g->countedged
-
-Return true if the graph is countedged.
-
-=item is_countvertexed
-
-=item countvertexed
-
- $g->is_countvertexed
- $g->countvertexed
-
-Return true if the graph is countvertexed.
-
-=item is_multiedged
-
-=item multiedged
-
- $g->is_multiedged
- $g->multiedged
-
-Return true if the graph is multiedged.
-
-=item is_multivertexed
-
-=item multivertexed
-
- $g->is_multivertexed
- $g->multivertexed
-
-Return true if the graph is multivertexed.
-
-=back
-
-A multiedged (either the weak kind or the strong kind) graph is
-a I<multigraph>, for which you can test with C<is_multi_graph()>.
-
-B<NOTE>: The various graph algorithms do not in general work well with
-multigraphs (they often assume I<simple graphs>, that is, no
-multiedges or loops), and no effort has been made to test the
-algorithms with multigraphs.
-
-vertices() and edges() will return the multiple elements: if you want
-just the unique elements, use
-
-=over 4
-
-=item unique_vertices
-
-=item unique_edges
-
- @uv = $g->unique_vertices; # unique
- @mv = $g->vertices; # possible multiples
- @ue = $g->unique_edges;
- @me = $g->edges;
-
-=back
-
-If you are using (the stronger kind of) multielements, you should use
-the I<by_id> variants:
-
-=over 4
-
-=item add_vertex_by_id
-
-=item has_vertex_by_id
-
-=item delete_vertex_by_id
-
-=item add_edge_by_id
-
-=item has_edge_by_id
-
-=item delete_edge_by_id
-
-=back
-
- $g->add_vertex_by_id($v, $id)
- $g->has_vertex_by_id($v, $id)
- $g->delete_vertex_by_id($v, $id)
-
- $g->add_edge_by_id($u, $v, $id)
- $g->has_edge_by_id($u, $v, $id)
- $g->delete_edge_by_id($u, $v, $id)
-
-When you delete the last vertex/edge in a multivertex/edge, the whole
-vertex/edge is deleted. You can use add_vertex()/add_edge() on
-a multivertex/multiedge graph, in which case an id is generated
-automatically. To find out which the generated id was, you need
-to use
-
-=over 4
-
-=item add_vertex_get_id
-
-=item add_edge_get_id
-
-=back
-
- $idv = $g->add_vertex_get_id($v)
- $ide = $g->add_edge_get_id($u, $v)
-
-To return all the ids of vertices/edges in a multivertex/multiedge, use
-
-=over 4
-
-=item get_multivertex_ids
-
-=item get_multiedge_ids
-
-=back
-
- $g->get_multivertex_ids($v)
- $g->get_multiedge_ids($u, $v)
-
-The ids are returned in random order.
-
-To find out how many times the edge has been added (this works for
-either kind of multiedges):
-
-=over 4
-
-=item get_edge_count
-
- my $c = $g->get_edge_count($u, $v);
-
-Return the count (the "countedness") of the edge, or undef if the
-edge does not exist.
-
-=back
-
-The following multi-entity utility functions exist, mirroring
-the non-multi vertices and edges:
-
-=over 4
-
-=item add_weighted_edge_by_id
-
-=item add_weighted_edges_by_id
-
-=item add_weighted_path_by_id
-
-=item add_weighted_vertex_by_id
-
-=item add_weighted_vertices_by_id
-
-=item delete_edge_weight_by_id
-
-=item delete_vertex_weight_by_id
-
-=item get_edge_weight_by_id
-
-=item get_vertex_weight_by_id
-
-=item has_edge_weight_by_id
-
-=item has_vertex_weight_by_id
-
-=item set_edge_weight_by_id
-
-=item set_vertex_weight_by_id
-
-=back
-
-=head2 Topological Sort
-
-=over 4
-
-=item topological_sort
-
-=item toposort
-
- my @ts = $g->topological_sort;
-
-Return the vertices of the graph sorted topologically. Note that
-there may be several possible topological orderings; one of them
-is returned.
-
-If the graph contains a cycle, a fatal error is thrown, you
-can either use C<eval> to trap that, or supply the C<empty_if_cyclic>
-argument with a true value
-
- my @ts = $g->topological_sort(empty_if_cyclic => 1);
-
-in which case an empty array is returned if the graph is cyclic.
-
-=back
-
-=head2 Minimum Spanning Trees (MST)
-
-Minimum Spanning Trees or MSTs are tree subgraphs derived from an
-undirected graph. MSTs "span the graph" (covering all the vertices)
-using as lightly weighted (hence the "minimum") edges as possible.
-
-=over 4
-
-=item MST_Kruskal
-
- $mstg = $g->MST_Kruskal;
-
-Returns the Kruskal MST of the graph.
-
-=item MST_Prim
-
- $mstg = $g->MST_Prim(%opt);
-
-Returns the Prim MST of the graph.
-
-You can choose the first vertex with $opt{ first_root }.
-
-=item MST_Dijkstra
-
-=item minimum_spanning_tree
-
- $mstg = $g->MST_Dijkstra;
- $mstg = $g->minimum_spanning_tree;
-
-Aliases for MST_Prim.
-
-=back
-
-=head2 Single-Source Shortest Paths (SSSP)
-
-Single-source shortest paths, also known as Shortest Path Trees
-(SPTs). For either a directed or an undirected graph, return a (tree)
-subgraph that from a single start vertex (the "single source") travels
-the shortest possible paths (the paths with the lightest weights) to
-all the other vertices. Note that the SSSP is neither reflexive (the
-shortest paths do not include the zero-length path from the source
-vertex to the source vertex) nor transitive (the shortest paths do not
-include transitive closure paths). If no weight is defined for an
-edge, 1 (one) is assumed.
-
-=over 4
-
-=item SPT_Dijkstra
-
- $sptg = $g->SPT_Dijkstra($root)
- $sptg = $g->SPT_Dijkstra(%opt)
-
-Return as a graph the the single-source shortest paths of the graph
-using Dijkstra's algorithm. The graph cannot contain negative edges
-(negative edges cause the algorithm to abort with an error message
-C<Graph::SPT_Dijkstra: edge ... is negative>).
-
-You can choose the first vertex of the result with either a single
-vertex argument or with $opt{ first_root }, otherwise a random vertex
-is chosen.
-
-B<NOTE>: note that all the vertices might not be reachable from the
-selected (explicit or random) start vertex.
-
-The start vertex is be available as the graph attribute
-C<SPT_Dijkstra_root>).
-
-The result weights of vertices can be retrieved from the result graph by
-
- my $w = $sptg->get_vertex_attribute($v, 'weight');
-
-The predecessor vertex of a vertex in the result graph
-can be retrieved by
-
- my $u = $sptg->get_vertex_attribute($v, 'p');
-
-("A successor vertex" cannot be retrieved as simply because a single
-vertex can have several successors. You can first find the
-C<neighbors()> vertices and then remove the predecessor vertex.)
-
-If you want to find the shortest path between two vertices,
-see L</SP_Dijkstra>.
-
-=item SSSP_Dijkstra
-
-=item single_source_shortest_paths
-
-Aliases for SPT_Dijkstra.
-
-=item SP_Dijkstra
-
- @path = $g->SP_Dijkstra($u, $v)
-
-Return the vertices in the shortest path in the graph $g between the
-two vertices $u, $v. If no path can be found, an empty list is returned.
-
-Uses SPT_Dijkstra().
-
-=item SPT_Dijkstra_clear_cache
-
- $g->SPT_Dijkstra_clear_cache
-
-See L</"Clearing cached results">.
-
-=item SPT_Bellman_Ford
-
- $sptg = $g->SPT_Bellman_Ford(%opt)
-
-Return as a graph the single-source shortest paths of the graph using
-Bellman-Ford's algorithm. The graph can contain negative edges but
-not negative cycles (negative cycles cause the algorithm to abort
-with an error message C<Graph::SPT_Bellman_Ford: negative cycle exists/>).
-
-You can choose the start vertex of the result with either a single
-vertex argument or with $opt{ first_root }, otherwise a random vertex
-is chosen.
-
-B<NOTE>: note that all the vertices might not be reachable from the
-selected (explicit or random) start vertex.
-
-The start vertex is be available as the graph attribute
-C<SPT_Bellman_Ford_root>).
-
-The result weights of vertices can be retrieved from the result graph by
-
- my $w = $sptg->get_vertex_attribute($v, 'weight');
-
-The predecessor vertex of a vertex in the result graph
-can be retrieved by
-
- my $u = $sptg->get_vertex_attribute($v, 'p');
-
-("A successor vertex" cannot be retrieved as simply because a single
-vertex can have several successors. You can first find the
-C<neighbors()> vertices and then remove the predecessor vertex.)
-
-If you want to find the shortes path between two vertices,
-see L</SP_Bellman_Ford>.
-
-=item SSSP_Bellman_Ford
-
-Alias for SPT_Bellman_Ford.
-
-=item SP_Bellman_Ford
-
- @path = $g->SP_Bellman_Ford($u, $v)
-
-Return the vertices in the shortest path in the graph $g between the
-two vertices $u, $v. If no path can be found, an empty list is returned.
-
-Uses SPT_Bellman_Ford().
-
-=item SPT_Bellman_Ford_clear_cache
-
- $g->SPT_Bellman_Ford_clear_cache
-
-See L</"Clearing cached results">.
-
-=back
-
-=head2 All-Pairs Shortest Paths (APSP)
-
-For either a directed or an undirected graph, return the APSP object
-describing all the possible paths between any two vertices of the
-graph. If no weight is defined for an edge, 1 (one) is assumed.
-
-=over 4
-
-=item APSP_Floyd_Warshall
-
-=item all_pairs_shortest_paths
-
- my $apsp = $g->APSP_Floyd_Warshall(...);
-
-Return the all-pairs shortest path object computed from the graph
-using Floyd-Warshall's algorithm. The length of a path between two
-vertices is the sum of weight attribute of the edges along the
-shortest path between the two vertices. If no weight attribute name
-is specified explicitly
-
- $g->APSP_Floyd_Warshall(attribute_name => 'height');
-
-the attribute C<weight> is assumed.
-
-B<If an edge has no defined weight attribute, the value of one is
-assumed when getting the attribute.>
-
-Once computed, you can query the APSP object with
-
-=over 8
-
-=item path_length
-
- my $l = $apsp->path_length($u, $v);
-
-Return the length of the shortest path between the two vertices.
-
-=item path_vertices
-
- my @v = $apsp->path_vertices($u, $v);
-
-Return the list of vertices along the shortest path.
-
-=item path_predecessor
-
- my $u = $apsp->path_predecessor($v);
-
-Returns the predecessor of vertex $v in the all-pairs shortest paths.
-
-=back
-
-=over 8
-
-=item average_path_length
-
- my $apl = $g->average_path_length; # All vertex pairs.
-
- my $apl = $g->average_path_length($u); # From $u.
- my $apl = $g->average_path_length($u, undef); # From $u.
-
- my $apl = $g->average_path_length($u, $v); # From $u to $v.
-
- my $apl = $g->average_path_length(undef, $v); # To $v.
-
-Return the average (shortest) path length over all the vertex pairs of
-the graph, from a vertex, between two vertices, and to a vertex.
-
-=item longest_path
-
- my @lp = $g->longest_path;
- my $lp = $g->longest_path;
-
-In scalar context return the I<longest shortest> path length over all
-the vertex pairs of the graph. In list context return the vertices
-along a I<longest shortest> path. Note that there might be more than
-one such path; this interfaces return a random one of them.
-
-=item diameter
-
-=item graph_diameter
-
- my $gd = $g->diameter;
-
-The longest path over all the vertex pairs is known as the
-I<graph diameter>.
-
-=item shortest_path
-
- my @sp = $g->shortest_path;
- my $sp = $g->shortest_path;
-
-In scalar context return the shortest length over all the vertex pairs
-of the graph. In list context return the vertices along a shortest
-path. Note that there might be more than one such path; this
-interface returns a random one of them.
-
-=item radius
-
- my $gr = $g->radius;
-
-The I<shortest longest> path over all the vertex pairs is known as the
-I<graph radius>. See also L</diameter>.
-
-=item center_vertices
-
-=item centre_vertices
-
- my @c = $g->center_vertices;
- my @c = $g->center_vertices($delta);
-
-The I<graph center> is the set of vertices for which the I<vertex
-eccentricity> is equal to the I<graph radius>. The vertices are
-returned in random order. By specifying a delta value you can widen
-the criterion from strict equality (handy for non-integer edge weights).
-
-=item vertex_eccentricity
-
- my $ve = $g->vertex_eccentricity($v);
-
-The longest path to a vertex is known as the I<vertex eccentricity>.
-If the graph is unconnected, returns Inf.
-
-=back
-
-You can walk through the matrix of the shortest paths by using
-
-=over 4
-
-=item for_shortest_paths
-
- $n = $g->for_shortest_paths($callback)
-
-The number of shortest paths is returned (this should be equal to V*V).
-The $callback is a sub reference that receives four arguments:
-the transitive closure object from Graph::TransitiveClosure, the two
-vertices, and the index to the current shortest paths (0..V*V-1).
-
-=back
-
-=back
-
-=head2 Clearing cached results
-
-For many graph algorithms there are several different but equally valid
-results. (Pseudo)Randomness is used internally by the Graph module to
-for example pick a random starting vertex, and to select random edges
-from a vertex.
-
-For efficiency the computed result is often cached to avoid
-recomputing the potentially expensive operation, and this also gives
-additional determinism (once a correct result has been computed, the
-same result will always be given).
-
-However, sometimes the exact opposite is desireable, and the possible
-alternative results are wanted (within the limits of the pseudorandomness:
-not all the possible solutions are guaranteed to be returned, usually only
-a subset is retuned). To undo the caching, the following methods are
-available:
-
-=over 4
-
-=item *
-
-connectivity_clear_cache
-
-Affects L</connected_components>, L</connected_component_by_vertex>,
-L</connected_component_by_index>, L</same_connected_components>,
-L</connected_graph>, L</is_connected>, L</is_weakly_connected>,
-L</weakly_connected_components>, L</weakly_connected_component_by_vertex>,
-L</weakly_connected_component_by_index>, L</same_weakly_connected_components>,
-L</weakly_connected_graph>.
-
-=item *
-
-biconnectivity_clear_cache
-
-Affects L</biconnected_components>,
-L</biconnected_component_by_vertex>,
-L</biconnected_component_by_index>, L</is_edge_connected>,
-L</is_edge_separable>, L</articulation_points>, L</cut_vertices>,
-L</is_biconnected>, L</biconnected_graph>,
-L</same_biconnected_components>, L</bridges>.
-
-=item *
-
-strong_connectivity_clear_cache
-
-Affects L</strongly_connected_components>,
-L</strongly_connected_component_by_vertex>,
-L</strongly_connected_component_by_index>,
-L</same_strongly_connected_components>, L</is_strongly_connected>,
-L</strongly_connected>, L</strongly_connected_graph>.
-
-=item *
-
-SPT_Dijkstra_clear_cache
-
-Affects L</SPT_Dijkstra>, L</SSSP_Dijkstra>, L</single_source_shortest_paths>,
-L</SP_Dijkstra>.
-
-=item *
-
-SPT_Bellman_Ford_clear_cache
-
-Affects L</SPT_Bellman_Ford>, L</SSSP_Bellman_Ford>, L</SP_Bellman_Ford>.
-
-=back
-
-Note that any such computed and cached results are of course always
-automatically discarded whenever the graph is modified.
-
-=head2 Random
-
-You can either ask for random elements of existing graphs or create
-random graphs.
-
-=over 4
-
-=item random_vertex
-
- my $v = $g->random_vertex;
-
-Return a random vertex of the graph, or undef if there are no vertices.
-
-=item random_edge
-
- my $e = $g->random_edge;
-
-Return a random edge of the graph as an array reference having the
-vertices as elements, or undef if there are no edges.
-
-=item random_successor
-
- my $v = $g->random_successor($v);
-
-Return a random successor of the vertex in the graph, or undef if there
-are no successors.
-
-=item random_predecessor
-
- my $u = $g->random_predecessor($v);
-
-Return a random predecessor of the vertex in the graph, or undef if there
-are no predecessors.
-
-=item random_graph
-
- my $g = Graph->random_graph(%opt);
-
-Construct a random graph. The I<%opt> B<must> contain the C<vertices>
-argument
-
- vertices => vertices_def
-
-where the I<vertices_def> is one of
-
-=over 8
-
-=item *
-
-an array reference where the elements of the array reference are the
-vertices
-
-=item *
-
-a number N in which case the vertices will be integers 0..N-1
-
-=back
-
-=back
-
-The %opt may have either of the argument C<edges> or the argument
-C<edges_fill>. Both are used to define how many random edges to
-add to the graph; C<edges> is an absolute number, while C<edges_fill>
-is a relative number (relative to the number of edges in a complete
-graph, C). The number of edges can be larger than C, but only if the
-graph is countedged. The random edges will not include self-loops.
-If neither C<edges> nor C<edges_fill> is specified, an C<edges_fill>
-of 0.5 is assumed.
-
-If you want repeatable randomness (what is an oxymoron?)
-you can use the C<random_seed> option:
-
- $g = Graph->random_graph(vertices => 10, random_seed => 1234);
-
-As this uses the standard Perl srand(), the usual caveat applies:
-use it sparingly, and consider instead using a single srand() call
-at the top level of your application.
-
-The default random distribution of edges is flat, that is, any pair of
-vertices is equally likely to appear. To define your own distribution,
-use the C<random_edge> option:
-
- $g = Graph->random_graph(vertices => 10, random_edge => \&d);
-
-where C<d> is a code reference receiving I<($g, $u, $v, $p)> as
-parameters, where the I<$g> is the random graph, I<$u> and I<$v> are
-the vertices, and the I<$p> is the probability ([0,1]) for a flat
-distribution. It must return a probability ([0,1]) that the vertices
-I<$u> and I<$v> have an edge between them. Note that returning one
-for a particular pair of vertices doesn't guarantee that the edge will
-be present in the resulting graph because the required number of edges
-might be reached before that particular pair is tested for the
-possibility of an edge. Be very careful to adjust also C<edges>
-or C<edges_fill> so that there is a possibility of the filling process
-terminating.
-
-=head2 Attributes
-
-You can attach free-form attributes (key-value pairs, in effect a full
-Perl hash) to each vertex, edge, and the graph itself.
-
-Note that attaching attributes does slow down some other operations
-on the graph by a factor of three to ten. For example adding edge
-attributes does slow down anything that walks through all the edges.
-
-For vertex attributes:
-
-=over 4
-
-=item set_vertex_attribute
-
- $g->set_vertex_attribute($v, $name, $value)
-
-Set the named vertex attribute.
-
-If the vertex does not exist, the set_...() will create it, and the
-other vertex attribute methods will return false or empty.
-
-B<NOTE: any attributes beginning with an underscore/underline (_)
-are reserved for the internal use of the Graph module.>
-
-=item get_vertex_attribute
-
- $value = $g->get_vertex_attribute($v, $name)
-
-Return the named vertex attribute.
-
-=item has_vertex_attribute
-
- $g->has_vertex_attribute($v, $name)
-
-Return true if the vertex has an attribute, false if not.
-
-=item delete_vertex_attribute
-
- $g->delete_vertex_attribute($v, $name)
-
-Delete the named vertex attribute.
-
-=item set_vertex_attributes
-
- $g->set_vertex_attributes($v, $attr)
-
-Set all the attributes of the vertex from the anonymous hash $attr.
-
-B<NOTE>: any attributes beginning with an underscore (C<_>) are
-reserved for the internal use of the Graph module.
-
-=item get_vertex_attributes
-
- $attr = $g->get_vertex_attributes($v)
-
-Return all the attributes of the vertex as an anonymous hash.
-
-=item get_vertex_attribute_names
-
- @name = $g->get_vertex_attribute_names($v)
-
-Return the names of vertex attributes.
-
-=item get_vertex_attribute_values
-
- @value = $g->get_vertex_attribute_values($v)
-
-Return the values of vertex attributes.
-
-=item has_vertex_attributes
-
- $g->has_vertex_attributes($v)
-
-Return true if the vertex has any attributes, false if not.
-
-=item delete_vertex_attributes
-
- $g->delete_vertex_attributes($v)
-
-Delete all the attributes of the named vertex.
-
-=back
-
-If you are using multivertices, use the I<by_id> variants:
-
-=over 4
-
-=item set_vertex_attribute_by_id
-
-=item get_vertex_attribute_by_id
-
-=item has_vertex_attribute_by_id
-
-=item delete_vertex_attribute_by_id
-
-=item set_vertex_attributes_by_id
-
-=item get_vertex_attributes_by_id
-
-=item get_vertex_attribute_names_by_id
-
-=item get_vertex_attribute_values_by_id
-
-=item has_vertex_attributes_by_id
-
-=item delete_vertex_attributes_by_id
-
- $g->set_vertex_attribute_by_id($v, $id, $name, $value)
- $g->get_vertex_attribute_by_id($v, $id, $name)
- $g->has_vertex_attribute_by_id($v, $id, $name)
- $g->delete_vertex_attribute_by_id($v, $id, $name)
- $g->set_vertex_attributes_by_id($v, $id, $attr)
- $g->get_vertex_attributes_by_id($v, $id)
- $g->get_vertex_attribute_values_by_id($v, $id)
- $g->get_vertex_attribute_names_by_id($v, $id)
- $g->has_vertex_attributes_by_id($v, $id)
- $g->delete_vertex_attributes_by_id($v, $id)
-
-=back
-
-For edge attributes:
-
-=over 4
-
-=item set_edge_attribute
-
- $g->set_edge_attribute($u, $v, $name, $value)
-
-Set the named edge attribute.
-
-If the edge does not exist, the set_...() will create it, and the other
-edge attribute methods will return false or empty.
-
-B<NOTE>: any attributes beginning with an underscore (C<_>) are
-reserved for the internal use of the Graph module.
-
-=item get_edge_attribute
-
- $value = $g->get_edge_attribute($u, $v, $name)
-
-Return the named edge attribute.
-
-=item has_edge_attribute
-
- $g->has_edge_attribute($u, $v, $name)
-
-Return true if the edge has an attribute, false if not.
-
-=item delete_edge_attribute
-
- $g->delete_edge_attribute($u, $v, $name)
-
-Delete the named edge attribute.
-
-=item set_edge_attributes
-
- $g->set_edge_attributes($u, $v, $attr)
-
-Set all the attributes of the edge from the anonymous hash $attr.
-
-B<NOTE>: any attributes beginning with an underscore (C<_>) are
-reserved for the internal use of the Graph module.
-
-=item get_edge_attributes
-
- $attr = $g->get_edge_attributes($u, $v)
-
-Return all the attributes of the edge as an anonymous hash.
-
-=item get_edge_attribute_names
-
- @name = $g->get_edge_attribute_names($u, $v)
-
-Return the names of edge attributes.
-
-=item get_edge_attribute_values
-
- @value = $g->get_edge_attribute_values($u, $v)
-
-Return the values of edge attributes.
-
-=item has_edge_attributes
-
- $g->has_edge_attributes($u, $v)
-
-Return true if the edge has any attributes, false if not.
-
-=item delete_edge_attributes
-
- $g->delete_edge_attributes($u, $v)
-
-Delete all the attributes of the named edge.
-
-=back
-
-If you are using multiedges, use the I<by_id> variants:
-
-=over 4
-
-=item set_edge_attribute_by_id
-
-=item get_edge_attribute_by_id
-
-=item has_edge_attribute_by_id
-
-=item delete_edge_attribute_by_id
-
-=item set_edge_attributes_by_id
-
-=item get_edge_attributes_by_id
-
-=item get_edge_attribute_names_by_id
-
-=item get_edge_attribute_values_by_id
-
-=item has_edge_attributes_by_id
-
-=item delete_edge_attributes_by_id
-
- $g->set_edge_attribute_by_id($u, $v, $id, $name, $value)
- $g->get_edge_attribute_by_id($u, $v, $id, $name)
- $g->has_edge_attribute_by_id($u, $v, $id, $name)
- $g->delete_edge_attribute_by_id($u, $v, $id, $name)
- $g->set_edge_attributes_by_id($u, $v, $id, $attr)
- $g->get_edge_attributes_by_id($u, $v, $id)
- $g->get_edge_attribute_values_by_id($u, $v, $id)
- $g->get_edge_attribute_names_by_id($u, $v, $id)
- $g->has_edge_attributes_by_id($u, $v, $id)
- $g->delete_edge_attributes_by_id($u, $v, $id)
-
-=back
-
-For graph attributes:
-
-=over 4
-
-=item set_graph_attribute
-
- $g->set_graph_attribute($name, $value)
-
-Set the named graph attribute.
-
-B<NOTE>: any attributes beginning with an underscore (C<_>) are
-reserved for the internal use of the Graph module.
-
-=item get_graph_attribute
-
- $value = $g->get_graph_attribute($name)
-
-Return the named graph attribute.
-
-=item has_graph_attribute
-
- $g->has_graph_attribute($name)
-
-Return true if the graph has an attribute, false if not.
-
-=item delete_graph_attribute
-
- $g->delete_graph_attribute($name)
-
-Delete the named graph attribute.
-
-=item set_graph_attributes
-
- $g->get_graph_attributes($attr)
-
-Set all the attributes of the graph from the anonymous hash $attr.
-
-B<NOTE>: any attributes beginning with an underscore (C<_>) are
-reserved for the internal use of the Graph module.
-
-=item get_graph_attributes
-
- $attr = $g->get_graph_attributes()
-
-Return all the attributes of the graph as an anonymous hash.
-
-=item get_graph_attribute_names
-
- @name = $g->get_graph_attribute_names()
-
-Return the names of graph attributes.
-
-=item get_graph_attribute_values
-
- @value = $g->get_graph_attribute_values()
-
-Return the values of graph attributes.
-
-=item has_graph_attributes
-
- $g->has_graph_attributes()
-
-Return true if the graph has any attributes, false if not.
-
-=item delete_graph_attributes
-
- $g->delete_graph_attributes()
-
-Delete all the attributes of the named graph.
-
-=back
-
-=head2 Weighted
-
-As convenient shortcuts the following methods add, query, and
-manipulate the attribute C<weight> with the specified value to the
-respective Graph elements.
-
-=over 4
-
-=item add_weighted_edge
-
- $g->add_weighted_edge($u, $v, $weight)
-
-=item add_weighted_edges
-
- $g->add_weighted_edges($u1, $v1, $weight1, ...)
-
-=item add_weighted_path
-
- $g->add_weighted_path($v1, $weight1, $v2, $weight2, $v3, ...)
-
-=item add_weighted_vertex
-
- $g->add_weighted_vertex($v, $weight)
-
-=item add_weighted_vertices
-
- $g->add_weighted_vertices($v1, $weight1, $v2, $weight2, ...)
-
-=item delete_edge_weight
-
- $g->delete_edge_weight($u, $v)
-
-=item delete_vertex_weight
-
- $g->delete_vertex_weight($v)
-
-=item get_edge_weight
-
- $g->get_edge_weight($u, $v)
-
-=item get_vertex_weight
-
- $g->get_vertex_weight($v)
-
-=item has_edge_weight
-
- $g->has_edge_weight($u, $v)
-
-=item has_vertex_weight
-
- $g->has_vertex_weight($v)
-
-=item set_edge_weight
-
- $g->set_edge_weight($u, $v, $weight)
-
-=item set_vertex_weight
-
- $g->set_vertex_weight($v, $weight)
-
-=back
-
-=head2 Isomorphism
-
-Two graphs being I<isomorphic> means that they are structurally the
-same graph, the difference being that the vertices might have been
-I<renamed> or I<substituted>. For example in the below example $g0
-and $g1 are isomorphic: the vertices C<b c d> have been renamed as
-C<z x y>.
-
- $g0 = Graph->new;
- $g0->add_edges(qw(a b a c c d));
- $g1 = Graph->new;
- $g1->add_edges(qw(a x x y a z));
-
-In the general case determining isomorphism is I<NP-hard>, in other
-words, really hard (time-consuming), no other ways of solving the problem
-are known than brute force check of of all the possibilities (with possible
-optimization tricks, of course, but brute force still rules at the end of
-the day).
-
-A B<very rough guess> at whether two graphs B<could> be isomorphic
-is possible via the method
-
-=over 4
-
-=item could_be_isomorphic
-
- $g0->could_be_isomorphic($g1)
-
-=back
-
-If the graphs do not have the same number of vertices and edges, false
-is returned. If the distribution of I<in-degrees> and I<out-degrees>
-at the vertices of the graphs does not match, false is returned.
-Otherwise, true is returned.
-
-What is actually returned is the maximum number of possible isomorphic
-graphs between the two graphs, after the above sanity checks have been
-conducted. It is basically the product of the factorials of the
-absolute values of in-degrees and out-degree pairs at each vertex,
-with the isolated vertices ignored (since they could be reshuffled and
-renamed arbitrarily). Note that for large graphs the product of these
-factorials can overflow the maximum presentable number (the floating
-point number) in your computer (in Perl) and you might get for example
-I<Infinity> as the result.
-
-=head2 Miscellaneous
-
-The "expect" methods can be used to test a graph and croak if the
-graph is not as expected.
-
-=over 4
-
-=item expect_acyclic
-
-=item expect_dag
-
-=item expect_directed
-
-=item expect_multiedged
-
-=item expect_multivertexed
-
-=item expect_non_multiedged
-
-=item expect_non_multivertexed
-
-=item expect_undirected
-
-=back
-
-In many algorithms it is useful to have a value representing the
-infinity. The Graph provides (and itself uses):
-
-=over 4
-
-=item Infinity
-
-(Not exported, use Graph::Infinity explicitly)
-
-=back
-
-=head2 Size Requirements
-
-A graph takes up at least 1172 bytes of memory.
-
-A vertex takes up at least 100 bytes of memory.
-
-An edge takes up at least 400 bytes of memory.
-
-(A Perl scalar value takes 16 bytes, or 12 bytes if it's a reference.)
-
-These size approximations are B<very> approximate and optimistic
-(they are based on total_size() of Devel::Size). In real life many
-factors affect these numbers, for example how Perl is configured.
-The numbers are for a 32-bit platform and for Perl 5.8.8.
-
-Roughly, the above numbers mean that in a megabyte of memory you can
-fit for example a graph of about 1000 vertices and about 2500 edges.
-
-=head2 Hyperedges, hypervertices, hypergraphs
-
-B<BEWARE>: this is a rather thinly tested feature, and the theory
-is even less so. Do not expect this to stay as it is (or at all)
-in future releases.
-
-B<NOTE>: most usual graph algorithms (and basic concepts) break
-horribly (or at least will look funny) with these hyperthingies.
-Caveat emptor.
-
-Hyperedges are edges that connect a number of vertices different
-from the usual two.
-
-Hypervertices are vertices that consist of a number of vertices
-different from the usual one.
-
-Note that for hypervertices there is an asymmetry: when adding
-hypervertices, the single vertices are also implicitly added.
-
-Hypergraphs are graphs with hyperedges.
-
-To enable hyperness when constructing Graphs use the C<hyperedged>
-and C<hypervertexed> attributes:
-
- my $h = Graph->new(hyperedged => 1, hypervertexed => 1);
-
-To add hypervertexes, either explicitly use more than one vertex (or,
-indeed, I<no> vertices) when using add_vertex()
-
- $h->add_vertex("a", "b")
- $h->add_vertex()
-
-or implicitly with array references when using add_edge()
-
- $h->add_edge(["a", "b"], "c")
- $h->add_edge()
-
-Testing for existence and deletion of hypervertices and hyperedges
-works similarly.
-
-To test for hyperness of a graph use the
-
-=over 4
-
-=item is_hypervertexed
-
-=item hypervertexed
-
- $g->is_hypervertexed
- $g->hypervertexed
-
-=item is_hyperedged
-
-=item hyperedged
-
- $g->is_hyperedged
- $g->hyperedged
-
-=back
-
-Since hypervertices consist of more than one vertex:
-
-=over 4
-
-=item vertices_at
-
- $g->vertices_at($v)
-
-=back
-
-Return the vertices at the vertex. This may return just the vertex
-or also other vertices.
-
-To go with the concept of undirected in normal (non-hyper) graphs,
-there is a similar concept of omnidirected I<(this is my own coinage,
-"all-directions")> for hypergraphs, and you can naturally test for it by
-
-=over 4
-
-=item is_omnidirected
-
-=item omnidirected
-
-=item is_omniedged
-
-=item omniedged
-
- $g->is_omniedged
-
- $g->omniedged
-
- $g->is_omnidirected
-
- $g->omnidirected
-
-Return true if the graph is omnidirected (edges have no direction),
-false if not.
-
-=back
-
-You may be wondering why on earth did I make up this new concept, why
-didn't the "undirected" work for me? Well, because of this:
-
- $g = Graph->new(hypervertexed => 1, omnivertexed => 1);
-
-That's right, vertices can be omni, too - and that is indeed the
-default. You can turn it off and then $g->add_vertex(qw(a b)) no
-more means adding also the (hyper)vertex qw(b a). In other words,
-the "directivity" is orthogonal to (or independent of) the number of
-vertices in the vertex/edge.
-
-=over 4
-
-=item is_omnivertexed
-
-=item omnivertexed
-
-=back
-
-Another oddity that fell out of the implementation is the uniqueness
-attribute, that comes naturally in C<uniqedged> and C<uniqvertexed>
-flavours. It does what it sounds like, to unique or not the vertices
-participating in edges and vertices (is the hypervertex qw(a b a) the
-same as the hypervertex qw(a b), for example). Without too much
-explanation:
-
-=over 4
-
-=item is_uniqedged
-
-=item uniqedged
-
-=item is_uniqvertexed
-
-=item uniqvertexed
-
-=back
-
-=head2 Backward compatibility with Graph 0.2
-
-The Graph 0.2 (and 0.2xxxx) had the following features
-
-=over 4
-
-=item *
-
-vertices() always sorted the vertex list, which most of the time is
-unnecessary and wastes CPU.
-
-=item *
-
-edges() returned a flat list where the begin and end vertices of the
-edges were intermingled: every even index had an edge begin vertex,
-and every odd index had an edge end vertex. This had the unfortunate
-consequence of C<scalar(@e = edges)> being twice the number of edges,
-and complicating any algorithm walking through the edges.
-
-=item *
-
-The vertex list returned by edges() was sorted, the primary key being
-the edge begin vertices, and the secondary key being the edge end vertices.
-
-=item *
-
-The attribute API was oddly position dependent and dependent
-on the number of arguments. Use ..._graph_attribute(),
-..._vertex_attribute(), ..._edge_attribute() instead.
-
-=back
-
-B<In future releases of Graph (any release after 0.50) the 0.2xxxx
-compatibility will be removed. Upgrade your code now.>
-
-If you want to continue using these (mis)features you can use the
-C<compat02> flag when creating a graph:
-
- my $g = Graph->new(compat02 => 1);
-
-This will change the vertices() and edges() appropriately. This,
-however, is not recommended, since it complicates all the code using
-vertices() and edges(). Instead it is recommended that the
-vertices02() and edges02() methods are used. The corresponding new
-style (unsorted, and edges() returning a list of references) methods
-are called vertices05() and edges05().
-
-To test whether a graph has the compatibility turned on
-
-=over 4
-
-=item is_compat02
-
-=item compat02
-
- $g->is_compat02
- $g->compat02
-
-=back
-
-The following are not backward compatibility methods, strictly
-speaking, because they did not exist before.
-
-=over 4
-
-=item edges02
-
-Return the edges as a flat list of vertices, elements at even indices
-being the start vertices and elements at odd indices being the end
-vertices.
-
-=item edges05
-
-Return the edges as a list of array references, each element
-containing the vertices of each edge. (This is not a backward
-compatibility interface as such since it did not exist before.)
-
-=item vertices02
-
-Return the vertices in sorted order.
-
-=item vertices05
-
-Return the vertices in random order.
-
-=back
-
-For the attributes the recommended way is to use the new API.
-
-Do not expect new methods to work for compat02 graphs.
-
-The following compatibility methods exist:
-
-=over 4
-
-=item has_attribute
-
-=item has_attributes
-
-=item get_attribute
-
-=item get_attributes
-
-=item set_attribute
-
-=item set_attributes
-
-=item delete_attribute
-
-=item delete_attributes
-
-Do not use the above, use the new attribute interfaces instead.
-
-=item vertices_unsorted
-
-Alias for vertices() (or rather, vertices05()) since the vertices()
-now always returns the vertices in an unsorted order. You can also
-use the unsorted_vertices import, but only with a true value (false
-values will cause an error).
-
-=item density_limits
-
- my ($sparse, $dense, $complete) = $g->density_limits;
-
-Return the "density limits" used to classify graphs as "sparse" or "dense".
-The first limit is C/4 and the second limit is 3C/4, where C is the number
-of edges in a complete graph (the last "limit").
-
-=item density
-
- my $density = $g->density;
-
-Return the density of the graph, the ratio of the number of edges to the
-number of edges in a complete graph.
-
-=item vertex
-
- my $v = $g->vertex($v);
-
-Return the vertex if the graph has the vertex, undef otherwise.
-
-=item out_edges
-
-=item in_edges
-
-=item edges($v)
-
-This is now called edges_at($v).
-
-=back
-
-=head2 DIAGNOSTICS
-
-=over 4
-
-=item *
-
-Graph::...Map...: arguments X expected Y ...
-
-If you see these (more user-friendly error messages should have been
-triggered above and before these) please report any such occurrences,
-but in general you should be happy to see these since it means that an
-attempt to call something with a wrong number of arguments was caught
-in time.
-
-=item *
-
-Graph::add_edge: graph is not hyperedged ...
-
-Maybe you used add_weighted_edge() with only the two vertex arguments.
-
-=item *
-
-Not an ARRAY reference at lib/Graph.pm ...
-
-One possibility is that you have code based on Graph 0.2xxxx that
-assumes Graphs being blessed hash references, possibly also assuming
-that certain hash keys are available to use for your own purposes.
-In Graph 0.50 none of this is true. Please do not expect any
-particular internal implementation of Graphs. Use inheritance
-and graph/vertex/edge attributes instead.
-
-Another possibility is that you meant to have objects (blessed
-references) as graph vertices, but forgot to use C<refvertexed>
-(see L</refvertexed>) when creating the graph.
-
-=back
-
-=head2 POSSIBLE FUTURES
-
-A possible future direction is a new graph module written for speed:
-this may very possibly mean breaking or limiting some of the APIs or
-behaviour as compared with this release of the module.
-
-What definitely won't happen in future releases is carrying over
-the Graph 0.2xxxx backward compatibility API.
-
-=head1 ACKNOWLEDGEMENTS
-
-All bad terminology, bugs, and inefficiencies are naturally mine, all
-mine, and not the fault of the below.
-
-Thanks to Nathan Goodman and Andras Salamon for bravely betatesting my
-pre-0.50 code. If they missed something, that was only because of my
-fiendish code.
-
-The following literature for algorithms and some test cases:
-
-=over 4
-
-=item *
-
-Algorithms in C, Third Edition, Part 5, Graph Algorithms, Robert Sedgewick, Addison Wesley
-
-=item *
-
-Introduction to Algorithms, First Edition, Cormen-Leiserson-Rivest, McGraw Hill
-
-=item *
-
-Graphs, Networks and Algorithms, Dieter Jungnickel, Springer
-
-=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
diff --git a/perllib/Graph/AdjacencyMap.pm b/perllib/Graph/AdjacencyMap.pm
deleted file mode 100644
index d2245da..0000000
--- a/perllib/Graph/AdjacencyMap.pm
+++ /dev/null
@@ -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
diff --git a/perllib/Graph/AdjacencyMap/Heavy.pm b/perllib/Graph/AdjacencyMap/Heavy.pm
deleted file mode 100644
index 262bd4f..0000000
--- a/perllib/Graph/AdjacencyMap/Heavy.pm
+++ /dev/null
@@ -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__
diff --git a/perllib/Graph/AdjacencyMap/Light.pm b/perllib/Graph/AdjacencyMap/Light.pm
deleted file mode 100644
index bedaf65..0000000
--- a/perllib/Graph/AdjacencyMap/Light.pm
+++ /dev/null
@@ -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;
diff --git a/perllib/Graph/AdjacencyMap/Vertex.pm b/perllib/Graph/AdjacencyMap/Vertex.pm
deleted file mode 100644
index 72d8142..0000000
--- a/perllib/Graph/AdjacencyMap/Vertex.pm
+++ /dev/null
@@ -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
diff --git a/perllib/Graph/AdjacencyMatrix.pm b/perllib/Graph/AdjacencyMatrix.pm
deleted file mode 100644
index 6c648fe..0000000
--- a/perllib/Graph/AdjacencyMatrix.pm
+++ /dev/null
@@ -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
diff --git a/perllib/Graph/Attribute.pm b/perllib/Graph/Attribute.pm
deleted file mode 100644
index 54fa29a..0000000
--- a/perllib/Graph/Attribute.pm
+++ /dev/null
@@ -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;
diff --git a/perllib/Graph/BitMatrix.pm b/perllib/Graph/BitMatrix.pm
deleted file mode 100644
index de91376..0000000
--- a/perllib/Graph/BitMatrix.pm
+++ /dev/null
@@ -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
diff --git a/perllib/Graph/Directed.pm b/perllib/Graph/Directed.pm
deleted file mode 100644
index 9c3fc86..0000000
--- a/perllib/Graph/Directed.pm
+++ /dev/null
@@ -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;
diff --git a/perllib/Graph/MSTHeapElem.pm b/perllib/Graph/MSTHeapElem.pm
deleted file mode 100644
index 32bc001..0000000
--- a/perllib/Graph/MSTHeapElem.pm
+++ /dev/null
@@ -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;
diff --git a/perllib/Graph/Matrix.pm b/perllib/Graph/Matrix.pm
deleted file mode 100644
index d3b9d40..0000000
--- a/perllib/Graph/Matrix.pm
+++ /dev/null
@@ -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
diff --git a/perllib/Graph/SPTHeapElem.pm b/perllib/Graph/SPTHeapElem.pm
deleted file mode 100644
index 0455531..0000000
--- a/perllib/Graph/SPTHeapElem.pm
+++ /dev/null
@@ -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;
diff --git a/perllib/Graph/TransitiveClosure.pm b/perllib/Graph/TransitiveClosure.pm
deleted file mode 100644
index fd5a0a8..0000000
--- a/perllib/Graph/TransitiveClosure.pm
+++ /dev/null
@@ -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
diff --git a/perllib/Graph/TransitiveClosure/Matrix.pm b/perllib/Graph/TransitiveClosure/Matrix.pm
deleted file mode 100644
index be56f2a..0000000
--- a/perllib/Graph/TransitiveClosure/Matrix.pm
+++ /dev/null
@@ -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
diff --git a/perllib/Graph/Traversal.pm b/perllib/Graph/Traversal.pm
deleted file mode 100644
index edfc5b1..0000000
--- a/perllib/Graph/Traversal.pm
+++ /dev/null
@@ -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
diff --git a/perllib/Graph/Traversal/BFS.pm b/perllib/Graph/Traversal/BFS.pm
deleted file mode 100644
index 2678f72..0000000
--- a/perllib/Graph/Traversal/BFS.pm
+++ /dev/null
@@ -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
diff --git a/perllib/Graph/Traversal/DFS.pm b/perllib/Graph/Traversal/DFS.pm
deleted file mode 100644
index 4b109bd..0000000
--- a/perllib/Graph/Traversal/DFS.pm
+++ /dev/null
@@ -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
diff --git a/perllib/Graph/Undirected.pm b/perllib/Graph/Undirected.pm
deleted file mode 100644
index 3993bb1..0000000
--- a/perllib/Graph/Undirected.pm
+++ /dev/null
@@ -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;
diff --git a/perllib/Graph/UnionFind.pm b/perllib/Graph/UnionFind.pm
deleted file mode 100644
index 83a921f..0000000
--- a/perllib/Graph/UnionFind.pm
+++ /dev/null
@@ -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
-
diff --git a/perllib/Heap071/Elem.pm b/perllib/Heap071/Elem.pm
deleted file mode 100644
index 40ae5dc..0000000
--- a/perllib/Heap071/Elem.pm
+++ /dev/null
@@ -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
diff --git a/perllib/Heap071/Fibonacci.pm b/perllib/Heap071/Fibonacci.pm
deleted file mode 100644
index 3308bf3..0000000
--- a/perllib/Heap071/Fibonacci.pm
+++ /dev/null
@@ -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 = \&top;
-
-sub extract_top {
- my $h = shift;
- my $el = $$h or return undef;
- my $ltop = $el->{left};
- my $cur;
- my $next;
-
- # $el is the heap with the lowest value on it
- # move all of $el's children (if any) to the top list (between
- # $ltop and $el)
- if( $cur = $el->{child} ) {
- # remember the beginning of the list of children
- my $first = $cur;
- do {
- # the children are moving to the top, clear the p
- # pointer for all of them
- $cur->{p} = undef;
- } until ($cur = $cur->{right}) == $first;
-
- # remember the end of the list
- $cur = $cur->{left};
- link_to_left_of $ltop, $first;
- link_to_left_of $cur, $el;
- }
-
- if( $el->{right} == $el ) {
- # $el had no siblings or children, the top only contains $el
- # and $el is being removed
- $$h = undef;
- } else {
- link_to_left_of $el->{left}, $$h = $el->{right};
- # now all those loose ends have to be merged together as we
- # search for the
- # new smallest element
- $h->consolidate;
- }
-
- # extract the actual value and return that, $el is no longer used
- # but break all of its links so that it won't be pointed to...
- my $top = $el->{val};
- $top->heap(undef);
- $el->{left} = $el->{right} = $el->{p} = $el->{child} = $el->{val} =
- undef;
- $top;
-}
-
-*extract_minimum = \&extract_top;
-
-sub absorb {
- my $h = shift;
- my $h2 = shift;
-
- my $el = $$h;
- unless( $el ) {
- $$h = $$h2;
- $$h2 = undef;
- return $h;
- }
-
- my $el2 = $$h2 or return $h;
-
- # add $el2 and its siblings to the head list for $h
- # at start, $ell -> $el -> ... -> $ell is on $h (where $ell is
- # $el->{left})
- # $el2l -> $el2 -> ... -> $el2l are on $h2
- # at end, $ell -> $el2l -> ... -> $el2 -> $el -> ... -> $ell are
- # all on $h
- my $el2l = $el2->{left};
- link_to_left_of $el->{left}, $el2;
- link_to_left_of $el2l, $el;
-
- # change the top link if needed
- $$h = $el2 if $el->{val}->cmp( $el2->{val} ) > 0;
-
- # clean out $h2
- $$h2 = undef;
-
- # return the heap
- $h;
-}
-
-# a key has been decreased, it may have to percolate up in its heap
-sub decrease_key {
- my $h = shift;
- my $top = $$h;
- my $v = shift;
- my $el = $v->heap or return undef;
- my $p;
-
- # first, link $h to $el if it is now the smallest (we will
- # soon link $el to $top to properly put it up to the top list,
- # if it isn't already there)
- $$h = $el if $top->{val}->cmp( $v ) > 0;
-
- if( $p = $el->{p} and $v->cmp($p->{val}) < 0 ) {
- # remove $el from its parent's list - it is now smaller
-
- ascending_cut $top, $p, $el;
- }
-
- $v;
-}
-
-
-# to delete an item, we bubble it to the top of its heap (as if its key
-# had been decreased to -infinity), and then remove it (as in extract_top)
-sub delete {
- my $h = shift;
- my $v = shift;
- my $el = $v->heap or return undef;
-
- # if there is a parent, cut $el to the top (as if it had just had its
- # key decreased to a smaller value than $p's value
- my $p;
- $p = $el->{p} and ascending_cut $$h, $p, $el;
-
- # $el is in the top list now, make it look like the smallest and
- # remove it
- $$h = $el;
- $h->extract_top;
-}
-
-
-################################################# internal utility functions
-
-sub elem {
- my $v = shift;
- my $el = undef;
- $el = {
- p => undef,
- degree => 0,
- mark => 0,
- child => undef,
- val => $v,
- left => undef,
- right => undef,
- };
- $el->{left} = $el->{right} = $el;
- $v->heap($el);
- $el;
-}
-
-sub elem_DESTROY {
- my $el = shift;
- my $ch;
- my $next;
- $el->{left}->{right} = undef;
-
- while( $el ) {
- $ch = $el->{child} and elem_DESTROY $ch;
- $next = $el->{right};
-
- defined $el->{val} and $el->{val}->heap(undef);
- $el->{child} = $el->{right} = $el->{left} = $el->{p} = $el->{val}
- = undef;
- $el = $next;
- }
-}
-
-sub link_to_left_of {
- my $l = shift;
- my $r = shift;
-
- $l->{right} = $r;
- $r->{left} = $l;
-}
-
-sub link_as_parent_of {
- my $p = shift;
- my $c = shift;
-
- my $pc;
-
- if( $pc = $p->{child} ) {
- link_to_left_of $pc->{left}, $c;
- link_to_left_of $c, $pc;
- } else {
- link_to_left_of $c, $c;
- }
- $p->{child} = $c;
- $c->{p} = $p;
- $p->{degree}++;
- $c->{mark} = 0;
- $p;
-}
-
-sub consolidate {
- my $h = shift;
-
- my $cur;
- my $this;
- my $next = $$h;
- my $last = $next->{left};
- my @a;
- do {
- # examine next item on top list
- $this = $cur = $next;
- $next = $cur->{right};
- my $d = $cur->{degree};
- my $alt;
- while( $alt = $a[$d] ) {
- # we already saw another item of the same degree,
- # put the larger valued one under the smaller valued
- # one - switch $cur and $alt if necessary so that $cur
- # is the smaller
- ($cur,$alt) = ($alt,$cur)
- if $cur->{val}->cmp( $alt->{val} ) > 0;
- # remove $alt from the top list
- link_to_left_of $alt->{left}, $alt->{right};
- # and put it under $cur
- link_as_parent_of $cur, $alt;
- # make sure that $h still points to a node at the top
- $$h = $cur;
- # we've removed the old $d degree entry
- $a[$d] = undef;
- # and we now have a $d+1 degree entry to try to insert
- # into @a
- ++$d;
- }
- # found a previously unused degree
- $a[$d] = $cur;
- } until $this == $last;
- $cur = $$h;
- for $cur (grep defined, @a) {
- $$h = $cur if $$h->{val}->cmp( $cur->{val} ) > 0;
- }
-}
-
-sub ascending_cut {
- my $top = shift;
- my $p = shift;
- my $el = shift;
-
- while( 1 ) {
- if( --$p->{degree} ) {
- # there are still other children below $p
- my $l = $el->{left};
- $p->{child} = $l;
- link_to_left_of $l, $el->{right};
- } else {
- # $el was the only child of $p
- $p->{child} = undef;
- }
- link_to_left_of $top->{left}, $el;
- link_to_left_of $el, $top;
- $el->{p} = undef;
- $el->{mark} = 0;
-
- # propagate up the list
- $el = $p;
-
- # quit at the top
- last unless $p = $el->{p};
-
- # quit if we can mark $el
- $el->{mark} = 1, last unless $el->{mark};
- }
-}
-
-
-1;
-
-__END__
-
-=head1 NAME
-
-Heap::Fibonacci - a Perl extension for keeping data partially sorted
-
-=head1 SYNOPSIS
-
- use Heap::Fibonacci;
-
- $heap = Heap::Fibonacci->new;
- # see Heap(3) for usage
-
-=head1 DESCRIPTION
-
-Keeps elements in heap order using a linked list of Fibonacci trees.
-The I<heap> method of an element is used to store a reference to
-the node in the list that refers to the element.
-
-See L<Heap> for details on using this module.
-
-=head1 AUTHOR
-
-John Macdonald, jmm@perlwolf.com
-
-=head1 COPYRIGHT
-
-Copyright 1998-2003, O'Reilly & Associates.
-
-This code is distributed under the same copyright terms as perl itself.
-
-=head1 SEE ALSO
-
-Heap(3), Heap::Elem(3).
-
-=cut
diff --git a/perllib/phash.ph b/perllib/phash.ph
index a274e11..24f6a4f 100644
--- a/perllib/phash.ph
+++ b/perllib/phash.ph
@@ -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);
-
- foreach $nx ($gr->neighbors($n)) {
- die unless ($gr->has_edge_attribute($n, $nx, "hash"));
- my $e = $gr->get_edge_attribute($n, $nx, "hash");
-
- # 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";
+ $$nodeval[$n] = $v;
+
+ foreach $nx (@{$$nodeneigh[$n]}) {
+ # $nx -> [neigh, hash]
+ my ($o, $e) = @$nx;
+
+ # 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";
-
- $gr->add_edge($pf1, $pf2);
- $gr->set_edge_attribute($pf1, $pf2, "hash", $e);
- $gr->set_edge_attribute($pf1, $pf2, "key", $k);
- }
+ # print STDERR "Edge $pf value $e from $k\n";
- # 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 =~ /^([^=]+)\=([^=]+)$/) {