package Graph;
use strict;
use warnings;
BEGIN { warnings->unimport('recursion') if $ENV{GRAPH_ALLOW_RECURSION} }
sub __carp_confess { require Carp; Carp::confess(@_) }
BEGIN {
if (0) { # SET THIS TO ZERO FOR TESTING AND RELEASES!
$SIG{__DIE__ } = \&__carp_confess;
$SIG{__WARN__} = \&__carp_confess;
}
}
use Graph::AdjacencyMap qw(:flags :fields);
our $VERSION = '0.9735';
require 5.006; # Weak references are absolutely required.
my @GRAPH_PROPS_COPIED = qw(
undirected refvertexed countvertexed multivertexed __stringified
hyperedged countedged multiedged
);
my $_empty_array = [];
sub _empty_array () { $_empty_array }
my $can_deep_copy_Storable;
sub _can_deep_copy_Storable () {
return $can_deep_copy_Storable if defined $can_deep_copy_Storable;
return $can_deep_copy_Storable = 0 if $] < 5.010; # no :load tag Safe 5.8
eval {
require Storable;
require B::Deparse;
Storable->VERSION(2.05);
B::Deparse->VERSION(0.61);
};
$can_deep_copy_Storable = !$@;
}
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 {
if ($] >= 5.022) {
$Inf = eval '+"Inf"'; # uncoverable statement
} else {
local $SIG{FPE}; # uncoverable statement
eval { $Inf = exp(999) } || # uncoverable statement
eval { $Inf = 9**9**9 } || # uncoverable statement
eval { $Inf = 1e+999 } || # uncoverable statement
{ $Inf = 1e+99 }; # uncoverable statement
# 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:
# - unionfind
# The vertices are contained in a "simplemap"
# (if no attributes) or in a "map".
# The edges are always in a "map".
# The defined flags for maps are:
# - _COUNT for countedness: more than one instance
# 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
# Vertices and edges assume none of these flags.
use Graph::Attribute array => _A, map => 'graph';
sub stringify {
my ($u, $h) = (&is_undirected, &is_hyperedged);
my $e = $u ? '=' : '-';
my @edges = map join($e,
$u ? sort { "$a" cmp "$b" } @$_ :
$h ? map '['.join(",", sort { "$a" cmp "$b" } @$_).']', @$_ :
@$_), &_edges05;
my @s = sort @edges;
push @s, sort { "$a" cmp "$b" } &isolated_vertices;
join(",", @s);
}
sub eq {
"$_[0]" eq "$_[1]"
}
sub boolify {
1; # Important for empty graphs: they stringify to "", which is false.
}
sub ne {
"$_[0]" ne "$_[1]"
}
use overload
'""' => \&stringify,
'bool' => \&boolify,
'eq' => \&eq,
'ne' => \≠
sub _opt {
my ($opt, $flags, %flags) = @_;
while (my ($flag, $FLAG) = each %flags) {
$$flags |= $FLAG if delete $opt->{$flag};
$$flags &= ~$FLAG if delete $opt->{"non$flag"};
}
}
sub _opt_get {
my ($opt, $key, $var) = @_;
return if !exists $opt->{$key};
$$var = delete $opt->{$key};
}
sub _opt_unknown {
my ($opt) = @_;
return unless my @opt = keys %$opt;
__carp_confess sprintf
"@{[(caller(1))[3]]}: Unknown option%s: @{[map qq['$_'], sort @opt]}",
@opt > 1 ? 's' : '';
}
sub _opt_from_existing {
my ($g) = @_;
my %existing;
$existing{$_}++ for grep $g->$_, @GRAPH_PROPS_COPIED;
$existing{unionfind}++ if $g->has_union_find;
%existing;
}
sub _opt_to_vflags {
my ($vflags, $opt) = (0, @_);
_opt($opt, \$vflags,
countvertexed => _COUNT,
multivertexed => _MULTI,
refvertexed => _REF,
refvertexed_stringified => _REFSTR ,
__stringified => _STR,
);
$vflags;
}
sub _opt_to_eflags {
my ($eflags, $opt) = (0, @_);
$opt->{undirected} = !delete $opt->{directed} if exists $opt->{directed};
_opt($opt, \$eflags,
countedged => _COUNT,
multiedged => _MULTI,
undirected => _UNORD,
);
($eflags, delete $opt->{hyperedged});
}
sub new {
my ($class, @args) = @_;
my $gflags = 0;
my %opt = _get_options( \@args );
%opt = (_opt_from_existing($class), %opt) # allow overrides
if ref $class && $class->isa('Graph');
my $vflags = _opt_to_vflags(\%opt);
my ($eflags, $is_hyper) = _opt_to_eflags(\%opt);
_opt(\%opt, \$gflags,
unionfind => _UNIONFIND,
);
my @V;
if ($opt{vertices}) {
__carp_confess "Graph: vertices should be an array ref"
if ref $opt{vertices} ne 'ARRAY';
@V = @{ delete $opt{vertices} };
}
my @E;
if ($opt{edges}) {
__carp_confess "Graph: edges should be an array ref of array refs"
if ref $opt{edges} ne 'ARRAY';
@E = @{ delete $opt{edges} };
__carp_confess "Graph: edges should be array refs"
if grep ref $_ ne 'ARRAY', @E;
}
_opt_unknown(\%opt);
__carp_confess "Graph: both countvertexed and multivertexed"
if ($vflags & _COUNT) && ($vflags & _MULTI);
__carp_confess "Graph: both countedged and multiedged"
if ($eflags & _COUNT) && ($eflags & _MULTI);
my $g = bless [ ], ref $class || $class;
$g->[ _F ] = $gflags;
$g->[ _G ] = 0;
$g->[ _V ] = _make_v($vflags);
$g->[ _E ] = _make_e($is_hyper, $eflags);
$g->[ _U ] = do { require Graph::UnionFind; Graph::UnionFind->new }
if $gflags & _UNIONFIND;
$g->add_vertices(@V) if @V;
$g->add_edges(@E) if @E;
return $g;
}
sub _make_v {
my ($vflags) = @_;
$vflags ? _am_heavy($vflags, 1) : _am_light($vflags, 1);
}
sub _make_e {
my ($is_hyper, $eflags) = @_;
($is_hyper or $eflags & ~_UNORD) ?
_am_heavy($eflags, $is_hyper ? 0 : 2) :
_am_light($eflags, 2);
}
sub _am_light {
require Graph::AdjacencyMap::Light;
Graph::AdjacencyMap::Light->_new(@_);
}
sub _am_heavy {
Graph::AdjacencyMap->_new(@_);
}
sub countvertexed { $_[0]->[ _V ]->_is_COUNT }
sub multivertexed { $_[0]->[ _V ]->_is_MULTI }
sub refvertexed { $_[0]->[ _V ]->_is_REF }
sub refvertexed_stringified { $_[0]->[ _V ]->_is_REFSTR }
sub __stringified { $_[0]->[ _V ]->_is_STR }
sub countedged { $_[0]->[ _E ]->_is_COUNT }
sub multiedged { $_[0]->[ _E ]->_is_MULTI }
sub hyperedged { !$_[0]->[ _E ]->[ _arity ] }
sub undirected { $_[0]->[ _E ]->_is_UNORD }
sub directed { ! $_[0]->[ _E ]->_is_UNORD }
*is_directed = \&directed;
*is_undirected = \&undirected;
*is_countvertexed = \&countvertexed;
*is_multivertexed = \&multivertexed;
*is_refvertexed = \&refvertexed;
*is_refvertexed_stringified = \&refvertexed_stringified;
*is_countedged = \&countedged;
*is_multiedged = \&multiedged;
*is_hyperedged = \&hyperedged;
sub has_union_find { $_[0]->[ _U ] }
sub add_vertex {
__carp_confess "Graph::add_vertex: use add_vertices for more than one vertex" if @_ != 2;
__carp_confess "Graph::add_vertex: undef vertex" if grep !defined, @_;
goto &add_vertices;
}
sub has_vertex {
my $g = $_[0];
my $V = $g->[ _V ];
return defined $V->has_path($_[1]) if ($V->[ _f ] & _REF);
exists $V->[ _pi ]->{ $_[1] };
}
sub _vertices05 {
my $g = $_[0];
$g->[ _V ]->paths;
}
sub vertices {
my $g = $_[0];
my @v = &_vertices05;
return @v if !(&is_multivertexed || &is_countvertexed);
return map +(($_) x $g->get_vertex_count($_)), @v if wantarray;
my $V = 0;
$V += $g->get_vertex_count($_) for @v;
return $V;
}
*unique_vertices = \&_vertices05;
sub has_vertices {
my $g = shift;
scalar $g->[ _V ]->has_any_paths;
}
sub add_edge {
&expect_hyperedged, &expect_undirected if @_ != 3;
$_[0]->add_edges([ @_[1..$#_] ]);
}
sub _vertex_ids_ensure {
push @_, 1;
goto &_vertex_ids_maybe_ensure;
}
sub _vertex_ids_ensure_multi {
my $id = pop;
my @i = &_vertex_ids_ensure;
push @_, $id;
@i ? (@i, $id) : ();
}
sub _vertex_ids {
push @_, 0;
goto &_vertex_ids_maybe_ensure;
}
sub _vertex_ids_multi {
my $id = pop;
my @i = &_vertex_ids;
push @_, $id;
@i ? (@i, $id) : ();
}
sub _vertex_ids_maybe_ensure {
my $ensure = pop;
my ($g, @args) = @_;
__carp_confess "Graph: given undefined vertex" if grep !defined, @args;
my $V = $g->[ _V ];
my $deep = &is_hyperedged && &is_directed;
return $V->get_ids_by_paths(\@args, $ensure, $deep) if ($V->[ _f ] & _REF) or $deep;
my $pi = $V->[ _pi ];
my @non_exist = grep !exists $pi->{ $_ }, @args;
return if !$ensure and @non_exist;
$V->get_ids_by_paths(\@non_exist, 1) if @non_exist;
@$pi{ @args };
}
sub has_edge {
my $g = $_[0];
my $E = $g->[ _E ];
my ($Ef, $Ea) = @$E[ _f, _arity ];
return 0 if $Ea and @_ != $Ea + 1;
my $directed = &is_directed;
my $deep = &is_hyperedged && $directed;
return 0 if (my @i = &_vertex_ids) != @_ - 1;
return defined $E->has_path($directed ? \@i : [ map [ sort @$_ ], @i ]) if $deep;
@i = sort @i if !$directed;
exists $E->[ _pi ]{ "@i" };
}
sub any_edge {
my ($g, @args) = @_;
my $E = $g->[ _E ];
my $V = $g->[ _V ];
return 0 if (my @i = $V->get_ids_by_paths(\@args)) != @args;
$E->has_successor(@i);
}
sub _edges05 {
my $g = $_[0];
my @e = $g->[ _E ]->paths;
return @e if !wantarray;
$g->[ _V ]->get_paths_by_ids(\@e, &is_hyperedged && &is_directed);
}
*unique_edges = \&_edges05;
sub edges {
my $g = $_[0];
my @e = &_edges05;
return @e if !(&is_multiedged || &is_countedged);
return map +(($_) x $g->get_edge_count(@$_)), @e if wantarray;
my $E = 0;
$E += $g->get_edge_count(@$_) for @e;
return $E;
}
sub has_edges {
scalar $_[0]->[ _E ]->has_any_paths;
}
###
# by_id
#
sub add_vertex_by_id {
&expect_multivertexed;
my ($g, $v, $id) = @_;
my $V = $g->[ _V ];
return $g if $V->has_path_by_multi_id( my @args = ($v, $id) );
my ($i) = $V->set_path_by_multi_id( @args );
$g->[ _U ]->add($i) if &has_union_find;
$g->[ _G ]++;
return $g;
}
sub add_vertex_get_id {
&expect_multivertexed;
my ($g, $v) = @_;
my ($i, $multi_id) = $g->[ _V ]->set_path_by_multi_id( $v, _GEN_ID );
$g->[ _U ]->add($i) if &has_union_find;
$g->[ _G ]++;
return $multi_id;
}
sub has_vertex_by_id {
&expect_multivertexed;
my ($g, $v, $id) = @_;
$g->[ _V ]->has_path_by_multi_id( $v, $id );
}
sub delete_vertex_by_id {
&expect_multivertexed;
&expect_non_unionfind;
my ($g, $v, $id) = @_;
return $g unless &has_vertex_by_id;
if ($g->[ _V ]->get_multi_ids( $v ) == 1) {
# only incarnation, zap edges
my @i = &_vertex_ids_multi;
pop @i; # the id
my $E = $g->[ _E ];
my @edges = $E->paths_from(@i);
push @edges, $E->paths_to(@i) if !&is_undirected;
$E->del_path( $_ ) for @edges;
}
$g->[ _V ]->del_path_by_multi_id( $v, $id );
$g->[ _G ]++;
return $g;
}
sub get_multivertex_ids {
&expect_multivertexed;
my $g = shift;
$g->[ _V ]->get_multi_ids( @_ );
}
sub add_edge_by_id {
&expect_multiedged;
my $g = $_[0];
my @i = &_vertex_ids_ensure_multi;
my $id = pop @i;
@i = sort @i if &is_undirected;
$g->[ _E ]->set_path_by_multi_id( \@i, $id );
$g->[ _G ]++;
$g->[ _U ]->union(\@i) if &has_union_find;
return $g;
}
sub add_edge_get_id {
&expect_multiedged;
my $g = $_[0];
my @i = &_vertex_ids_ensure;
@i = sort @i if &is_undirected;
my (undef, $id) = $g->[ _E ]->set_path_by_multi_id( \@i, _GEN_ID );
$g->[ _G ]++;
$g->[ _U ]->union(\@i) if &has_union_find;
return $id;
}
sub has_edge_by_id {
&expect_multiedged;
my $g = $_[0];
my @i = &_vertex_ids_multi;
return 0 if @i < @_ - 2;
my $id = pop @i;
@i = sort @i if &is_undirected;
$g->[ _E ]->has_path_by_multi_id( \@i, $id );
}
sub delete_edge_by_id {
&expect_multiedged;
&expect_non_unionfind;
my $g = $_[0];
my $E = $g->[ _E ];
my @i = &_vertex_ids_multi;
return if @i < @_ - 2;
my $id = pop @i;
@i = sort @i if &is_undirected;
return unless $E->has_path_by_multi_id( my @args = (\@i, $id) );
$E->del_path_by_multi_id( @args );
$g->[ _G ]++;
return $g;
}
sub get_multiedge_ids {
&expect_multiedged;
return unless @_-1 == (my @i = &_vertex_ids);
$_[0]->[ _E ]->get_multi_ids( \@i );
}
###
# Neighbourhood.
#
sub _edges_at {
goto &_edges_from if &is_undirected;
require Set::Object;
Set::Object->new(&_edges_from, &_edges_to)->${ wantarray ? \'members' : \'size' };
}
sub _edges_from {
my ($g, @args) = @_;
my ($V, $E) = @$g[ _V, _E ];
return if (my @i = $V->get_ids_by_paths(\@args, &is_hyperedged && &is_directed)) != @args;
$E->paths_from(@i);
}
sub _edges_to {
goto &_edges_from if &is_undirected;
my ($g, @args) = @_;
my ($V, $E) = @$g[ _V, _E ];
return if (my @i = $V->get_ids_by_paths(\@args, &is_hyperedged && &is_directed)) != @args;
$E->paths_to(@i);
}
sub edges_at {
goto &_edges_at if !wantarray;
$_[0]->[ _V ]->get_paths_by_ids([ &_edges_at ], &is_hyperedged && &is_directed);
}
sub edges_from {
goto &_edges_from if !wantarray;
$_[0]->[ _V ]->get_paths_by_ids([ &_edges_from ], &is_hyperedged && &is_directed);
}
sub edges_to {
goto &edges_from if &is_undirected;
goto &_edges_to if !wantarray;
$_[0]->[ _V ]->get_paths_by_ids([ &_edges_to ], &is_hyperedged && &is_directed);
}
sub successors {
my ($g, @args) = @_;
my ($V, $E) = @$g[ _V, _E ];
return if (my @i = $V->get_ids_by_paths(\@args)) != @args;
my @v = $E->successors(@i);
return @v if !wantarray;
map @$_, $V->get_paths_by_ids([ \@v ]);
}
sub predecessors {
goto &successors if &is_undirected;
my ($g, @args) = @_;
my ($V, $E) = @$g[ _V, _E ];
return if (my @i = $V->get_ids_by_paths(\@args)) != @args;
my @v = $E->predecessors(@i);
return @v if !wantarray;
map @$_, $V->get_paths_by_ids([ \@v ]);
}
sub _cessors_by_radius {
my ($radius, $method, $self_only_if_loop) = splice @_, -3, 3;
my ($g, @v) = @_;
require Set::Object;
my ($init, $next) = map Set::Object->new(@v), 1..2;
my $self = $self_only_if_loop ? Set::Object->new(grep $g->has_edge($_, $_), @v) : undef;
my ($got, $found) = map Set::Object->new, 1..2;
while (!defined $radius or $radius-- > 0) {
$found->insert($g->$method($next->members));
$next = $found->difference($got);
last if $next->is_null; # Leave if no new found.
$got->insert($next->members);
$found->clear;
}
$got->remove($init->difference($self)->members) if $self_only_if_loop;
$got->${ wantarray ? \'members' : \'size' };
}
sub all_successors {
&expect_directed;
push @_, undef, 'successors', 0;
goto &_cessors_by_radius;
}
sub successors_by_radius {
&expect_directed;
push @_, 'successors', 0;
goto &_cessors_by_radius;
}
sub all_predecessors {
&expect_directed;
push @_, undef, 'predecessors', 0;
goto &_cessors_by_radius;
}
sub predecessors_by_radius {
&expect_directed;
push @_, 'predecessors', 0;
goto &_cessors_by_radius;
}
sub neighbours_by_radius {
push @_, 'neighbours', 1;
goto &_cessors_by_radius;
}
*neighbors_by_radius = \&neighbours_by_radius;
sub neighbours {
require Set::Object;
my $s = Set::Object->new(&successors);
$s->insert(&predecessors) if &is_directed;
$s->${ wantarray ? \'members' : \'size' };
}
*neighbors = \&neighbours;
sub all_neighbours {
push @_, undef, 'neighbours', 1;
goto &_cessors_by_radius;
}
*all_neighbors = \&all_neighbours;
sub all_reachable {
&directed ? goto &all_successors : goto &all_neighbors;
}
sub reachable_by_radius {
&directed ? goto &successors_by_radius : goto &neighbors_by_radius;
}
sub delete_edge {
&expect_non_unionfind;
my $g = $_[0];
return $g if (my @i = &_vertex_ids) != @_ - 1;
@i = sort @i if &is_undirected;
return $g unless @i and $g->[ _E ]->del_path( \@i );
$g->[ _G ]++;
return $g;
}
sub delete_vertex {
&expect_non_unionfind;
my $g = $_[0];
return $g if @_ != 2;
my $V = $g->[ _V ];
return $g unless defined $V->has_path($_[1]);
# TODO: _edges_at is excruciatingly slow (rt.cpan.org 92427)
my $E = $g->[ _E ];
$E->del_path( $_ ) for &_edges_at;
$V->del_path($_[1]);
$g->[ _G ]++;
return $g;
}
sub get_vertex_count {
my $g = shift;
$g->[ _V ]->_get_path_count( @_ );
}
sub get_edge_count {
my $g = $_[0];
return 0 if (my @i = &_vertex_ids) != @_ - 1;
@i = sort @i if &is_undirected;
$g->[ _E ]->_get_path_count( \@i );
}
sub delete_vertices {
&expect_non_unionfind;
my $g = shift;
while (@_) {
my $v = shift @_;
$g->delete_vertex($v);
}
return $g;
}
sub delete_edges {
&expect_non_unionfind;
my $g = shift;
while (@_) {
my ($u, $v) = splice @_, 0, 2;
$g->delete_edge($u, $v);
}
return $g;
}
###
# Degrees.
#
sub in_degree {
my $g = $_[0];
return undef unless @_ > 1 && &has_vertex;
my $in = 0;
$in += $g->get_edge_count( @$_ ) for &edges_to;
$in++ if &is_undirected and &is_self_loop_vertex;
return $in;
}
sub out_degree {
my $g = $_[0];
return undef unless @_ > 1 && &has_vertex;
my $out = 0;
$out += $g->get_edge_count( @$_ ) for &edges_from;
$out++ if &is_undirected and &is_self_loop_vertex;
return $out;
}
sub _total_degree {
return undef unless @_ > 1 && &has_vertex;
&is_undirected ? &in_degree : &in_degree - &out_degree;
}
sub degree {
goto &_total_degree if @_ > 1;
return 0 if &is_directed;
my $g = $_[0];
my $total = 0;
$total += $g->_total_degree( $_ ) for &_vertices05;
return $total;
}
*vertex_degree = \°ree;
sub is_sink_vertex {
return 0 unless @_ > 1;
&successors == 0 && &predecessors > 0;
}
sub is_source_vertex {
return 0 unless @_ > 1;
&predecessors == 0 && &successors > 0;
}
sub is_successorless_vertex {
return 0 unless @_ > 1;
&successors == 0;
}
sub is_predecessorless_vertex {
return 0 unless @_ > 1;
&predecessors == 0;
}
sub is_successorful_vertex {
return 0 unless @_ > 1;
&successors > 0;
}
sub is_predecessorful_vertex {
return 0 unless @_ > 1;
&predecessors > 0;
}
sub is_isolated_vertex {
return 0 unless @_ > 1;
&predecessors == 0 && &successors == 0;
}
sub is_interior_vertex {
return 0 unless @_ > 1;
my $s = &successors;
$s-- if my $isl = &is_self_loop_vertex;
return 0 if $s == 0;
return $s > 0 if &is_undirected;
my $p = &predecessors;
$p-- if $isl;
$p > 0;
}
sub is_exterior_vertex {
return 0 unless @_ > 1;
&predecessors == 0 || &successors == 0;
}
sub is_self_loop_vertex {
return 0 unless @_ > 1;
return 1 if grep $_ eq $_[1], &successors; # @todo: multiedges
return 0;
}
for my $p (qw(
is_sink_vertex
is_source_vertex
is_successorless_vertex
is_predecessorless_vertex
is_successorful_vertex
is_predecessorful_vertex
is_isolated_vertex
is_interior_vertex
is_exterior_vertex
is_self_loop_vertex
)) {
no strict 'refs';
(my $m = $p) =~ s/^is_(.*)ex$/${1}ices/;
*$m = sub { my $g = $_[0]; grep $g->$p($_), &_vertices05 };
}
###
# Paths and cycles.
#
sub add_path {
my $g = shift;
my $u = shift;
my @edges;
while (@_) {
my $v = shift;
push @edges, [ $u, $v ];
$u = $v;
}
$g->add_edges(@edges);
return $g;
}
sub delete_path {
&expect_non_unionfind;
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 {
push @_, $_[1];
goto &add_path;
}
sub delete_cycle {
&expect_non_unionfind;
push @_, $_[1];
goto &delete_path;
}
sub has_cycle {
return 0 if @_ == 1;
push @_, $_[1];
goto &has_path;
}
*has_this_cycle = \&has_cycle;
sub has_a_cycle {
my $g = shift;
require Graph::Traversal::DFS;
my $t = Graph::Traversal::DFS->new($g, has_a_cycle => 1, @_);
$t->dfs;
return $t->get_state('has_a_cycle');
}
sub find_a_cycle {
require Graph::Traversal::DFS;
my @r = ( back_edge => \&Graph::Traversal::find_a_cycle);
push @r,
down_edge => \&Graph::Traversal::find_a_cycle
if &is_undirected;
my $g = shift;
my $t = Graph::Traversal::DFS->new($g, @r, @_);
$t->dfs;
$t->has_state('a_cycle') ? @{ $t->get_state('a_cycle') } : ();
}
###
# Attributes.
my @generic_methods = (
[ 'set_attribute', 'my (\$attr, \$value) = splice \@_, -2; &$add unless &$has;',
'\$_[0]->[ $offset ]->_set_path_attr( \@args, \$attr, \$value );' ],
[ 'set_attributes', 'my \$attr = pop; &$add unless &$has;',
'\$_[0]->[ $offset ]->_set_path_attrs( \@args, \$attr );', ],
[ 'has_attributes', 'return 0 unless &$has;',
'\$_[0]->[ $offset ]->_has_path_attrs( \@args );', ],
[ 'has_attribute', 'my \$attr = pop; return 0 unless &$has;',
'\$_[0]->[ $offset ]->_has_path_attr( \@args, \$attr );', ],
[ 'get_attributes', 'return undef unless &$has;',
'scalar \$_[0]->[ $offset ]->_get_path_attrs( \@args );', ],
[ 'get_attribute', 'my \$attr = pop; return undef unless &$has;',
'scalar \$_[0]->[ $offset ]->_get_path_attr( \@args, \$attr );', ],
[ 'get_attribute_names', 'return unless &$has;',
'\$_[0]->[ $offset ]->_get_path_attr_names( \@args );', ],
[ 'get_attribute_values', 'return unless &$has;',
'\$_[0]->[ $offset ]->_get_path_attr_values( \@args );', ],
[ 'delete_attributes', 'return undef unless &$has;',
'\$_[0]->[ $offset ]->_del_path_attrs( \@args );', ],
[ 'delete_attribute', 'my \$attr = pop; return undef unless &$has;',
'\$_[0]->[ $offset ]->_del_path_attr( \@args, \$attr );', ],
);
my %entity2offset = (vertex => '_V', edge => '_E');
my %entity2args = (edge => '&_vertex_ids');
my $template_mid = 'my \@args = @{[ $args || "\@_[1..\$#_]" ]};$munge';
for my $entity (qw(vertex edge)) {
no strict 'refs';
my $has_base = 'has_' . $entity;
my $add_base = 'add_' . $entity;
my $offset = $entity2offset{$entity};
for my $t (@generic_methods) {
my ($raw, $t1, $t2) = @$t;
my ($first, $rest) = ($raw =~ /^(\w+?)_(.+)/);
my $is_vertex = $entity eq 'vertex';
my $m = join '_', $first, $entity, $rest;
my ($args, $munge, $has, $add) = ($entity2args{$entity}, $is_vertex ? '' : "\n\@args = &is_undirected ? [sort \@args] : [\@args];", $has_base, $add_base);
my $func_text = "qq{sub $m {\n&expect_non_multi$entity;\n$t1\n$template_mid\n$t2\n}}\n"; #warn "$m:\n$func_text\n";
my $tv2 = eval $func_text; #warn "$m v2:\n$tv2\n";
eval $tv2; die if $@;
$m .= '_by_id';
($args, $munge, $has, $add) = ($entity2args{$entity} && "$entity2args{$entity}_multi", $is_vertex ? '' : "\n\@args = (&is_undirected ? [sort \@args[0..\$#args-1]] : [\@args[0..\$#args-1]], \$args[-1]);", $has_base.'_by_id', $add_base.'_by_id');
$func_text = "qq{sub $m {\n&expect_multi$entity;\n$t1\n$template_mid\n$t2\n}}\n"; #warn "$m:\n$func_text\n";
$tv2 = eval $func_text; #warn "$m v2:\n$tv2\n";
eval $tv2; die if $@;
}
}
sub get_edge_attribute_all {
my ($g, $u, $v, $name) = @_;
die "no attribute name given" if !defined $name;
grep defined(),
&is_multiedged ? (map $g->get_edge_attribute_by_id($u, $v, $_, $name),
$g->get_multiedge_ids($u, $v))
: $g->get_edge_attribute($u, $v, $name);
}
sub add_vertices {
my ($g, @v) = @_;
if (&is_multivertexed) {
$g->add_vertex_by_id($_, _GEN_ID) for @v;
return $g;
}
my @i = $g->[ _V ]->set_paths(@v);
$g->[ _G ]++;
return $g if !&has_union_find;
$g->[ _U ]->add(@i);
$g;
}
sub add_edges {
my ($g, @args) = @_;
my @edges;
while (defined(my $u = shift @args)) {
push @edges, ref $u eq 'ARRAY' ? $u : @args ? [ $u, shift @args ]
: __carp_confess "Graph::add_edges: missing end vertex";
}
if (&is_multiedged) {
$g->add_edge_by_id(@$_, _GEN_ID) for @edges;
return $g;
}
my $uf = &has_union_find;
my $deep = &is_hyperedged && &is_directed;
my @paths = $g->[ _V ]->get_ids_by_paths(\@edges, 1, 1 + ($deep ? 1 : 0));
@paths = map [ sort @$_ ], @paths if &is_undirected;
$g->[ _E ]->set_paths( @paths );
$uf->union(@paths) if $uf;
$g->[ _G ]++;
return $g;
}
sub add_edges_by_id {
&expect_multiedged;
my ($g, $id) = (shift, pop);
my @edges;
while (defined(my $u = shift @_)) {
push @edges, ref $u eq 'ARRAY' ? $u : @_ ? [ $u, shift @_ ]
: __carp_confess "Graph::add_edges: missing end vertex";
}
$g->add_edge_by_id(@$_, $id) for @edges;
return $g;
}
sub rename_vertex {
my $g = shift;
$g->[ _V ]->rename_path(@_);
return $g;
}
sub rename_vertices {
my ($g, $code) = @_;
my %seen;
$g->rename_vertex($_, $code->($_))
for grep !$seen{$_}++, $g->[ _V ]->paths;
return $g;
}
sub filter_vertices {
my ($g, $code) = @_;
my @v = &_vertices05;
if (&is_multivertexed) {
for my $v (@v) {
$g->delete_vertex_by_id($v, $_) for
grep !$code->($g, $v, $_), $g->get_multivertex_ids($v);
}
} else {
$g->delete_vertices(grep !$code->($g, $_), @v);
}
$g;
}
sub filter_edges {
my ($g, $code) = @_;
my @e = &_edges05;
if (&is_multiedged) {
for my $e (@e) {
$g->delete_edge_by_id(@$e, $_) for
grep !$code->($g, @$e, $_), $g->get_multiedge_ids(@$e);
}
} else {
$g->delete_edges(map @$_, grep !$code->($g, @$_), @e);
}
$g;
}
sub as_hashes {
my ($g) = @_;
my (%v, %e, @e);
my ($is_hyper, $is_directed) = (&is_hyperedged, &is_directed);
if (&is_multivertexed) {
for my $v ($g->unique_vertices) {
$v{$v} = {
map +($_ => $g->get_vertex_attributes_by_id($v, $_) || {}),
$g->get_multivertex_ids($v)
};
}
} else {
%v = map +($_ => $g->get_vertex_attributes($_) || {}), $g->unique_vertices;
}
my $multi_e = &is_multiedged;
for my $e ($g->edges) {
my $edge_attr = {
$multi_e
? map +($_ => $g->get_edge_attributes_by_id(@$e, $_) || {}),
$g->get_multiedge_ids(@$e)
: %{ $g->get_edge_attributes(@$e)||{} }
};
if ($is_hyper) {
my %h = (attributes => $edge_attr);
if ($is_directed) {
@h{qw(predecessors successors)} = @$e;
} else {
$h{vertices} = $e;
}
push @e, \%h;
} else {
$e{ $e->[0] }{ $e->[1] } = $edge_attr;
$e{ $e->[1] }{ $e->[0] } = $edge_attr if !$is_directed;
}
}
( \%v, $is_hyper ? \@e : \%e );
}
sub ingest {
my ($g, $g2) = @_;
_copy_vertices($g2, $g, 1);
_copy_edges($g2, $g, 1);
$g;
}
###
# More constructors.
#
sub copy {
my ($g, @args) = @_;
my $c = $g->new(@args);
_copy_vertices($g, $c);
_copy_edges($g, $c);
return $c;
}
*copy_graph = \©
sub _deep_copy_best {
_can_deep_copy_Storable()
? _deep_copy_Storable(@_) : _deep_copy_DataDumper(@_);
}
sub _deep_copy_Storable {
my $g = shift;
require Safe; # For deep_copy().
my $safe = Safe->new;
$safe->permit(qw/:load/);
local $Storable::Deparse = 1;
local $Storable::Eval = sub { $safe->reval($_[0]) };
return Storable::thaw(Storable::freeze($g));
}
sub _deep_copy_DataDumper {
my $g = shift;
require Data::Dumper;
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;
}
sub deep_copy {
local $. = $.;
my $g2 = _deep_copy_best(@_);
$g2->[ _V ]->reindex if grep ref, &_vertices05;
$g2;
}
*deep_copy_graph = \&deep_copy;
sub transpose_edge {
my $g = $_[0];
return $g if !&is_directed;
return undef unless &has_edge;
my $c = &get_edge_count;
my $a = &get_edge_attributes;
my @e = reverse @_[1..$#_];
&delete_edge unless $g->has_edge( @e );
$g->add_edges(map \@e, 1..$c);
$g->set_edge_attributes(@e, $a) if $a;
return $g;
}
sub transpose_graph {
my $t = ©
return $t if !&directed;
$t->transpose_edge(@$_) for &_edges05;
return $t;
}
*transpose = \&transpose_graph;
sub complete_graph {
my $directed = &is_directed;
my $c = &new;
my @v = &_vertices05;
my @edges;
for (my $i = $#v; $i >= 0; $i-- ) {
push @edges, map +([$v[$i], $v[$_]], $directed ? [$v[$_], $v[$i]] : ()),
0..$i - 1;
}
$c->add_edges(@edges);
return $c;
}
sub max_cliques {
my ($g) = @_;
&expect_undirected;
$g->bron_kerbosch_pivot([], [$g->vertices], [], \ my @cliques);
return wantarray ? @cliques : \@cliques
}
sub bron_kerbosch_pivot {
my ($g, $r, $p, $x, $max_cliques) = @_;
if (! @$p && ! @$x && @$r) {
push @$max_cliques, [@$r];
return;
}
my $pivot = (@$p, @$x)[0];
for my $v (my @p = @$p) {
next if $g->has_edge($pivot, $v);
$g->bron_kerbosch_pivot(
[@$r, $v],
[grep { my $w = $_; grep $_ eq $w, @$p } $g->neighbours($v)],
[grep { my $w = $_; grep $_ eq $w, @$x } $g->neighbours($v)],
$max_cliques);
@$p = grep $_ ne $v, @$p;
push @$x, $v;
}
}
*complement = \&complement_graph;
sub complement_graph {
my $c = &complete_graph;
$c->delete_edge(@$_) for &edges;
return $c;
}
*complete = \&complete_graph;
sub subgraph {
my ($g, $src, $dst) = @_;
__carp_confess "Graph::subgraph: need src and dst array references"
unless ref $src eq 'ARRAY' && (!defined($dst) or ref $dst eq 'ARRAY');
require Set::Object;
my $s = $g->new;
my @u = grep $g->has_vertex($_), @$src;
my $v = Set::Object->new($dst ? grep $g->has_vertex($_), @$dst : @u);
$s->add_vertices(@u, $dst ? $v->members : ());
my $directed = &is_directed;
if ($directed) {
$s->add_edges(grep $v->contains($_->[1]), $g->edges_from(@u));
} else {
my $valid = $dst ? $v + Set::Object->new(@u) : $v;
$s->add_edges(
grep +($v->contains($_->[0]) || $v->contains($_->[1])) &&
($valid->contains($_->[0]) && $valid->contains($_->[1])),
$g->edges_from(@u)
);
}
return $s;
}
###
# Transitivity.
#
sub is_transitive {
my $g = shift;
require Graph::TransitiveClosure;
Graph::TransitiveClosure::is_transitive($g);
}
###
# Weighted vertices.
#
my $defattr = 'weight';
sub _defattr {
return $defattr;
}
sub add_weighted_vertex {
&expect_non_multivertexed;
push @_, $defattr, pop;
goto &set_vertex_attribute;
}
sub add_weighted_vertices {
&expect_non_multivertexed;
my $g = shift;
while (@_) {
my ($v, $w) = splice @_, 0, 2;
$g->set_vertex_attribute($v, $defattr, $w);
}
}
sub get_vertex_weight {
&expect_non_multivertexed;
push @_, $defattr;
goto &get_vertex_attribute;
}
sub has_vertex_weight {
&expect_non_multivertexed;
push @_, $defattr;
goto &has_vertex_attribute;
}
sub set_vertex_weight {
&expect_non_multivertexed;
push @_, $defattr, pop;
goto &set_vertex_attribute;
}
sub delete_vertex_weight {
&expect_non_multivertexed;
push @_, $defattr;
goto &delete_vertex_attribute;
}
sub add_weighted_vertex_by_id {
&expect_multivertexed;
push @_, $defattr, pop;
goto &set_vertex_attribute_by_id;
}
sub add_weighted_vertices_by_id {
&expect_multivertexed;
my $g = shift;
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 {
&expect_multivertexed;
push @_, $defattr;
goto &get_vertex_attribute_by_id;
}
sub has_vertex_weight_by_id {
&expect_multivertexed;
push @_, $defattr;
goto &has_vertex_attribute_by_id;
}
sub set_vertex_weight_by_id {
&expect_multivertexed;
push @_, $defattr, pop;
goto &set_vertex_attribute_by_id;
}
sub delete_vertex_weight_by_id {
&expect_multivertexed;
push @_, $defattr;
goto &delete_vertex_attribute_by_id;
}
###
# Weighted edges.
#
sub add_weighted_edge {
&expect_non_multiedged;
push @_, $defattr, pop;
goto &set_edge_attribute;
}
sub add_weighted_edges {
&expect_non_multiedged;
my $g = shift;
while (@_) {
my ($u, $v, $w) = splice @_, 0, 3;
$g->set_edge_attribute($u, $v, $defattr, $w);
}
}
sub add_weighted_edges_by_id {
&expect_multiedged;
my $g = shift;
my $id = pop;
while (@_) {
my ($u, $v, $w) = splice @_, 0, 3;
$g->set_edge_attribute_by_id($u, $v, $id, $defattr, $w);
}
}
sub add_weighted_path {
&expect_non_multiedged;
my $g = shift;
my $u = shift;
while (@_) {
my ($w, $v) = splice @_, 0, 2;
$g->set_edge_attribute($u, $v, $defattr, $w);
$u = $v;
}
}
sub get_edge_weight {
&expect_non_multiedged;
push @_, $defattr;
goto &get_edge_attribute;
}
sub has_edge_weight {
&expect_non_multiedged;
push @_, $defattr;
goto &has_edge_attribute;
}
sub set_edge_weight {
&expect_non_multiedged;
push @_, $defattr, pop;
goto &set_edge_attribute;
}
sub delete_edge_weight {
&expect_non_multiedged;
push @_, $defattr;
goto &delete_edge_attribute;
}
sub add_weighted_edge_by_id {
&expect_multiedged;
push @_, $defattr, pop;
goto &set_edge_attribute_by_id;
}
sub add_path_by_id {
&expect_multiedged;
my ($g, $u, $id) = (shift, shift, pop);
my @edges;
while (@_) {
my $v = shift;
push @edges, [ $u, $v ];
$u = $v;
}
$g->add_edges_by_id(@edges, $id);
return $g;
}
sub add_weighted_path_by_id {
&expect_multiedged;
my ($g, $u, $id) = (shift, shift, pop);
while (@_) {
my ($w, $v) = splice @_, 0, 2;
$g->set_edge_attribute_by_id($u, $v, $id, $defattr, $w);
$u = $v;
}
}
sub get_edge_weight_by_id {
&expect_multiedged;
push @_, $defattr;
goto &get_edge_attribute_by_id;
}
sub has_edge_weight_by_id {
&expect_multiedged;
push @_, $defattr;
goto &has_edge_attribute_by_id;
}
sub set_edge_weight_by_id {
&expect_multiedged;
push @_, $defattr, pop;
goto &set_edge_attribute_by_id;
}
sub delete_edge_weight_by_id {
&expect_multiedged;
push @_, $defattr;
goto &delete_edge_attribute_by_id;
}
###
# 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); # uncoverable statement
die "$caller1[3]: expected $exp graph$got, at $caller1[1] line $caller1[2].\n"; # uncoverable statement
}
}
sub expect_no_args {
my $g = shift;
return unless @_;
my @caller1 = caller(1); # uncoverable statement
die "$caller1[3]: expected no arguments, got " . scalar @_ . ", at $caller1[1] line $caller1[2]\n"; # uncoverable statement
}
sub expect_undirected {
_expected('undirected') unless &is_undirected;
}
sub expect_directed {
_expected('directed') unless &is_directed;
}
sub expect_acyclic {
_expected('acyclic') unless &is_acyclic;
}
sub expect_dag {
my @got;
push @got, 'undirected' unless &is_directed;
push @got, 'cyclic' unless &is_acyclic;
_expected('directed acyclic', "@got") if @got;
}
sub expect_hyperedged {
_expected('hyperedged') unless &is_hyperedged;
}
sub expect_multivertexed {
_expected('multivertexed') unless &is_multivertexed;
}
*expect_multivertex = \&expect_multivertexed;
sub expect_non_multivertexed {
_expected('non-multivertexed') if &is_multivertexed;
}
*expect_non_multivertex = \&expect_non_multivertexed;
sub expect_non_multiedged {
_expected('non-multiedged') if &is_multiedged;
}
*expect_non_multiedge = \&expect_non_multiedged;
sub expect_multiedged {
_expected('multiedged') unless &is_multiedged;
}
*expect_multiedge = \&expect_multiedged;
sub expect_non_unionfind {
_expected('non-unionfind') if &has_union_find;
}
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"; # uncoverable statement
}
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 : do { require List::Util; \&List::Util::shuffle };
}
sub random_graph {
my $class = (@_ % 2) == 0 ? 'Graph' : shift;
my %opt = _get_options( \@_ );
__carp_confess "Graph::random_graph: argument 'vertices' missing or undef"
unless defined $opt{vertices};
__carp_confess "Graph::random_graph: both arguments 'edges' and 'edges_fill' specified"
if exists $opt{edges} && exists $opt{edges_fill};
srand delete $opt{random_seed} if exists $opt{random_seed};
my $random_edge = delete $opt{random_edge};
my @V;
if (my $ref = ref $opt{vertices}) {
__carp_confess "Graph::random_graph: argument 'vertices' illegal"
if $ref ne 'ARRAY';
@V = @{ $opt{vertices} };
} else {
@V = 0..($opt{vertices} - 1);
}
delete $opt{vertices};
my $V = @V;
my $C = $V * ($V - 1) / 2;
my $E = exists $opt{edges_fill} ? $opt{edges_fill} * $C : $opt{edges};
delete @opt{qw(edges 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;
__carp_confess "Graph::random_graph: needs to be countedged or multiedged ($E > $C)"
if $p > 1.0 && !($g->countedged || $g->multiedged);
# Shuffle the vertex lists so that the pairs at
# the beginning of the lists are not more likely.
my @V1 = _shuffle @V;
my @V2 = _shuffle @V;
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;
}
}
}
}
$g;
}
sub random_vertex {
my @V = &_vertices05;
@V[rand @V];
}
sub random_edge {
my @E = &_edges05;
@E[rand @E];
}
sub random_successor {
my @S = &successors;
@S[rand @S];
}
sub random_predecessor {
my @P = &predecessors;
@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), $_ ],
&_edges05;
}
sub MST_Kruskal {
&expect_undirected;
my ($g, %attr) = @_;
require Graph::UnionFind;
my $MST = Graph->new(directed => 0);
my $UF = Graph::UnionFind->new;
$UF->add(&_vertices05);
my @edges;
for my $e ($g->_MST_edges(\%attr)) {
my ($u, $v) = @$e; # TODO: hyperedges
next if $UF->same( @$e );
$UF->union([$u, $v]);
push @edges, [ $u, $v ];
}
$MST->add_edges(@edges);
return $MST;
}
sub _MST_add {
my ($g, $h, $HF, $r, $attr, $unseen) = @_;
$HF->add( Graph::MSTHeapElem->new( $r, $_, $g->get_edge_attribute( $r, $_, $attr ) ) )
for grep exists $unseen->{ $_ }, $g->successors( $r );
}
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, @args) = @_;
my %opt = @args == 1 ? ( first_root => $args[0] ) : _get_options( \@args );
my %unseen;
my @unseen = $g->_vertices05;
@unseen{ @unseen } = @unseen;
@unseen = _shuffle @unseen;
my $r;
if (exists $opt{ start }) {
$opt{ first_root } = delete $opt{ start };
$opt{ next_root } = undef;
}
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, $opt, $unseenh, $unseena, $r, $next, $code, $attr) = @_;
require Heap::Fibonacci;
my $HF = Heap::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;
last unless defined $r;
}
return $h;
}
sub MST_Prim {
&expect_undirected;
require Graph::MSTHeapElem;
$_[0]->_heap_walk(Graph->new(directed => 0), \&_MST_add, undef, &_root_opt);
}
*MST_Dijkstra = \&MST_Prim;
*minimum_spanning_tree = \&MST_Prim;
###
# Cycle detection.
#
*is_cyclic = \&has_a_cycle;
sub is_acyclic {
!&is_cyclic;
}
sub is_dag {
&is_directed && &is_acyclic ? 1 : 0;
}
*is_directed_acyclic_graph = \&is_dag;
###
# Simple DFS uses.
#
sub topological_sort {
my $g = shift;
my %opt = _get_options( \@_ );
my $eic = delete $opt{ empty_if_cyclic };
my $hac;
if ($eic) {
$hac = $g->has_a_cycle;
} else {
$g->expect_dag;
}
require Graph::Traversal::DFS;
my $t = Graph::Traversal::DFS->new($g, %opt);
my @s = $t->dfs;
$hac ? () : reverse @s;
}
*toposort = \&topological_sort;
sub _copy_vertices {
my ($g, $gc, $attr_too) = @_;
if (&is_multivertexed) {
for my $v (&_vertices05) {
if ($attr_too) {
$gc->set_vertex_attributes_by_id($v, $_, $g->get_vertex_attributes_by_id($v, $_))
for $g->get_multivertex_ids($v);
} else {
$gc->add_vertex_by_id($v, $_) for $g->get_multivertex_ids($v);
}
}
} else {
if ($attr_too) {
$gc->set_vertex_attributes($_, $g->get_vertex_attributes($_)) for &_vertices05;
} else {
$gc->add_vertices(&_vertices05);
}
}
}
sub _copy_edges {
my ($g, $gc, $attr_too, $mirror) = @_;
my @edges = &_edges05;
if (&is_multiedged) {
for my $e (@edges) {
for my $id ($g->get_multiedge_ids(@$e)) {
if ($attr_too) {
$gc->set_edge_attributes_by_id(@$e, $id, $g->get_edge_attributes_by_id(@$e, $id));
$gc->set_edge_attributes_by_id(reverse(@$e), $id, $g->get_edge_attributes_by_id(@$e, $id)) if $mirror;
} else {
$gc->add_edge_by_id(@$e, $id);
$gc->add_edge_by_id(reverse(@$e), $id) if $mirror;
}
}
}
} else {
if ($attr_too) {
$gc->set_edge_attributes(@$_, $g->get_edge_attributes(@$_))
for @edges;
if ($mirror) {
$gc->set_edge_attributes(reverse(@$_), $g->get_edge_attributes(@$_))
for @edges;
}
} else {
$gc->add_edges(@edges, !$mirror ? () : map [reverse @$_], @edges);
}
}
}
sub undirected_copy {
&expect_directed;
my $gc = $_[0]->new(undirected=>1);
_copy_vertices($_[0], $gc);
_copy_edges($_[0], $gc);
$gc;
}
*undirected_copy_graph = \&undirected_copy;
sub undirected_copy_attributes {
&expect_directed;
my $gc = $_[0]->new(undirected=>1);
$gc->set_graph_attributes($_[0]->get_graph_attributes);
_copy_vertices($_[0], $gc, 1);
_copy_edges($_[0], $gc, 1);
$gc;
}
sub directed_copy {
&expect_undirected;
my $gc = $_[0]->new(undirected=>0);
_copy_vertices($_[0], $gc);
_copy_edges($_[0], $gc, 0, 1);
$gc;
}
*directed_copy_graph = \&directed_copy;
sub directed_copy_attributes {
&expect_undirected;
my $gc = $_[0]->new(directed=>1);
$gc->set_graph_attributes($_[0]->get_graph_attributes);
_copy_vertices($_[0], $gc, 1);
_copy_edges($_[0], $gc, 1, 1);
$gc;
}
sub is_bipartite {
&expect_undirected;
my ($g) = @_;
my $is_bipartite = 1;
my %colors;
my $operations = {
tree_edge => sub {
my( $seen, $unseen ) = @_;
( $seen, $unseen ) = sort { exists $colors{$b} <=> exists $colors{$a} } ( $seen, $unseen );
$colors{$seen} ||= -1;
$colors{$unseen} = -$colors{$seen};
},
non_tree_edge => sub {
$is_bipartite = '' if $colors{$_[0]} == $colors{$_[1]};
},
};
require Graph::Traversal::DFS;
Graph::Traversal::DFS->new( $g, %$operations )->dfs;
return $is_bipartite;
}
sub is_planar {
&expect_undirected;
my ($g) = @_;
my @paths_at = map [], 1..$g->vertices;
my $path_graph = Graph->new(undirected => 1);
my ($n, $d, %order) = (0, 0);
my $operations = {
pre => sub {
$order{$_[0]} = $n;
$n++;
},
non_tree_edge => sub {
my( $i, $j ) = sort map { $order{$_} } @_[0..1];
for (@{$paths_at[$i]}) { # for all crossed paths
$path_graph->add_edge( $_, $d );
}
for ($i+1..$j-1) {
push @{$paths_at[$_]}, $d;
}
$d++;
},
};
require Graph::Traversal::DFS;
Graph::Traversal::DFS->new( $g, %$operations )->dfs;
return $path_graph->is_bipartite;
}
###
# Cache or not.
#
my %_cache_type =
(
'connectivity' => ['_ccc'],
'strong_connectivity' => ['_scc'],
'weak_connectivity_undirected_graph' => ['_wcug'],
'biconnectivity' => ['_bcc'],
'SPT_Dijkstra' => ['_spt_di', 'SPT_Dijkstra_root'],
'SPT_Bellman_Ford' => ['_spt_bf', 'SPT_Bellman_Ford_root'],
'transitive_closure_matrix' => ['_tcm'],
);
for my $t (keys %_cache_type) {
no strict 'refs';
my @attr = @{ $_cache_type{$t} };
*{$t."_clear_cache"} = sub { $_[0]->delete_graph_attribute($_) for @attr };
}
sub _check_cache {
my ($g, $type, $extra_vals, $code, @args) = @_;
my $c = $_cache_type{$type};
__carp_confess "Graph: unknown cache type '$type'" if !defined $c;
my ($main_key, @extra_keys) = @$c;
__carp_confess "Graph: wrong number of extra values (@extra_keys) vs (@$extra_vals)" if @extra_keys != @$extra_vals;
my $a = $g->get_graph_attribute($main_key);
__carp_confess "$c attribute set to unexpected value $a"
if defined $a and ref $a ne 'ARRAY';
unless (defined $a && $a->[ 0 ] == $g->[ _G ]) {
$g->set_graph_attribute($main_key, $a = [ $g->[ _G ], $code->( $g, @args ) ]);
}
my $i = -1;
my $extra_invalid = grep {
my $v = $a->[ 1 ]->get_graph_attribute($_);
$i++; # here so still incremented even if short-cut
!defined $v or $v ne $extra_vals->[$i];
} @extra_keys;
if ($extra_invalid) {
$g->set_graph_attribute($main_key, $a = [ $g->[ _G ], $code->( $g, @args ) ]);
}
return $a->[ 1 ];
}
###
# Connected components.
#
sub _connected_components_compute {
my $g = $_[0];
my %v2c;
my @c;
return [ [], {} ] unless my @v = $g->unique_vertices;
if (my $UF = &has_union_find) {
my $V = $g->[ _V ];
my @ids = $V->get_ids_by_paths(\@v, 0);
my ($counter, %cc2counter) = 0;
my @cc = $UF->find(@ids);
for (my $i = 0; $i <= $#v; $i++) {
my $cc = $cc[$i];
__carp_confess "connected_component union-find did not have vertex '$v[$i]', please report"
if !defined $cc;
$cc2counter{$cc} = $counter++ if !exists $cc2counter{$cc};
my $ci = $cc2counter{$cc};
$v2c{ $v[$i] } = $ci;
push @{ $c[$ci] }, $v[$i];
}
} else {
require Graph::Traversal::DFS;
my %r; @r{ @v } = @v;
@c = [];
my $t = Graph::Traversal::DFS->new(
$g,
first_root => sub { (each %r)[1] },
next_root => sub { push @c, [] if keys %r; (each %r)[1]; },
pre => sub {
my ($v, $t) = @_;
$v2c{ $v } = $#c;
push @{ $c[-1] }, $v;
delete $r{ $v };
},
@_[1..$#_]
);
$t->dfs;
}
return [ \@c, \%v2c ];
}
sub _connected_components {
my $ccc = _check_cache($_[0], 'connectivity', [],
\&_connected_components_compute);
return @{ $ccc };
}
sub connected_component_by_vertex {
&expect_undirected;
(&_connected_components)[1]->{ $_[1] };
}
sub connected_component_by_index {
&expect_undirected;
my $value = (&_connected_components)[0]->[$_[1]];
$value ? @{ $value || _empty_array } : ();
}
sub connected_components {
&expect_undirected;
@{ (&_connected_components)[0] };
}
sub same_connected_components {
&expect_undirected;
my ($g, @args) = @_;
my @components;
if (my $UF = &has_union_find) {
my @ids = &_vertex_ids;
return 0 if @ids != @args;
@components = $UF->find(@ids);
} else {
@components = @{ (&_connected_components)[1] }{ @args };
}
return 0 if grep !defined, @components;
require List::Util;
List::Util::uniq( @components ) == 1;
}
sub _super_component { join("+", sort @_) }
sub connected_graph {
&expect_undirected;
my ($g, %opt) = @_;
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 = $opt{super_component} || \&_super_component;
$cg->set_vertex_attribute(scalar $sc_cb->(@$_), 'subvertices', $_)
for $g->connected_components;
}
return $cg;
}
sub is_connected {
&expect_undirected;
return @{ (&_connected_components)[0] } == 1;
}
sub is_weakly_connected {
&expect_directed;
splice @_, 0, 1, &undirected_copy;
goto &is_connected;
}
*weakly_connected = \&is_weakly_connected;
# because recreating undirected copy every time has different hash ordering
# so weakly_connected_component_by_index etc would be unstable
sub _weakly_connected_undir_graph {
_check_cache($_[0], 'weak_connectivity_undirected_graph', [],
\&undirected_copy);
}
sub weakly_connected_components {
&expect_directed;
splice @_, 0, 1, &_weakly_connected_undir_graph;
goto &connected_components;
}
sub weakly_connected_component_by_vertex {
&expect_directed;
splice @_, 0, 1, &_weakly_connected_undir_graph;
goto &connected_component_by_vertex;
}
sub weakly_connected_component_by_index {
&expect_directed;
splice @_, 0, 1, &_weakly_connected_undir_graph;
goto &connected_component_by_index;
}
sub same_weakly_connected_components {
&expect_directed;
splice @_, 0, 1, &_weakly_connected_undir_graph;
goto &same_connected_components;
}
sub weakly_connected_graph {
&expect_directed;
splice @_, 0, 1, &_weakly_connected_undir_graph;
goto &connected_graph;
}
sub _strongly_connected_components_compute {
my $g = $_[0];
require Graph::Traversal::DFS;
require List::Util;
my $t = Graph::Traversal::DFS->new($g);
my @d = reverse $t->dfs;
my @c;
my %v2c;
my $u = Graph::Traversal::DFS->new(
$g->transpose_graph,
next_root => sub {
my ($t, $u) = @_;
return if !defined(my $root = List::Util::first(
sub { exists $u->{$_} }, @d
));
push @c, [];
return $root;
},
pre => sub {
my ($v, $t) = @_;
push @{ $c[-1] }, $v;
$v2c{$v} = $#c;
},
next_alphabetic => 1,
);
$u->dfs;
return [ \@c, \%v2c ];
}
sub _strongly_connected_components_v2c {
&_strongly_connected_components->[1];
}
sub _strongly_connected_components_arrays {
@{ &_strongly_connected_components->[0] };
}
sub _strongly_connected_components {
_check_cache($_[0], 'strong_connectivity', [],
\&_strongly_connected_components_compute);
}
sub strongly_connected_components {
&expect_directed;
goto &_strongly_connected_components_arrays;
}
sub strongly_connected_component_by_vertex {
&expect_directed;
&_strongly_connected_components_v2c->{$_[1]};
}
sub strongly_connected_component_by_index {
&expect_directed;
my $i = $_[1];
return if !defined(my $c = &_strongly_connected_components->[0][ $i ]);
@$c;
}
sub same_strongly_connected_components {
&expect_directed;
my ($g, @args) = @_;
require Set::Object;
Set::Object->new(@{ &_strongly_connected_components_v2c }{@args})->size <= 1;
}
sub is_strongly_connected {
&strongly_connected_components == 1;
}
*strongly_connected = \&is_strongly_connected;
sub strongly_connected_graph {
&expect_directed;
my ($g, %attr) = @_;
my $sc_cb = \&_super_component;
_opt_get(\%attr, super_component => \$sc_cb);
_opt_unknown(\%attr);
my ($c, $v2c) = @{ &_strongly_connected_components };
my $s = Graph->new;
my @s = map $sc_cb->(@$_), @$c;
$s->set_vertex_attribute($s[$_], 'subvertices', $c->[$_]) for 0..$#$c;
require List::Util;
$s->add_edges(map [@s[ @$v2c{ @$_ } ]], grep List::Util::uniq( @$v2c{ @$_ } ) > 1, &_edges05);
return $s;
}
###
# Biconnectivity.
#
sub _biconnectivity_out {
my ($state, $u, $v) = @_;
my @BC;
while (@{$state->{stack}}) {
push @BC, my $e = pop @{$state->{stack}};
last if $e->[0] eq $u && $e->[1] eq $v;
}
push @{$state->{BC}}, \@BC if @BC;
}
sub _biconnectivity_dfs {
my ($E, $u, $state) = @_;
$state->{low}{$u} = $state->{num}{$u} = $state->{dfs}++;
for my $v ($E->successors($u)) {
if (!exists $state->{num}{$v}) {
push @{$state->{stack}}, [$u, $v];
$state->{pred}{$v} = $u;
_biconnectivity_dfs($E, $v, $state);
$state->{low}{$u} = List::Util::min(@{ $state->{low} }{$u, $v});
_biconnectivity_out($state, $u, $v)
if $state->{low}{$v} >= $state->{num}{$u};
} elsif (defined $state->{pred}{$u} &&
$state->{pred}{$u} ne $v &&
$state->{num}{$v} < $state->{num}{$u}) {
push @{$state->{stack}}, [$u, $v];
$state->{low}{$u} = List::Util::min($state->{low}{$u}, $state->{num}{$v});
}
}
}
sub _biconnectivity_compute {
require List::Util;
my ($g) = @_;
my ($V, $E) = @$g[ _V, _E ];
my %state = (BC=>[], dfs=>0);
my @u = $V->ids;
for my $u (@u) {
next if exists $state{num}->{$u};
_biconnectivity_dfs($E, $u, \%state);
push @{$state{BC}}, delete $state{stack} if @{ $state{stack} || _empty_array };
}
# Mark the components each vertex belongs to.
my ($bci, %v2bc, %bc2v) = 0;
for my $bc (@{$state{BC}}) {
$v2bc{$_}{$bci} = undef for map @$_, @$bc;
$bci++;
}
# Any isolated vertices get each their own component.
$v2bc{$_}{$bci++} = undef for grep !exists $v2bc{$_}, @u;
# build vector now we know how big to make it
my ($Z, %v2bc_vec, @ap) = "\0" x (($bci + 7) / 8);
@v2bc_vec{@u} = ($Z) x @u;
for my $v (@u) {
my @components = keys %{ $v2bc{$v} };
vec($v2bc_vec{$v}, $_, 1) = 1 for @components;
$bc2v{$_}{$v}{$_} = undef for @components;
# Articulation points / cut vertices are the vertices
# which belong to more than one component.
push @ap, $v if @components > 1;
}
# Bridges / cut edges are the components of two vertices.
my @br = grep @$_ == 2, map [keys %$_], values %bc2v;
# Create the subgraph components.
my @sg = map [ List::Util::uniq( map @$_, @$_ ) ], @{$state{BC}};
my ($apdeep, $sgv, $brv) = $V->get_paths_by_ids([[\@ap], \@sg, \@br], 1);
return [ @$apdeep, $sgv, $brv, \%v2bc, \%v2bc_vec, $Z ];
}
sub biconnectivity {
&expect_undirected;
@{ _check_cache($_[0], 'biconnectivity', [],
\&_biconnectivity_compute, @_[1..$#_]) || _empty_array };
}
sub is_biconnected {
&edges >= 2 ? @{ (&biconnectivity)[0] } == 0 : undef ;
}
sub is_edge_connected {
&edges >= 2 ? @{ (&biconnectivity)[2] } == 0 : undef;
}
sub is_edge_separable {
&edges >= 2 ? @{ (&biconnectivity)[2] } > 0 : undef;
}
sub articulation_points {
@{ (&biconnectivity)[0] };
}
*cut_vertices = \&articulation_points;
sub biconnected_components {
@{ (&biconnectivity)[1] };
}
sub biconnected_component_by_index {
my ($i) = splice @_, 1, 1;
(&biconnectivity)[1]->[ $i ];
}
sub biconnected_component_by_vertex {
my ($v) = splice @_, 1, 1;
my $v2bc = (&biconnectivity)[3];
splice @_, 1, 0, $v;
my $V = $_[0]->[ _V ];
($v) = $V->get_ids_by_paths([$v]);
return defined $v2bc->{ $v } ? keys %{ $v2bc->{ $v } } : ();
}
sub same_biconnected_components {
my ($v2bc, $Z) = (&biconnectivity)[4,5];
my $V = $_[0]->[ _V ];
my @vs = $V->get_ids_by_paths([@_[1..$#_]]);
return 0 if grep !defined, my @vecs = @$v2bc{ @vs };
my $accumulator = $vecs[0];
$accumulator &= $_ for @vecs[1..$#vecs]; # accumulate 0s -> all in same
$accumulator ne $Z;
}
sub biconnected_graph {
my ($g, %opt) = @_;
my $bc = (&biconnectivity)[1];
my $bcg = Graph->new(directed => 0);
my $sc_cb = $opt{super_component} || \&_super_component;
my @s = map $sc_cb->(@$_), @$bc;
$bcg->set_vertex_attribute($s[$_], 'subvertices', $bc->[$_]) for 0..$#$bc;
my @edges;
for my $i (0..$#$bc) {
my @u = @{ $bc->[ $i ] };
for my $j (0..$i-1) {
my %j; @j{ @{ $bc->[ $j ] } } = ();
next if !grep exists $j{ $_ }, @u;
push @edges, [ @s[$i, $j] ];
}
}
$bcg->add_edges(@edges);
return $bcg;
}
sub bridges {
@{ (&biconnectivity)[2] || _empty_array };
}
###
# 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) = sort {$a<=>$b} $g->get_edge_attribute_all($r, $s, $attr);
$t = 1 unless defined $t;
__carp_confess "Graph::SPT_Dijkstra: edge $r-$s is negative ($t)"
if $t < 0;
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_attributes($s, { $attr=>$etc->{ $s }, 'p', $r });
$HF->add( Graph::SPTHeapElem->new($r, $s, $etc->{ $s }) );
}
}
}
sub _SPT_Dijkstra_compute {
require Graph::SPTHeapElem;
my $sptg = $_[0]->_heap_walk($_[0]->new(multiedged=>0), \&_SPT_add, {}, @_[1..$#_]);
$sptg->set_graph_attribute('SPT_Dijkstra_root', $_[4]);
$sptg;
}
sub SPT_Dijkstra {
my $g = $_[0];
my @args = &_root_opt;
_check_cache($g, 'SPT_Dijkstra', [$args[3]],
\&_SPT_Dijkstra_compute, @args);
}
*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);
require Set::Object;
my $seen = Set::Object->new;
my $V = $g->vertices;
my $p;
while (defined($p = $sptg->get_vertex_attribute($v, 'p'))) {
last if $seen->contains($p);
push @path, $p;
$v = $p;
$seen->insert($p);
last if $seen->size == $V || $u eq $v;
}
return if !@path or $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) = sort {$a<=>$b} $g->get_edge_attribute_all($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);
__SPT_Bellman_Ford($g, $v, $u, $attr, \%d, \%p, \%c0, \%c1)
if $g->undirected;
}
%c0 = %c1 unless $i == $V - 1;
}
for my $e ($g->edges) {
my ($u, $v) = @$e;
if (defined $d{ $u } && defined $d{ $v }) {
my ($d) = sort {$a<=>$b} $g->get_edge_attribute_all($u, $v, $attr);
__carp_confess "Graph::SPT_Bellman_Ford: negative cycle exists"
if defined $d && $d{ $v } > $d{ $u } + $d;
}
}
return (\%p, \%d);
}
sub _SPT_Bellman_Ford_compute {
my ($g, @args) = @_;
my ($p, $d) = $g->_SPT_Bellman_Ford(@args);
my $h = $g->new(multiedged=>0);
for my $v (keys %$p) {
my $u = $p->{ $v };
my ($w) = sort {$a<=>$b} $g->get_edge_attribute_all($u, $v, $args[6]);
$h->set_edge_attribute( $u, $v, $args[6], $w);
$h->set_vertex_attributes( $v, { $args[6], $d->{ $v }, p => $u } );
}
$h->set_graph_attribute('SPT_Bellman_Ford_root', $args[3]);
$h;
}
sub SPT_Bellman_Ford {
my @args = &_root_opt;
_check_cache($_[0], 'SPT_Bellman_Ford', [$args[3]],
\&_SPT_Bellman_Ford_compute, @args);
}
*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);
require Set::Object;
my $seen = Set::Object->new;
my $V = $g->vertices;
my $p;
while (defined($p = $sptg->get_vertex_attribute($v, 'p'))) {
last if $seen->contains($p);
push @path, $p;
$v = $p;
$seen->insert($p);
last if $seen->size == $V;
}
# @path = () if @path && "$path[-1]" ne "$u";
return reverse @path;
}
###
# Transitive Closure.
#
sub TransitiveClosure_Floyd_Warshall {
my $self = shift;
require Graph::TransitiveClosure;
Graph::TransitiveClosure->new($self, @_);
}
*transitive_closure = \&TransitiveClosure_Floyd_Warshall;
sub APSP_Floyd_Warshall {
my $self = shift;
require Graph::TransitiveClosure;
Graph::TransitiveClosure->new($self, path => 1, @_);
}
*all_pairs_shortest_paths = \&APSP_Floyd_Warshall;
sub _transitive_closure_matrix_compute {
&APSP_Floyd_Warshall->transitive_closure_matrix;
}
sub transitive_closure_matrix {
_check_cache($_[0], 'transitive_closure_matrix', [],
\&_transitive_closure_matrix_compute, @_[1..$#_]);
}
sub path_length {
shift->transitive_closure_matrix->path_length(@_);
}
sub path_successor {
shift->transitive_closure_matrix->path_successor(@_);
}
sub path_vertices {
shift->transitive_closure_matrix->path_vertices(@_);
}
sub all_paths {
shift->transitive_closure_matrix->all_paths(@_);
}
sub is_reachable {
shift->transitive_closure_matrix->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) {
$c->($t, $u, $_, ++$n) for grep $t->is_reachable($u, $_), @v;
}
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) {
return wantarray ? $t->path_vertices($u, $v) : $t->path_length($u, $v)
if defined $v;
my $max;
my @max;
for my $v (grep $u ne $_, $g->vertices) {
my $l = $t->path_length($u, $v);
next if !(defined $l && (!defined $max || $l > $max));
$max = $l;
@max = $t->path_vertices($u, $v);
}
return wantarray ? @max : $max;
}
if (defined $v) {
my $max;
my @max;
for my $u (grep $_ ne $v, $g->vertices) {
my $l = $t->path_length($u, $v);
next if !(defined $l && (!defined $max || $l > $max));
$max = $l;
@max = $t->path_vertices($u, $v);
}
return wantarray ? @max : @max - 1;
}
my ($min, $max, $minp, $maxp) = $g->_minmax_path(@_);
return defined $maxp ? (wantarray ? @$maxp : $max) : undef;
}
sub vertex_eccentricity {
&expect_undirected;
my ($g, $u) = @_;
return Infinity() if !&is_connected;
my $max;
for my $v (grep $u ne $_, $g->vertices) {
my $l = $g->path_length($u, $v);
next if !(defined $l && (!defined $max || $l > $max));
$max = $l;
}
return defined $max ? $max : Infinity();
}
sub shortest_path {
&expect_undirected;
my ($g, $u, $v) = @_;
my $t = $g->transitive_closure_matrix;
if (defined $u) {
return wantarray ? $t->path_vertices($u, $v) : $t->path_length($u, $v)
if defined $v;
my $min;
my @min;
for my $v (grep $u ne $_, $g->vertices) {
my $l = $t->path_length($u, $v);
next if !(defined $l && (!defined $min || $l < $min));
$min = $l;
@min = $t->path_vertices($u, $v);
}
# print "min/1 = @min\n";
return wantarray ? @min : $min;
}
if (defined $v) {
my $min;
my @min;
for my $u (grep $_ ne $v, $g->vertices) {
my $l = $t->path_length($u, $v);
next if !(defined $l && (!defined $min || $l < $min));
$min = $l;
@min = $t->path_vertices($u, $v);
}
# print "min/2 = @min\n";
return wantarray ? @min : $min;
}
my ($min, $max, $minp, $maxp) = $g->_minmax_path(@_);
return if !defined $minp;
wantarray ? @$minp : $min;
}
sub radius {
&expect_undirected;
my $g = shift;
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 {
&expect_undirected;
my ($g, $delta) = @_;
$delta = 0 unless defined $delta;
$delta = abs($delta);
my @c;
my $Inf = Infinity();
my $r = $g->radius;
if (defined $r && $r != $Inf) {
for my $v ($g->vertices) {
my $e = $g->vertex_eccentricity($v);
next unless defined $e && $e != $Inf;
push @c, $v if abs($e - $r) <= $delta;
}
}
return @c;
}
*centre_vertices = \¢er_vertices;
sub average_path_length {
my $g = shift;
my @A = @_;
my $d = 0;
my $m = 0;
$g->for_shortest_paths(sub {
my ($t, $u, $v, $n) = @_;
return unless my $l = $t->path_length($u, $v);
return if defined $A[0] && $u ne $A[0];
return if defined $A[1] && $v ne $A[1];
$d += $l;
$m++;
});
return $m ? $d / $m : undef;
}
###
# Simple tests.
#
sub is_multi_graph {
return 0 unless &is_multiedged || &is_countedged;
my $g = $_[0];
my $multiedges = 0;
for my $e (&_edges05) {
my ($u, @v) = @$e;
return 0 if grep $u eq $_, @v;
$multiedges++ if $g->get_edge_count(@$e) > 1;
}
return $multiedges;
}
sub is_simple_graph {
return 1 unless &is_multiedged || &is_countedged;
my $g = $_[0];
return 0 if grep $g->get_edge_count(@$_) > 1, &_edges05;
return 1;
}
sub is_pseudo_graph {
my $m = &is_countedged || &is_multiedged;
my $g = $_[0];
for my $e (&_edges05) {
my ($u, @v) = @$e;
return 1 if grep $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);
__carp_confess "factorial of a negative number" if $n < 0;
__factorial($n) unless exists $_factorial{$n};
return $_factorial{$n};
}
sub could_be_isomorphic {
my ($g0, $g1) = @_;
return 0 unless &vertices == $g1->vertices;
return 0 unless &_edges05 == $g1->_edges05;
my %d0;
$d0{ $g0->in_degree($_) }{ $g0->out_degree($_) }++ for &vertices;
my %d1;
$d1{ $g1->in_degree($_) }{ $g1->out_degree($_) }++ for $g1->vertices;
return 0 unless keys %d0 == keys %d1;
for my $da (keys %d0) {
return 0
unless exists $d1{$da} &&
keys %{ $d0{$da} } == keys %{ $d1{$da} };
return 0
if grep !(exists $d1{$da}{$_} && $d0{$da}{$_} == $d1{$da}{$_}),
keys %{ $d0{$da} };
}
for my $da (keys %d0) {
return 0 if grep $d1{$da}{$_} != $d0{$da}{$_}, keys %{ $d0{$da} };
delete $d1{$da};
}
return 0 unless keys %d1 == 0;
my $f = 1;
for my $da (keys %d0) {
$f *= _factorial(abs($d0{$da}{$_})) for keys %{ $d0{$da} };
}
return $f;
}
###
# Analysis functions.
sub subgraph_by_radius {
$_[0]->subgraph([ @_[1..$#_-1], &reachable_by_radius ]);
}
sub clustering_coefficient {
my ($g) = @_;
return unless my @v = $g->vertices;
require Set::Object;
my %clustering;
my $gamma = 0;
for my $n (@v) {
my $gamma_v = 0;
my @neigh = $g->successors($n);
my $c = Set::Object->new;
for my $u (@neigh) {
for my $v (grep +(!$c->contains("$u-$_") && $g->has_edge($u, $_)), @neigh) {
$gamma_v++;
$c->insert("$u-$v");
$c->insert("$v-$u");
}
}
if (@neigh > 1) {
$clustering{$n} = $gamma_v/(@neigh * (@neigh - 1) / 2);
$gamma += $gamma_v/(@neigh * (@neigh - 1) / 2);
} else {
$clustering{$n} = 0;
}
}
$gamma /= @v;
return wantarray ? ($gamma, %clustering) : $gamma;
}
sub betweenness {
my $g = shift;
my @V = $g->vertices();
my %Cb; # C_b{w} = 0
@Cb{@V} = ();
for my $s (@V) {
my @S; # stack (unshift, shift)
my %P; # P{w} = empty list
$P{$_} = [] for @V;
my %sigma; # \sigma{t} = 0
$sigma{$_} = 0 for @V;
$sigma{$s} = 1;
my %d; # d{t} = -1;
$d{$_} = -1 for @V;
$d{$s} = 0;
my @Q; # queue (push, shift)
push @Q, $s;
while (@Q) {
my $v = shift @Q;
unshift @S, $v;
for my $w ($g->successors($v)) {
# w found for first time
if ($d{$w} < 0) {
push @Q, $w;
$d{$w} = $d{$v} + 1;
}
# Shortest path to w via v
if ($d{$w} == $d{$v} + 1) {
$sigma{$w} += $sigma{$v};
push @{ $P{$w} }, $v;
}
}
}
my %delta;
$delta{$_} = 0 for @V;
while (@S) {
my $w = shift @S;
$delta{$_} += $sigma{$_}/$sigma{$w} * (1 + $delta{$w})
for @{ $P{$w} };
$Cb{$w} += $delta{$w} if $w ne $s;
}
}
return %Cb;
}
sub connected_subgraphs {
my $g = shift;
require Set::Object;
my @subgraphs = ( [ map { Set::Object->new($_) } $g->vertices ] );
for (2..scalar $g->vertices) {
my %seen;
for my $subgraph (@{$subgraphs[-1]}) {
for my $neighbour ((Set::Object->new( map { $g->neighbours($_) } $subgraph->members ) - $subgraph)->members) {
my $new_subgraph = Set::Object->new($subgraph->members, $neighbour);
my $key = join '|', @$new_subgraph;
next if exists $seen{$key};
$seen{$key} = $new_subgraph;
}
}
push @subgraphs, [values %seen];
}
return map { $g->subgraph([$_->members]) } map { @$_ } @subgraphs;
}
1;