diff --git a/perllib/Graph.pm b/perllib/Graph.pm deleted file mode 100644 index 3d1ad336..00000000 --- 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' => \≠ - -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 = \°ree; - -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 = \© - -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 = \¢er_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 9452d51d..00000000 --- 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 any sort of I, business or -otherwise. - -=head2 Description - -Instead, this module is for creating I -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 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 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 parameter -to use the so-called union-find scheme to speed up the computation of -I of the graph (see L, -L, L, -L, and L). -If C 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. -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. (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 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. - -A vertex is also known as a I. - -Adding C as vertex is not allowed. - -Note that unless you have isolated vertices (or I -vertices), you do not need to explicitly use C since -L 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. - -An edge is also known as an I. - -=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 or I -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 or I -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 or I -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 or I -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 -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 -operator and the method - -=over 4 - -=item ne - - $g->ne("a-b,a-c,d") - -=back - -See also L. - -=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 This does not I cycles, see L and -L. - -=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: 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.) - -To find at least that one cycle, see L. - -=item is_acyclic - -Return true if the graph is acyclic (does not contain any cycles). - -=back - -To find a cycle, use L. - -=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 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 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 - -=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 parameter, -the time complexity is (essentially) O(V), otherwise O(V log V). - -See also L, L, -L, and L, -and L. - -For directed graphs, see L -and L. - -=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 -and L. - -=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. - -If the graph has been created with a true C parameter, -the time complexity is (essentially) O(1), otherwise O(V log V). - -See also L. - -For directed graphs, see L -and L. - -=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. - -For directed graphs, see L -and L. - -=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 parameter, -the time complexity is (essentially) O(1), otherwise O(V log V). - -For directed graphs, see L -and L. - -=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. - -See L 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. - -For directed graphs, see L -and L. - -=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 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. - -=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. - -For undirected graphs, see L, or L. - -=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. - -See also L. - -For undirected graphs, see L or -L. - -=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. - -For undirected graphs, see L. - -=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. - -For undirected graphs, see L or -L. - -=item strong_connectivity_clear_cache - - $g->strong_connectivity_clear_cache - -See L. - -=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 graph. - -See also L. - -For undirected graphs, see L or L. - -=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. - -For undirected graphs, see L or -L. - -=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. - -For undirected graphs, see L -and L. - -=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. - -For undirected graphs, see L -and L. - -=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 and L. - -=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. - -For undirected graphs, see L, -or see L. - -=item strongly_connected_graph - - my $scg = $g->strongly_connected_graph; - -See L for further discussion. - -Strongly connected graphs are also known as I. - -See also L. - -For undirected graphs, see L, or L. - -=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 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 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. - -=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 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 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 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 for the definition of a self-loop vertex. - -=back - -=head2 Connected Graphs and Their Components - -In this discussion I refers to any of -I, I, and I. - -B: if the vertices of the original graph are Perl objects, -(in other words, references, so you must be using C) -the vertices of the I 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 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 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) 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. - -=head2 Counted Vertices - -I are vertices with more than one instance, normally -adding vertices is idempotent. To enable counted vertices on a graph, -give the C 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 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, 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, or I, if that sounds -more familiar. - -The stronger kind is called (true) I, 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, for which you can test with C. - -B: The various graph algorithms do not in general work well with -multigraphs (they often assume I, 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 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 to trap that, or supply the C -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). - -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 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). - -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 vertices and then remove the predecessor vertex.) - -If you want to find the shortest path between two vertices, -see L. - -=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. - -=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). - -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 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). - -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 vertices and then remove the predecessor vertex.) - -If you want to find the shortes path between two vertices, -see L. - -=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. - -=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 is assumed. - -B - -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 path length over all -the vertex pairs of the graph. In list context return the vertices -along a I 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. - -=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 path over all the vertex pairs is known as the -I. See also L. - -=item center_vertices - -=item centre_vertices - - my @c = $g->center_vertices; - my @c = $g->center_vertices($delta); - -The I is the set of vertices for which the I is equal to the I. 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. -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, L, -L, L, -L, L, L, -L, L, -L, L, -L. - -=item * - -biconnectivity_clear_cache - -Affects L, -L, -L, L, -L, L, L, -L, L, -L, L. - -=item * - -strong_connectivity_clear_cache - -Affects L, -L, -L, -L, L, -L, L. - -=item * - -SPT_Dijkstra_clear_cache - -Affects L, L, L, -L. - -=item * - -SPT_Bellman_Ford_clear_cache - -Affects L, L, L. - -=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 contain the C -argument - - vertices => vertices_def - -where the I 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 or the argument -C. Both are used to define how many random edges to -add to the graph; C is an absolute number, while C -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 nor C is specified, an C -of 0.5 is assumed. - -If you want repeatable randomness (what is an oxymoron?) -you can use the C 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 option: - - $g = Graph->random_graph(vertices => 10, random_edge => \&d); - -where C 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 -or C 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 - -=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: 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 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: 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: 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 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: 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: 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 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 means that they are structurally the -same graph, the difference being that the vertices might have been -I or I. For example in the below example $g0 -and $g1 are isomorphic: the vertices C have been renamed as -C. - - $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, 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 at whether two graphs B 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 and I -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 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 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: 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: 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 -and C attributes: - - my $h = Graph->new(hyperedged => 1, hypervertexed => 1); - -To add hypervertexes, either explicitly use more than one vertex (or, -indeed, I 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 and C -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 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 - -If you want to continue using these (mis)features you can use the -C 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 -(see L) 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 - -=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 d2245da6..00000000 --- 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 - -=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 - -=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 262bd4f5..00000000 --- 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 bedaf652..00000000 --- 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 72d81427..00000000 --- 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 - -=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 - -=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 6c648fec..00000000 --- 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 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 -method, or query the distance between vertices by using the -C method. - -By default the edge attribute used for distance is C, 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 with a true value -to the new() constructor. - -=item attribute_name => attribute_name - -By default the edge attribute used for distance is C. You can -change that by giving another attribute name with the C -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 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, L - -=head1 AUTHOR AND COPYRIGHT - -Jarkko Hietaniemi F - -=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 54fa29a3..00000000 --- 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 de913763..00000000 --- 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 for the vertices C, C, ..., C -Returns a list of I truth values. - -=item set_row($u, $v1, $v2, ..., $vn) - -Sets the row at vertex C for the vertices C, C, ..., C, -in other words, connects the vertex C to the vertices C. -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 for the vertices C, C, ..., C, -in other words, disconnects the vertex C from the vertices C. -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 - -=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 9c3fc86d..00000000 --- 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. - -=head1 SEE ALSO - -L, L - -=head1 AUTHOR AND COPYRIGHT - -Jarkko Hietaniemi F - -=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 32bc0011..00000000 --- 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 d3b9d407..00000000 --- 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 - -=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 - -=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 04555310..00000000 --- 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 fd5a0a82..00000000 --- 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 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 and -C methods, and the paths by using the -C and C methods. - -For further documentation, see the L. - -=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 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 be56f2a9..00000000 --- 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 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 and -C methods, and the paths by using the -C and C 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 => I - -By default the edge attribute used for distance is C. You can -change that by giving another attribute name with the C -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 option. - -B: 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 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 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 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 - -=head1 AUTHOR AND COPYRIGHT - -Jarkko Hietaniemi F - -=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 edfc5b19..00000000 --- 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, a C, or a C). -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. - -=item start - -Identical to defining C and undefining C. - -=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 or C. - -=back - -The parameters C and C have a 'hierarchy' -of how they are determined: if they have been explicitly defined, use -that value. If not, use the value of C, if that has -been defined. If not, use the value of C, 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 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. - -=item successor - -Identical to having C both C defined -to be the same. - -=item unseen_successor - -Like C. - -=item seen_successor - -Like C. - -=back - -=head2 Special callbacks - -If in a callback you call the special C method, -the traversal is terminated, no more vertices are traversed. - -=head1 SEE ALSO - -L, L - -=head1 AUTHOR AND COPYRIGHT - -Jarkko Hietaniemi F - -=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 2678f72e..00000000 --- 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. - -=head2 Methods - -The following methods are available: - -=over 4 - -=item dfs - -Traverse the graph in depth-first order. - -=back - -=head1 SEE ALSO - -L, L, L. - -=cut diff --git a/perllib/Graph/Traversal/DFS.pm b/perllib/Graph/Traversal/DFS.pm deleted file mode 100644 index 4b109bd8..00000000 --- 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. - -=head2 Methods - -The following methods are available: - -=over 4 - -=item dfs - -Traverse the graph in depth-first order. - -=back - -=head1 SEE ALSO - -L, L, L. - -=cut diff --git a/perllib/Graph/Undirected.pm b/perllib/Graph/Undirected.pm deleted file mode 100644 index 3993bb1c..00000000 --- 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. - -=head1 SEE ALSO - -L, L - -=head1 AUTHOR AND COPYRIGHT - -Jarkko Hietaniemi F - -=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 83a921f0..00000000 --- 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 is a special data structure that can be used to track the -partitioning of a set into subsets (a problem known also as I). - -Graph::UnionFind() is used for Graph::connected_components(), -Graph::connected_component(), and Graph::same_connected_components() -if you specify a true C 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 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 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 - -=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 40ae5dc9..00000000 --- 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 and I. - -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, 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 3308bf31..00000000 --- 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 = \⊤ - -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 method of an element is used to store a reference to -the node in the list that refers to the element. - -See L 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 a274e114..24f6a4f5 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); + $$nodeval[$n] = $v; - foreach $nx ($gr->neighbors($n)) { - die unless ($gr->has_edge_attribute($n, $nx, "hash")); - my $e = $gr->get_edge_attribute($n, $nx, "hash"); + foreach $nx (@{$$nodeneigh[$n]}) { + # $nx -> [neigh, hash] + my ($o, $e) = @$nx; - # print STDERR "Edge $n=$nx value $e: "; - - if ($gr->has_vertex_attribute($nx, "val")) { - die if ($v+$gr->get_vertex_attribute($nx, "val") != $e); - # print STDERR "ok\n"; + # print STDERR "Edge $n,$o value $e: "; + my $ov; + if (defined($ov = $$nodeval[$o])) { + if ($v+$ov != $e) { + # Cyclic graph with collision + # print STDERR "error, should be ", $v+$ov, "\n"; + return 0; + } else { + # print STDERR "ok\n"; + } } else { - walk_graph($gr, $nx, $e-$v); + return 0 unless (walk_graph($nodeval, $nodeneigh, $o, $e-$v)); } } + return 1; } # @@ -59,63 +64,57 @@ sub walk_graph($$$) { sub gen_hash_n($$$$) { my($n, $sv, $href, $run) = @_; my @keys = keys(%{$href}); - my $i, $sv, @g; + my $i, $sv; my $gr; my $k, $v; my $gsize = 2*$n; + my @nodeval; + my @nodeneigh; + my %edges; - $gr = Graph::Undirected->new; for ($i = 0; $i < $gsize; $i++) { - $gr->add_vertex($i); + $nodeneigh[$i] = []; } + %edges = (); foreach $k (@keys) { my ($pf1, $pf2) = prehash($k, $n, $sv); + my $pf = "$pf1,$pf2"; my $e = ${$href}{$k}; + my $xkey; - if ($gr->has_edge($pf1, $pf2)) { - my $xkey = $gr->get_edge_attribute($pf1, $pf2, "key"); - my ($xp1, $xp2) = prehash($xkey, $n, $sv); + if (defined($xkey = $edges{$pf})) { if (defined($run)) { - print STDERR "$run: Collision: $pf1=$pf2 $k with "; - print STDERR "$xkey ($xp1,$xp2)\n"; + print STDERR "$run: Collision: $pf: $k with $xkey\n"; } return; } - # print STDERR "Edge $pf1=$pf2 value $e from $k\n"; + # print STDERR "Edge $pf value $e from $k\n"; - $gr->add_edge($pf1, $pf2); - $gr->set_edge_attribute($pf1, $pf2, "hash", $e); - $gr->set_edge_attribute($pf1, $pf2, "key", $k); - } - - # At this point, we're good if the graph is acyclic. - if ($gr->is_cyclic) { - if (defined($run)) { - print STDERR "$run: Graph is cyclic\n"; - } - return; - } - - if (defined($run)) { - print STDERR "$run: Graph OK, computing vertices...\n"; + $edges{$pf} = $k; + push(@{$nodeneigh[$pf1]}, [$pf2, $e]); + push(@{$nodeneigh[$pf2]}, [$pf1, $e]); } # Now we need to assign values to each vertex, so that for each # edge, the sum of the values for the two vertices give the value - # for the edge (which is our hash index.) Since the graph is - # acyclic, this is always doable. + # for the edge (which is our hash index.) If we find an impossible + # sitation, the graph was cyclic. + @nodeval = (undef) x $gsize; + for ($i = 0; $i < $gsize; $i++) { - if ($gr->degree($i)) { + if (scalar(@{$nodeneigh[$i]})) { # This vertex has neighbors (is used) - if (!$gr->has_vertex_attribute($i, "val")) { - walk_graph($gr,$i,0); # First vertex in a cluster + if (!defined($nodeval[$i])) { + # First vertex in a cluster + unless (walk_graph(\@nodeval, \@nodeneigh, $i, 0)) { + if (defined($run)) { + print STDERR "$run: Graph is cyclic\n"; + } + return; + } } - push(@g, $gr->get_vertex_attribute($i, "val")); - } else { - # Unused vertex - push(@g, undef); } } @@ -128,7 +127,7 @@ sub gen_hash_n($$$$) { $$sv[0], $$sv[1]; } - return ($n, $sv, \@g); + return ($n, $sv, \@nodeval); } # @@ -180,7 +179,7 @@ sub read_input() { while (defined($l = )) { chomp $l; $l =~ s/\s*(\#.*|)$//; - + next if ($l eq ''); if ($l =~ /^([^=]+)\=([^=]+)$/) {