From: H. Peter Anvin Date: Wed, 29 Aug 2007 17:20:09 +0000 (+0000) Subject: Create a Perl library directory, and add the Graph module to it X-Git-Tag: nasm-2.11.05~2039 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=16a76654b8d769527e3eeb66232340c1b8314415;p=platform%2Fupstream%2Fnasm.git Create a Perl library directory, and add the Graph module to it Graph-0.84 from CPAN --- diff --git a/Makefile.in b/Makefile.in index c252854..b0f661b 100644 --- a/Makefile.in +++ b/Makefile.in @@ -22,7 +22,7 @@ INTERNAL_CFLAGS = -I$(srcdir) -I. ALL_CFLAGS = $(BUILD_CFLAGS) $(INTERNAL_CFLAGS) LDFLAGS = @LDFLAGS@ LIBS = @LIBS@ -PERL = perl +PERL = perl -I$(srcdir)/perllib INSTALL = @INSTALL@ INSTALL_PROGRAM = @INSTALL_PROGRAM@ diff --git a/perllib/Graph.pm b/perllib/Graph.pm new file mode 100644 index 0000000..3d1ad33 --- /dev/null +++ b/perllib/Graph.pm @@ -0,0 +1,3851 @@ +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 new file mode 100644 index 0000000..9452d51 --- /dev/null +++ b/perllib/Graph.pod @@ -0,0 +1,2768 @@ +=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 new file mode 100644 index 0000000..d2245da --- /dev/null +++ b/perllib/Graph/AdjacencyMap.pm @@ -0,0 +1,473 @@ +package Graph::AdjacencyMap; + +use strict; + +require Exporter; +use vars qw(@ISA @EXPORT_OK %EXPORT_TAGS); +@ISA = qw(Exporter); +@EXPORT_OK = qw(_COUNT _MULTI _COUNTMULTI _GEN_ID + _HYPER _UNORD _UNIQ _REF _UNORDUNIQ _UNIONFIND _LIGHT + _n _f _a _i _s _p _g _u _ni _nc _na _nm); +%EXPORT_TAGS = + (flags => [qw(_COUNT _MULTI _COUNTMULTI _GEN_ID + _HYPER _UNORD _UNIQ _REF _UNORDUNIQ _UNIONFIND _LIGHT)], + fields => [qw(_n _f _a _i _s _p _g _u _ni _nc _na _nm)]); + +sub _COUNT () { 0x00000001 } +sub _MULTI () { 0x00000002 } +sub _COUNTMULTI () { _COUNT|_MULTI } +sub _HYPER () { 0x00000004 } +sub _UNORD () { 0x00000008 } +sub _UNIQ () { 0x00000010 } +sub _REF () { 0x00000020 } +sub _UNORDUNIQ () { _UNORD|_UNIQ } +sub _UNIONFIND () { 0x00000040 } +sub _LIGHT () { 0x00000080 } + +my $_GEN_ID = 0; + +sub _GEN_ID () { \$_GEN_ID } + +sub _ni () { 0 } # Node index. +sub _nc () { 1 } # Node count. +sub _na () { 2 } # Node attributes. +sub _nm () { 3 } # Node map. + +sub _n () { 0 } # Next id. +sub _f () { 1 } # Flags. +sub _a () { 2 } # Arity. +sub _i () { 3 } # Index to path. +sub _s () { 4 } # Successors / Path to Index. +sub _p () { 5 } # Predecessors. +sub _g () { 6 } # Graph (AdjacencyMap::Light) + +sub _V () { 2 } # Graph::_V() + +sub _new { + my $class = shift; + my $map = bless [ 0, @_ ], $class; + return $map; +} + +sub _ids { + my $m = shift; + return $m->[ _i ]; +} + +sub has_paths { + my $m = shift; + return defined $m->[ _i ] && keys %{ $m->[ _i ] }; +} + +sub _dump { + my $d = Data::Dumper->new([$_[0]],[ref $_[0]]); + defined wantarray ? $d->Dump : print $d->Dump; +} + +sub _del_id { + my ($m, $i) = @_; + my @p = $m->_get_id_path( $i ); + $m->del_path( @p ) if @p; +} + +sub _new_node { + my ($m, $n, $id) = @_; + my $f = $m->[ _f ]; + my $i = $m->[ _n ]++; + if (($f & _MULTI)) { + $id = 0 if $id eq _GEN_ID; + $$n = [ $i, 0, undef, { $id => { } } ]; + } elsif (($f & _COUNT)) { + $$n = [ $i, 1 ]; + } else { + $$n = $i; + } + return $i; +} + +sub _inc_node { + my ($m, $n, $id) = @_; + my $f = $m->[ _f ]; + if (($f & _MULTI)) { + if ($id eq _GEN_ID) { + $$n->[ _nc ]++ + while exists $$n->[ _nm ]->{ $$n->[ _nc ] }; + $id = $$n->[ _nc ]; + } + $$n->[ _nm ]->{ $id } = { }; + } elsif (($f & _COUNT)) { + $$n->[ _nc ]++; + } + return $id; +} + +sub __get_path_node { + my $m = shift; + my ($p, $k); + my $f = $m->[ _f ]; + @_ = sort @_ if ($f & _UNORD); + if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. + return unless exists $m->[ _s ]->{ $_[0] }; + $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ]; + $k = [ $_[0], $_[1] ]; + } else { + ($p, $k) = $m->__has_path( @_ ); + } + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + return ( exists $p->[-1]->{ $l }, $p->[-1]->{ $l }, $p, $k, $l ); +} + +sub set_path_by_multi_id { + my $m = shift; + my ($p, $k) = $m->__set_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + return $m->__set_path_node( $p, $l, @_ ); +} + +sub get_multi_ids { + my $m = shift; + my $f = $m->[ _f ]; + return () unless ($f & _MULTI); + my ($e, $n) = $m->__get_path_node( @_ ); + return $e ? keys %{ $n->[ _nm ] } : (); +} + +sub _has_path_attrs { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + return keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } } ? 1 : 0; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return ref $n && $#$n == _na && keys %{ $n->[ _na ] } ? 1 : 0; + } +} + +sub _set_path_attrs { + my $m = shift; + my $f = $m->[ _f ]; + my $attr = pop; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( @_ ); + push @_, $id if ($f & _MULTI); + my ($p, $k) = $m->__set_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + $m->__set_path_node( $p, $l, @_ ) unless exists $p->[-1]->{ $l }; + if (($f & _MULTI)) { + $p->[-1]->{ $l }->[ _nm ]->{ $id } = $attr; + } else { + # Extend the node if it is a simple id node. + $p->[-1]->{ $l } = [ $p->[-1]->{ $l }, 1 ] unless ref $p->[-1]->{ $l }; + $p->[-1]->{ $l }->[ _na ] = $attr; + } +} + +sub _has_path_attr { + my $m = shift; + my $f = $m->[ _f ]; + my $attr = pop; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + exists $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr }; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return ref $n && $#$n == _na ? exists $n->[ _na ]->{ $attr } : undef; + } +} + +sub _set_path_attr { + my $m = shift; + my $f = $m->[ _f ]; + my $val = pop; + my $attr = pop; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + my ($p, $k); + $m->__attr( \@_ ); # _LIGHT maps need this to get upgraded when needed. + push @_, $id if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_REF|_UNIQ|_HYPER|_UNIQ))) { + $m->[ _s ]->{ $_[0] } ||= { }; + $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ]; + $k = [ $_[0], $_[1] ]; + } else { + ($p, $k) = $m->__set_path( @_ ); + } + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + $m->__set_path_node( $p, $l, @_ ) unless exists $p->[-1]->{ $l }; + if (($f & _MULTI)) { + $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr } = $val; + } else { + # Extend the node if it is a simple id node. + $p->[-1]->{ $l } = [ $p->[-1]->{ $l }, 1 ] unless ref $p->[-1]->{ $l }; + $p->[-1]->{ $l }->[ _na ]->{ $attr } = $val; + } + return $val; +} + +sub _get_path_attrs { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + $p->[-1]->{ $l }->[ _nm ]->{ $id }; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return unless $e; + return $n->[ _na ] if ref $n && $#$n == _na; + return; + } +} + +sub _get_path_attr { + my $m = shift; + my $f = $m->[ _f ]; + my $attr = pop; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + return $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr }; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return ref $n && $#$n == _na ? $n->[ _na ]->{ $attr } : undef; + } +} + +sub _get_path_attr_names { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } }; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return keys %{ $n->[ _na ] } if ref $n && $#$n == _na; + return; + } +} + +sub _get_path_attr_values { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + values %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } }; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return values %{ $n->[ _na ] } if ref $n && $#$n == _na; + return; + } +} + +sub _del_path_attrs { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + delete $p->[-1]->{ $l }->[ _nm ]->{ $id }; + unless (keys %{ $p->[-1]->{ $l }->[ _nm ] } || + (defined $p->[-1]->{ $l }->[ _na ] && + keys %{ $p->[-1]->{ $l }->[ _na ] })) { + delete $p->[-1]->{ $l }; + } + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + if (ref $n) { + $e = _na == $#$n && keys %{ $n->[ _na ] } ? 1 : 0; + $#$n = _na - 1; + return $e; + } else { + return 0; + } + } +} + +sub _del_path_attr { + my $m = shift; + my $f = $m->[ _f ]; + my $attr = pop; + my $id = pop if ($f & _MULTI); + @_ = sort @_ if ($f & _UNORD); + $m->__attr( \@_ ); + if (($f & _MULTI)) { + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + delete $p->[-1]->{ $l }->[ _nm ]->{ $id }->{ $attr }; + $m->_del_path_attrs( @_, $id ) + unless keys %{ $p->[-1]->{ $l }->[ _nm ]->{ $id } }; + } else { + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + if (ref $n && $#$n == _na && exists $n->[ _na ]->{ $attr }) { + delete $n->[ _na ]->{ $attr }; + return 1; + } else { + return 0; + } + } +} + +sub _is_COUNT { $_[0]->[ _f ] & _COUNT } +sub _is_MULTI { $_[0]->[ _f ] & _MULTI } +sub _is_HYPER { $_[0]->[ _f ] & _HYPER } +sub _is_UNORD { $_[0]->[ _f ] & _UNORD } +sub _is_UNIQ { $_[0]->[ _f ] & _UNIQ } +sub _is_REF { $_[0]->[ _f ] & _REF } + +sub __arg { + my $m = shift; + my $f = $m->[ _f ]; + my @a = @{$_[0]}; + if ($f & _UNIQ) { + my %u; + if ($f & _UNORD) { + @u{ @a } = @a; + @a = values %u; + } else { + my @u; + for my $e (@a) { + push @u, $e if $u{$e}++ == 0; + } + @a = @u; + } + } + # Alphabetic or numeric sort, does not matter as long as it unifies. + @{$_[0]} = ($f & _UNORD) ? sort @a : @a; +} + +sub _successors { + my $E = shift; + my $g = shift; + my $V = $g->[ _V ]; + map { my @v = @{ $_->[ 1 ] }; + shift @v; + map { $V->_get_id_path($_) } @v } $g->_edges_from( @_ ); +} + +sub _predecessors { + my $E = shift; + my $g = shift; + my $V = $g->[ _V ]; + if (wantarray) { + map { my @v = @{ $_->[ 1 ] }; + pop @v; + map { $V->_get_id_path($_) } @v } $g->_edges_to( @_ ); + } else { + return $g->_edges_to( @_ ); + } +} + +1; +__END__ +=pod + +=head1 NAME + +Graph::AdjacencyMap - create and a map of graph vertices or edges + +=head1 SYNOPSIS + + Internal. + +=head1 DESCRIPTION + +B + +=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 new file mode 100644 index 0000000..262bd4f --- /dev/null +++ b/perllib/Graph/AdjacencyMap/Heavy.pm @@ -0,0 +1,253 @@ +package Graph::AdjacencyMap::Heavy; + +# THIS IS INTERNAL IMPLEMENTATION ONLY, NOT TO BE USED DIRECTLY. +# THE INTERFACE IS HARD TO USE AND GOING TO STAY THAT WAY AND +# ALMOST GUARANTEED TO CHANGE OR GO AWAY IN FUTURE RELEASES. + +use strict; + +# $SIG{__DIE__ } = sub { use Carp; confess }; +# $SIG{__WARN__} = sub { use Carp; confess }; + +use Graph::AdjacencyMap qw(:flags :fields); +use base 'Graph::AdjacencyMap'; + +require overload; # for de-overloading + +require Data::Dumper; + +sub __set_path { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + if (@_ != $m->[ _a ] && !($f & _HYPER)) { + require Carp; + Carp::confess(sprintf "Graph::AdjacencyMap::Heavy: arguments %d expected %d", + scalar @_, $m->[ _a ]); + } + my $p; + $p = ($f & _HYPER) ? + (( $m->[ _s ] ||= [ ] )->[ @_ ] ||= { }) : + ( $m->[ _s ] ||= { }); + my @p = $p; + my @k; + while (@_) { + my $k = shift; + my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k; + if (@_) { + $p = $p->{ $q } ||= {}; + return unless $p; + push @p, $p; + } + push @k, $q; + } + return (\@p, \@k); +} + +sub __set_path_node { + my ($m, $p, $l) = splice @_, 0, 3; + my $f = $m->[ _f ] ; + my $id = pop if ($f & _MULTI); + unless (exists $p->[-1]->{ $l }) { + my $i = $m->_new_node( \$p->[-1]->{ $l }, $id ); + $m->[ _i ]->{ defined $i ? $i : "" } = [ @_ ]; + return defined $id ? ($id eq _GEN_ID ? $$id : $id) : $i; + } else { + return $m->_inc_node( \$p->[-1]->{ $l }, $id ); + } +} + +sub set_path { + my $m = shift; + my $f = $m->[ _f ]; + if (@_ > 1 && ($f & _UNORDUNIQ)) { + if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } + else { $m->__arg(\@_) } + } + my ($p, $k) = $m->__set_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + return $m->__set_path_node( $p, $l, @_ ); +} + +sub __has_path { + my $m = shift; + my $f = $m->[ _f ]; + if (@_ != $m->[ _a ] && !($f & _HYPER)) { + require Carp; + Carp::confess(sprintf "Graph::AdjacencyMap::Heavy: arguments %d expected %d", + scalar @_, $m->[ _a ]); + } + if (@_ > 1 && ($f & _UNORDUNIQ)) { + if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } + else { $m->__arg(\@_) } + } + my $p = $m->[ _s ]; + return unless defined $p; + $p = $p->[ @_ ] if ($f & _HYPER); + return unless defined $p; + my @p = $p; + my @k; + while (@_) { + my $k = shift; + my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k; + if (@_) { + $p = $p->{ $q }; + return unless defined $p; + push @p, $p; + } + push @k, $q; + } + return (\@p, \@k); +} + +sub has_path { + my $m = shift; + my $f = $m->[ _f ]; + if (@_ > 1 && ($f & _UNORDUNIQ)) { + if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } + else { $m->__arg(\@_) } + } + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + return exists $p->[-1]->{ defined $k->[-1] ? $k->[-1] : "" }; +} + +sub has_path_by_multi_id { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop; + if (@_ > 1 && ($f & _UNORDUNIQ)) { + if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } + else { $m->__arg(\@_) } + } + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return exists $n->[ _nm ]->{ $id }; +} + +sub _get_path_node { + my $m = shift; + my $f = $m->[ _f ]; + if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. + @_ = sort @_ if ($f & _UNORD); + return unless exists $m->[ _s ]->{ $_[0] }; + my $p = [ $m->[ _s ], $m->[ _s ]->{ $_[0] } ]; + my $k = [ $_[0], $_[1] ]; + my $l = $_[1]; + return ( exists $p->[-1]->{ $l }, $p->[-1]->{ $l }, $p, $k, $l ); + } else { + if (@_ > 1 && ($f & _UNORDUNIQ)) { + if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } + else { $m->__arg(\@_) } + } + $m->__get_path_node( @_ ); + } +} + +sub _get_path_id { + my $m = shift; + my $f = $m->[ _f ]; + my ($e, $n); + if ($m->[ _a ] == 2 && @_ == 2 && !($f & (_HYPER|_REF|_UNIQ))) { # Fast path. + @_ = sort @_ if ($f & _UNORD); + return unless exists $m->[ _s ]->{ $_[0] }; + my $p = $m->[ _s ]->{ $_[0] }; + $e = exists $p->{ $_[1] }; + $n = $p->{ $_[1] }; + } else { + ($e, $n) = $m->_get_path_node( @_ ); + } + return undef unless $e; + return ref $n ? $n->[ _ni ] : $n; +} + +sub _get_path_count { + my $m = shift; + my $f = $m->[ _f ]; + my ($e, $n) = $m->_get_path_node( @_ ); + return undef unless $e && defined $n; + return + ($f & _COUNT) ? $n->[ _nc ] : + ($f & _MULTI) ? scalar keys %{ $n->[ _nm ] } : 1; +} + +sub __attr { + my $m = shift; + if (@_) { + if (ref $_[0] && @{ $_[0] }) { + if (@{ $_[0] } != $m->[ _a ]) { + require Carp; + Carp::confess(sprintf + "Graph::AdjacencyMap::Heavy: arguments %d expected %d\n", + scalar @{ $_[0] }, $m->[ _a ]); + } + my $f = $m->[ _f ]; + if (@{ $_[0] } > 1 && ($f & _UNORDUNIQ)) { + if (($f & _UNORDUNIQ) == _UNORD && @{ $_[0] } == 2) { + @{ $_[0] } = sort @{ $_[0] } + } else { $m->__arg(\@_) } + } + } + } +} + +sub _get_id_path { + my ($m, $i) = @_; + my $p = defined $i ? $m->[ _i ]->{ $i } : undef; + return defined $p ? @$p : ( ); +} + +sub del_path { + my $m = shift; + my $f = $m->[ _f ]; + if (@_ > 1 && ($f & _UNORDUNIQ)) { + if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } + else { $m->__arg(\@_) } + } + my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ ); + return unless $e; + my $c = ($f & _COUNT) ? --$n->[ _nc ] : 0; + if ($c == 0) { + delete $m->[ _i ]->{ ref $n ? $n->[ _ni ] : $n }; + delete $p->[-1]->{ $l }; + while (@$p && @$k && keys %{ $p->[-1]->{ $k->[-1] } } == 0) { + delete $p->[-1]->{ $k->[-1] }; + pop @$p; + pop @$k; + } + } + return 1; +} + +sub del_path_by_multi_id { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop; + if (@_ > 1 && ($f & _UNORDUNIQ)) { + if (($f & _UNORDUNIQ) == _UNORD && @_ == 2) { @_ = sort @_ } + else { $m->__arg(\@_) } + } + my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ ); + return unless $e; + delete $n->[ _nm ]->{ $id }; + unless (keys %{ $n->[ _nm ] }) { + delete $m->[ _i ]->{ $n->[ _ni ] }; + delete $p->[-1]->{ $l }; + while (@$p && @$k && keys %{ $p->[-1]->{ $k->[-1] } } == 0) { + delete $p->[-1]->{ $k->[-1] }; + pop @$p; + pop @$k; + } + } + return 1; +} + +sub paths { + my $m = shift; + return values %{ $m->[ _i ] } if defined $m->[ _i ]; + wantarray ? ( ) : 0; +} + +1; +__END__ diff --git a/perllib/Graph/AdjacencyMap/Light.pm b/perllib/Graph/AdjacencyMap/Light.pm new file mode 100644 index 0000000..bedaf65 --- /dev/null +++ b/perllib/Graph/AdjacencyMap/Light.pm @@ -0,0 +1,247 @@ +package Graph::AdjacencyMap::Light; + +# THIS IS INTERNAL IMPLEMENTATION ONLY, NOT TO BE USED DIRECTLY. +# THE INTERFACE IS HARD TO USE AND GOING TO STAY THAT WAY AND +# ALMOST GUARANTEED TO CHANGE OR GO AWAY IN FUTURE RELEASES. + +use strict; + +use Graph::AdjacencyMap qw(:flags :fields); +use base 'Graph::AdjacencyMap'; + +use Scalar::Util qw(weaken); + +use Graph::AdjacencyMap::Heavy; +use Graph::AdjacencyMap::Vertex; + +sub _V () { 2 } # Graph::_V +sub _E () { 3 } # Graph::_E +sub _F () { 0 } # Graph::_F + +sub _new { + my ($class, $graph, $flags, $arity) = @_; + my $m = bless [ ], $class; + $m->[ _n ] = 0; + $m->[ _f ] = $flags | _LIGHT; + $m->[ _a ] = $arity; + $m->[ _i ] = { }; + $m->[ _s ] = { }; + $m->[ _p ] = { }; + $m->[ _g ] = $graph; + weaken $m->[ _g ]; # So that DESTROY finds us earlier. + return $m; +} + +sub set_path { + my $m = shift; + my ($n, $f, $a, $i, $s, $p) = @$m; + if ($a == 2) { + @_ = sort @_ if ($f & _UNORD); + } + my $e0 = shift; + if ($a == 2) { + my $e1 = shift; + unless (exists $s->{ $e0 } && exists $s->{ $e0 }->{ $e1 }) { + $n = $m->[ _n ]++; + $i->{ $n } = [ $e0, $e1 ]; + $s->{ $e0 }->{ $e1 } = $n; + $p->{ $e1 }->{ $e0 } = $n; + } + } else { + unless (exists $s->{ $e0 }) { + $n = $m->[ _n ]++; + $s->{ $e0 } = $n; + $i->{ $n } = $e0; + } + } +} + +sub has_path { + my $m = shift; + my ($n, $f, $a, $i, $s) = @$m; + return 0 unless $a == @_; + my $e; + if ($a == 2) { + @_ = sort @_ if ($f & _UNORD); + $e = shift; + return 0 unless exists $s->{ $e }; + $s = $s->{ $e }; + } + $e = shift; + exists $s->{ $e }; +} + +sub _get_path_id { + my $m = shift; + my ($n, $f, $a, $i, $s) = @$m; + return undef unless $a == @_; + my $e; + if ($a == 2) { + @_ = sort @_ if ($f & _UNORD); + $e = shift; + return undef unless exists $s->{ $e }; + $s = $s->{ $e }; + } + $e = shift; + $s->{ $e }; +} + +sub _get_path_count { + my $m = shift; + my ($n, $f, $a, $i, $s) = @$m; + my $e; + if (@_ == 2) { + @_ = sort @_ if ($f & _UNORD); + $e = shift; + return undef unless exists $s->{ $e }; + $s = $s->{ $e }; + } + $e = shift; + return exists $s->{ $e } ? 1 : 0; +} + +sub has_paths { + my $m = shift; + my ($n, $f, $a, $i, $s) = @$m; + keys %$s; +} + +sub paths { + my $m = shift; + my ($n, $f, $a, $i) = @$m; + if (defined $i) { + my ($k, $v) = each %$i; + if (ref $v) { + return values %{ $i }; + } else { + return map { [ $_ ] } values %{ $i }; + } + } else { + return ( ); + } +} + +sub _get_id_path { + my $m = shift; + my ($n, $f, $a, $i) = @$m; + my $p = $i->{ $_[ 0 ] }; + defined $p ? ( ref $p eq 'ARRAY' ? @$p : $p ) : ( ); +} + +sub del_path { + my $m = shift; + my ($n, $f, $a, $i, $s, $p) = @$m; + if (@_ == 2) { + @_ = sort @_ if ($f & _UNORD); + my $e0 = shift; + return 0 unless exists $s->{ $e0 }; + my $e1 = shift; + if (defined($n = $s->{ $e0 }->{ $e1 })) { + delete $i->{ $n }; + delete $s->{ $e0 }->{ $e1 }; + delete $p->{ $e1 }->{ $e0 }; + delete $s->{ $e0 } unless keys %{ $s->{ $e0 } }; + delete $p->{ $e1 } unless keys %{ $p->{ $e1 } }; + return 1; + } + } else { + my $e = shift; + if (defined($n = $s->{ $e })) { + delete $i->{ $n }; + delete $s->{ $e }; + return 1; + } + } + return 0; +} + +sub __successors { + my $E = shift; + return wantarray ? () : 0 unless defined $E->[ _s ]; + my $g = shift; + my $V = $g->[ _V ]; + return wantarray ? () : 0 unless defined $V && defined $V->[ _s ]; + # my $i = $V->_get_path_id( $_[0] ); + my $i = + ($V->[ _f ] & _LIGHT) ? + $V->[ _s ]->{ $_[0] } : + $V->_get_path_id( $_[0] ); + return wantarray ? () : 0 unless defined $i && defined $E->[ _s ]->{ $i }; + return keys %{ $E->[ _s ]->{ $i } }; +} + +sub _successors { + my $E = shift; + my $g = shift; + my @s = $E->__successors($g, @_); + if (($E->[ _f ] & _UNORD)) { + push @s, $E->__predecessors($g, @_); + my %s; @s{ @s } = (); + @s = keys %s; + } + my $V = $g->[ _V ]; + return wantarray ? map { $V->[ _i ]->{ $_ } } @s : @s; +} + +sub __predecessors { + my $E = shift; + return wantarray ? () : 0 unless defined $E->[ _p ]; + my $g = shift; + my $V = $g->[ _V ]; + return wantarray ? () : 0 unless defined $V && defined $V->[ _s ]; + # my $i = $V->_get_path_id( $_[0] ); + my $i = + ($V->[ _f ] & _LIGHT) ? + $V->[ _s ]->{ $_[0] } : + $V->_get_path_id( $_[0] ); + return wantarray ? () : 0 unless defined $i && defined $E->[ _p ]->{ $i }; + return keys %{ $E->[ _p ]->{ $i } }; +} + +sub _predecessors { + my $E = shift; + my $g = shift; + my @p = $E->__predecessors($g, @_); + if ($E->[ _f ] & _UNORD) { + push @p, $E->__successors($g, @_); + my %p; @p{ @p } = (); + @p = keys %p; + } + my $V = $g->[ _V ]; + return wantarray ? map { $V->[ _i ]->{ $_ } } @p : @p; +} + +sub __attr { + # Major magic takes place here: we rebless the appropriate 'light' + # map into a more complex map and then redispatch the method. + my $m = $_[0]; + my ($n, $f, $a, $i, $s, $p, $g) = @$m; + my ($k, $v) = each %$i; + my @V = @{ $g->[ _V ] }; + my @E = $g->edges; # TODO: Both these (ZZZ) lines are mysteriously needed! + # ZZZ: an example of failing tests is t/52_edge_attributes.t. + if (ref $v eq 'ARRAY') { # Edges, then. + # print "Reedging.\n"; + @E = $g->edges; # TODO: Both these (ZZZ) lines are mysteriously needed! + $g->[ _E ] = $m = Graph::AdjacencyMap::Heavy->_new($f, 2); + $g->add_edges( @E ); + } else { + # print "Revertexing.\n"; + $m = Graph::AdjacencyMap::Vertex->_new(($f & ~_LIGHT), 1); + $m->[ _n ] = $V[ _n ]; + $m->[ _i ] = $V[ _i ]; + $m->[ _s ] = $V[ _s ]; + $m->[ _p ] = $V[ _p ]; + $g->[ _V ] = $m; + } + $_[0] = $m; + goto &{ ref($m) . "::__attr" }; # Redispatch. +} + +sub _is_COUNT () { 0 } +sub _is_MULTI () { 0 } +sub _is_HYPER () { 0 } +sub _is_UNIQ () { 0 } +sub _is_REF () { 0 } + +1; diff --git a/perllib/Graph/AdjacencyMap/Vertex.pm b/perllib/Graph/AdjacencyMap/Vertex.pm new file mode 100644 index 0000000..72d8142 --- /dev/null +++ b/perllib/Graph/AdjacencyMap/Vertex.pm @@ -0,0 +1,216 @@ +package Graph::AdjacencyMap::Vertex; + +# THIS IS INTERNAL IMPLEMENTATION ONLY, NOT TO BE USED DIRECTLY. +# THE INTERFACE IS HARD TO USE AND GOING TO STAY THAT WAY AND +# ALMOST GUARANTEED TO CHANGE OR GO AWAY IN FUTURE RELEASES. + +use strict; + +# $SIG{__DIE__ } = sub { use Carp; confess }; +# $SIG{__WARN__} = sub { use Carp; confess }; + +use Graph::AdjacencyMap qw(:flags :fields); +use base 'Graph::AdjacencyMap'; + +use Scalar::Util qw(weaken); + +sub _new { + my ($class, $flags, $arity) = @_; + bless [ 0, $flags, $arity ], $class; +} + +require overload; # for de-overloading + +sub __set_path { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + if (@_ != 1) { + require Carp; + Carp::confess(sprintf "Graph::AdjacencyMap::Vertex: arguments %d expected 1", scalar @_); + } + my $p; + $p = $m->[ _s ] ||= { }; + my @p = $p; + my @k; + my $k = shift; + my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k; + push @k, $q; + return (\@p, \@k); +} + +sub __set_path_node { + my ($m, $p, $l) = splice @_, 0, 3; + my $f = $m->[ _f ]; + my $id = pop if ($f & _MULTI); + unless (exists $p->[-1]->{ $l }) { + my $i = $m->_new_node( \$p->[-1]->{ $l }, $id ); + $m->[ _i ]->{ defined $i ? $i : "" } = $_[0]; + } else { + $m->_inc_node( \$p->[-1]->{ $l }, $id ); + } +} + +sub set_path { + my $m = shift; + my $f = $m->[ _f ]; + my ($p, $k) = $m->__set_path( @_ ); + return unless defined $p && defined $k; + my $l = defined $k->[-1] ? $k->[-1] : ""; + my $set = $m->__set_path_node( $p, $l, @_ ); + return $set; +} + +sub __has_path { + my $m = shift; + my $f = $m->[ _f ]; + if (@_ != 1) { + require Carp; + Carp::confess(sprintf + "Graph::AdjacencyMap: arguments %d expected 1\n", + scalar @_); + } + my $p = $m->[ _s ]; + return unless defined $p; + my @p = $p; + my @k; + my $k = shift; + my $q = ref $k && ($f & _REF) && overload::Method($k, '""') ? overload::StrVal($k) : $k; + push @k, $q; + return (\@p, \@k); +} + +sub has_path { + my $m = shift; + my ($p, $k) = $m->__has_path( @_ ); + return unless defined $p && defined $k; + return exists $p->[-1]->{ defined $k->[-1] ? $k->[-1] : "" }; +} + +sub has_path_by_multi_id { + my $m = shift; + my $id = pop; + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return exists $n->[ _nm ]->{ $id }; +} + +sub _get_path_id { + my $m = shift; + my $f = $m->[ _f ]; + my ($e, $n) = $m->__get_path_node( @_ ); + return undef unless $e; + return ref $n ? $n->[ _ni ] : $n; +} + +sub _get_path_count { + my $m = shift; + my $f = $m->[ _f ]; + my ($e, $n) = $m->__get_path_node( @_ ); + return 0 unless $e && defined $n; + return + ($f & _COUNT) ? $n->[ _nc ] : + ($f & _MULTI) ? scalar keys %{ $n->[ _nm ] } : 1; +} + +sub __attr { + my $m = shift; + if (@_ && ref $_[0] && @{ $_[0] } != $m->[ _a ]) { + require Carp; + Carp::confess(sprintf "Graph::AdjacencyMap::Vertex: arguments %d expected %d", + scalar @{ $_[0] }, $m->[ _a ]); + } +} + +sub _get_id_path { + my ($m, $i) = @_; + return defined $m->[ _i ] ? $m->[ _i ]->{ $i } : undef; +} + +sub del_path { + my $m = shift; + my $f = $m->[ _f ]; + my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ ); + return unless $e; + my $c = ($f & _COUNT) ? --$n->[ _nc ] : 0; + if ($c == 0) { + delete $m->[ _i ]->{ ref $n ? $n->[ _ni ] : $n }; + delete $p->[ -1 ]->{ $l }; + } + return 1; +} + +sub del_path_by_multi_id { + my $m = shift; + my $f = $m->[ _f ]; + my $id = pop; + my ($e, $n, $p, $k, $l) = $m->__get_path_node( @_ ); + return unless $e; + delete $n->[ _nm ]->{ $id }; + unless (keys %{ $n->[ _nm ] }) { + delete $m->[ _i ]->{ $n->[ _ni ] }; + delete $p->[-1]->{ $l }; + } + return 1; +} + +sub paths { + my $m = shift; + return map { [ $_ ] } values %{ $m->[ _i ] } if defined $m->[ _i ]; + wantarray ? ( ) : 0; +} + +1; +=pod + +=head1 NAME + +Graph::AdjacencyMap - create and a map of graph vertices or edges + +=head1 SYNOPSIS + + Internal. + +=head1 DESCRIPTION + +B + +=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 new file mode 100644 index 0000000..6c648fe --- /dev/null +++ b/perllib/Graph/AdjacencyMatrix.pm @@ -0,0 +1,223 @@ +package Graph::AdjacencyMatrix; + +use strict; + +use Graph::BitMatrix; +use Graph::Matrix; + +use base 'Graph::BitMatrix'; + +use Graph::AdjacencyMap qw(:flags :fields); + +sub _V () { 2 } # Graph::_V +sub _E () { 3 } # Graph::_E + +sub new { + my ($class, $g, %opt) = @_; + my $n; + my @V = $g->vertices; + my $want_distance; + if (exists $opt{distance_matrix}) { + $want_distance = $opt{distance_matrix}; + delete $opt{distance_matrix}; + } + my $d = Graph::_defattr(); + if (exists $opt{attribute_name}) { + $d = $opt{attribute_name}; + $want_distance++; + } + delete $opt{attribute_name}; + my $want_transitive = 0; + if (exists $opt{is_transitive}) { + $want_transitive = $opt{is_transitive}; + delete $opt{is_transitive}; + } + Graph::_opt_unknown(\%opt); + if ($want_distance) { + $n = Graph::Matrix->new($g); + for my $v (@V) { $n->set($v, $v, 0) } + } + my $m = Graph::BitMatrix->new($g, connect_edges => $want_distance); + if ($want_distance) { + # for my $u (@V) { + # for my $v (@V) { + # if ($g->has_edge($u, $v)) { + # $n->set($u, $v, + # $g->get_edge_attribute($u, $v, $d)); + # } + # } + # } + my $Vi = $g->[_V]->[_i]; + my $Ei = $g->[_E]->[_i]; + my %V; @V{ @V } = 0 .. $#V; + my $n0 = $n->[0]; + my $n1 = $n->[1]; + if ($g->is_undirected) { + for my $e (keys %{ $Ei }) { + my ($i0, $j0) = @{ $Ei->{ $e } }; + my $i1 = $V{ $Vi->{ $i0 } }; + my $j1 = $V{ $Vi->{ $j0 } }; + my $u = $V[ $i1 ]; + my $v = $V[ $j1 ]; + $n0->[ $i1 ]->[ $j1 ] = + $g->get_edge_attribute($u, $v, $d); + $n0->[ $j1 ]->[ $i1 ] = + $g->get_edge_attribute($v, $u, $d); + } + } else { + for my $e (keys %{ $Ei }) { + my ($i0, $j0) = @{ $Ei->{ $e } }; + my $i1 = $V{ $Vi->{ $i0 } }; + my $j1 = $V{ $Vi->{ $j0 } }; + my $u = $V[ $i1 ]; + my $v = $V[ $j1 ]; + $n0->[ $i1 ]->[ $j1 ] = + $g->get_edge_attribute($u, $v, $d); + } + } + } + bless [ $m, $n, [ @V ] ], $class; +} + +sub adjacency_matrix { + my $am = shift; + $am->[0]; +} + +sub distance_matrix { + my $am = shift; + $am->[1]; +} + +sub vertices { + my $am = shift; + @{ $am->[2] }; +} + +sub is_adjacent { + my ($m, $u, $v) = @_; + $m->[0]->get($u, $v) ? 1 : 0; +} + +sub distance { + my ($m, $u, $v) = @_; + defined $m->[1] ? $m->[1]->get($u, $v) : undef; +} + +1; +__END__ +=pod + +=head1 NAME + +Graph::AdjacencyMatrix - create and query the adjacency matrix of graph G + +=head1 SYNOPSIS + + use Graph::AdjacencyMatrix; + use Graph::Directed; # or Undirected + + my $g = Graph::Directed->new; + $g->add_...(); # build $g + + my $am = Graph::AdjacencyMatrix->new($g); + $am->is_adjacent($u, $v) + + my $am = Graph::AdjacencyMatrix->new($g, distance_matrix => 1); + $am->distance($u, $v) + + my $am = Graph::AdjacencyMatrix->new($g, attribute_name => 'length'); + $am->distance($u, $v) + + my $am = Graph::AdjacencyMatrix->new($g, ...); + my @V = $am->vertices(); + +=head1 DESCRIPTION + +You can use C 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 new file mode 100644 index 0000000..54fa29a --- /dev/null +++ b/perllib/Graph/Attribute.pm @@ -0,0 +1,130 @@ +package Graph::Attribute; + +use strict; + +sub _F () { 0 } +sub _COMPAT02 () { 0x00000001 } + +sub import { + my $package = shift; + my %attr = @_; + my $caller = caller(0); + if (exists $attr{array}) { + my $i = $attr{array}; + no strict 'refs'; + *{"${caller}::_get_attributes"} = sub { $_[0]->[ $i ] }; + *{"${caller}::_set_attributes"} = + sub { $_[0]->[ $i ] ||= { }; + $_[0]->[ $i ] = $_[1] if @_ == 2; + $_[0]->[ $i ] }; + *{"${caller}::_has_attributes"} = sub { defined $_[0]->[ $i ] }; + *{"${caller}::_delete_attributes"} = sub { undef $_[0]->[ $i ]; 1 }; + } elsif (exists $attr{hash}) { + my $k = $attr{hash}; + no strict 'refs'; + *{"${caller}::_get_attributes"} = sub { $_[0]->{ $k } }; + *{"${caller}::_set_attributes"} = + sub { $_[0]->{ $k } ||= { }; + $_[0]->{ $k } = $_[1] if @_ == 2; + $_[0]->{ $k } }; + *{"${caller}::_has_attributes"} = sub { defined $_[0]->{ $k } }; + *{"${caller}::_delete_attributes"} = sub { delete $_[0]->{ $k } }; + } else { + die "Graph::Attribute::import($package @_) caller $caller\n"; + } + my @api = qw(get_attribute + get_attributes + set_attribute + set_attributes + has_attribute + has_attributes + delete_attribute + delete_attributes + get_attribute_names + get_attribute_values); + if (exists $attr{map}) { + my $map = $attr{map}; + for my $api (@api) { + my ($first, $rest) = ($api =~ /^(\w+?)_(.+)/); + no strict 'refs'; + *{"${caller}::${first}_${map}_${rest}"} = \&$api; + } + } +} + +sub set_attribute { + my $g = shift; + my $v = pop; + my $a = pop; + my $p = $g->_set_attributes; + $p->{ $a } = $v; + return 1; +} + +sub set_attributes { + my $g = shift; + my $a = pop; + my $p = $g->_set_attributes( $a ); + return 1; +} + +sub has_attribute { + my $g = shift; + my $a = pop; + my $p = $g->_get_attributes; + $p ? exists $p->{ $a } : 0; +} + +sub has_attributes { + my $g = shift; + $g->_get_attributes ? 1 : 0; +} + +sub get_attribute { + my $g = shift; + my $a = pop; + my $p = $g->_get_attributes; + $p ? $p->{ $a } : undef; +} + +sub delete_attribute { + my $g = shift; + my $a = pop; + my $p = $g->_get_attributes; + if (defined $p) { + delete $p->{ $a }; + return 1; + } else { + return 0; + } +} + +sub delete_attributes { + my $g = shift; + if ($g->_has_attributes) { + $g->_delete_attributes; + return 1; + } else { + return 0; + } +} + +sub get_attribute_names { + my $g = shift; + my $p = $g->_get_attributes; + defined $p ? keys %{ $p } : ( ); +} + +sub get_attribute_values { + my $g = shift; + my $p = $g->_get_attributes; + defined $p ? values %{ $p } : ( ); +} + +sub get_attributes { + my $g = shift; + my $a = $g->_get_attributes; + ($g->[ _F ] & _COMPAT02) ? (defined $a ? %{ $a } : ()) : $a; +} + +1; diff --git a/perllib/Graph/BitMatrix.pm b/perllib/Graph/BitMatrix.pm new file mode 100644 index 0000000..de91376 --- /dev/null +++ b/perllib/Graph/BitMatrix.pm @@ -0,0 +1,227 @@ +package Graph::BitMatrix; + +use strict; + +# $SIG{__DIE__ } = sub { use Carp; confess }; +# $SIG{__WARN__} = sub { use Carp; confess }; + +sub _V () { 2 } # Graph::_V() +sub _E () { 3 } # Graph::_E() +sub _i () { 3 } # Index to path. +sub _s () { 4 } # Successors / Path to Index. + +sub new { + my ($class, $g, %opt) = @_; + my @V = $g->vertices; + my $V = @V; + my $Z = "\0" x (($V + 7) / 8); + my %V; @V{ @V } = 0 .. $#V; + my $bm = bless [ [ ( $Z ) x $V ], \%V ], $class; + my $bm0 = $bm->[0]; + my $connect_edges; + if (exists $opt{connect_edges}) { + $connect_edges = $opt{connect_edges}; + delete $opt{connect_edges}; + } + $connect_edges = 1 unless defined $connect_edges; + Graph::_opt_unknown(\%opt); + if ($connect_edges) { + # for (my $i = 0; $i <= $#V; $i++) { + # my $u = $V[$i]; + # for (my $j = 0; $j <= $#V; $j++) { + # vec($bm0->[$i], $j, 1) = 1 if $g->has_edge($u, $V[$j]); + # } + # } + my $Vi = $g->[_V]->[_i]; + my $Ei = $g->[_E]->[_i]; + if ($g->is_undirected) { + for my $e (keys %{ $Ei }) { + my ($i0, $j0) = @{ $Ei->{ $e } }; + my $i1 = $V{ $Vi->{ $i0 } }; + my $j1 = $V{ $Vi->{ $j0 } }; + vec($bm0->[$i1], $j1, 1) = 1; + vec($bm0->[$j1], $i1, 1) = 1; + } + } else { + for my $e (keys %{ $Ei }) { + my ($i0, $j0) = @{ $Ei->{ $e } }; + vec($bm0->[$V{ $Vi->{ $i0 } }], $V{ $Vi->{ $j0 } }, 1) = 1; + } + } + } + return $bm; +} + +sub set { + my ($m, $u, $v) = @_; + my ($i, $j) = map { $m->[1]->{ $_ } } ($u, $v); + vec($m->[0]->[$i], $j, 1) = 1 if defined $i && defined $j; +} + +sub unset { + my ($m, $u, $v) = @_; + my ($i, $j) = map { $m->[1]->{ $_ } } ($u, $v); + vec($m->[0]->[$i], $j, 1) = 0 if defined $i && defined $j; +} + +sub get { + my ($m, $u, $v) = @_; + my ($i, $j) = map { $m->[1]->{ $_ } } ($u, $v); + defined $i && defined $j ? vec($m->[0]->[$i], $j, 1) : undef; +} + +sub set_row { + my ($m, $u) = splice @_, 0, 2; + my $m0 = $m->[0]; + my $m1 = $m->[1]; + my $i = $m1->{ $u }; + return unless defined $i; + for my $v (@_) { + my $j = $m1->{ $v }; + vec($m0->[$i], $j, 1) = 1 if defined $j; + } +} + +sub unset_row { + my ($m, $u) = splice @_, 0, 2; + my $m0 = $m->[0]; + my $m1 = $m->[1]; + my $i = $m1->{ $u }; + return unless defined $i; + for my $v (@_) { + my $j = $m1->{ $v }; + vec($m0->[$i], $j, 1) = 0 if defined $j; + } +} + +sub get_row { + my ($m, $u) = splice @_, 0, 2; + my $m0 = $m->[0]; + my $m1 = $m->[1]; + my $i = $m1->{ $u }; + return () x @_ unless defined $i; + my @r; + for my $v (@_) { + my $j = $m1->{ $v }; + push @r, defined $j ? (vec($m0->[$i], $j, 1) ? 1 : 0) : undef; + } + return @r; +} + +sub vertices { + my ($m, $u, $v) = @_; + keys %{ $m->[1] }; +} + +1; +__END__ +=pod + +=head1 NAME + +Graph::BitMatrix - create and manipulate a V x V bit matrix of graph G + +=head1 SYNOPSIS + + use Graph::BitMatrix; + use Graph::Directed; + my $g = Graph::Directed->new; + $g->add_...(); # build $g + my $m = Graph::BitMatrix->new($g, %opt); + $m->get($u, $v) + $m->set($u, $v) + $m->unset($u, $v) + $m->get_row($u, $v1, $v2, ..., $vn) + $m->set_row($u, $v1, $v2, ..., $vn) + $m->unset_row($u, $v1, $v2, ..., $vn) + $a->vertices() + +=head1 DESCRIPTION + +This class enables creating bit matrices that compactly describe +the connected of the graphs. + +=head2 Class Methods + +=over 4 + +=item new($g) + +Create a bit matrix from a Graph $g. The C<%opt>, if present, +can have the following options: + +=over 8 + +=item * + +connect_edges + +If true or if not present, set the bits in the bit matrix that +correspond to edges. If false, do not set any bits. In either +case the bit matrix of V x V bits is allocated. + +=back + +=back + +=head2 Object Methods + +=over 4 + +=item get($u, $v) + +Return true if the bit matrix has a "one bit" between the vertices +$u and $v; in other words, if there is (at least one) a vertex going from +$u to $v. If there is no vertex and therefore a "zero bit", return false. + +=item set($u, $v) + +Set the bit between the vertices $u and $v; in other words, connect +the vertices $u and $v by an edge. The change does not get mirrored +back to the original graph. Returns nothing. + +=item unset($u, $v) + +Unset the bit between the vertices $u and $v; in other words, disconnect +the vertices $u and $v by an edge. The change does not get mirrored +back to the original graph. Returns nothing. + +=item get_row($u, $v1, $v2, ..., $vn) + +Test the row at vertex C 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 new file mode 100644 index 0000000..9c3fc86 --- /dev/null +++ b/perllib/Graph/Directed.pm @@ -0,0 +1,44 @@ +package Graph::Directed; + +use Graph; +use base 'Graph'; +use strict; + +=pod + +=head1 NAME + +Graph::Directed - directed graphs + +=head1 SYNOPSIS + + use Graph::Directed; + my $g = Graph::Directed->new; + + # Or alternatively: + + use Graph; + my $g = Graph->new(directed => 1); + my $g = Graph->new(undirected => 0); + +=head1 DESCRIPTION + +Graph::Directed allows you to create directed graphs. + +For the available methods, see L. + +=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 new file mode 100644 index 0000000..32bc001 --- /dev/null +++ b/perllib/Graph/MSTHeapElem.pm @@ -0,0 +1,24 @@ +package Graph::MSTHeapElem; + +use strict; +use vars qw($VERSION @ISA); +use Heap071::Elem; + +use base 'Heap071::Elem'; + +$VERSION = 0.01; + +sub new { + my $class = shift; + bless { u => $_[0], v => $_[1], w => $_[2] }, $class; +} + +sub cmp { + ($_[0]->{ w } || 0) <=> ($_[1]->{ w } || 0); +} + +sub val { + @{ $_[0] }{ qw(u v w) }; +} + +1; diff --git a/perllib/Graph/Matrix.pm b/perllib/Graph/Matrix.pm new file mode 100644 index 0000000..d3b9d40 --- /dev/null +++ b/perllib/Graph/Matrix.pm @@ -0,0 +1,82 @@ +package Graph::Matrix; + +# $SIG{__DIE__ } = sub { use Carp; confess }; +# $SIG{__WARN__} = sub { use Carp; confess }; + +use strict; + +sub new { + my ($class, $g) = @_; + my @V = $g->vertices; + my $V = @V; + my %V; @V{ @V } = 0 .. $#V; + bless [ [ map { [ ] } 0 .. $#V ], \%V ], $class; +} + +sub set { + my ($m, $u, $v, $val) = @_; + my ($i, $j) = map { $m->[1]->{ $_ } } ($u, $v); + $m->[0]->[$i]->[$j] = $val; +} + +sub get { + my ($m, $u, $v) = @_; + my ($i, $j) = map { $m->[1]->{ $_ } } ($u, $v); + $m->[0]->[$i]->[$j]; +} + +1; +__END__ +=pod + +=head1 NAME + +Graph::Matrix - create and manipulate a V x V matrix of graph G + +=head1 SYNOPSIS + + use Graph::Matrix; + use Graph::Directed; + my $g = Graph::Directed->new; + $g->add_...(); # build $g + my $m = Graph::Matrix->new($g); + $m->get($u, $v) + $s->get($u, $v, $val) + +=head1 DESCRIPTION + +B + +=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 new file mode 100644 index 0000000..0455531 --- /dev/null +++ b/perllib/Graph/SPTHeapElem.pm @@ -0,0 +1,26 @@ +package Graph::SPTHeapElem; + +use strict; +use vars qw($VERSION @ISA); +use Heap071::Elem; + +use base 'Heap071::Elem'; + +$VERSION = 0.01; + +sub new { + my $class = shift; + bless { u => $_[0], v => $_[1], w => $_[2] }, $class; +} + +sub cmp { + ($_[0]->{ w } || 0) <=> ($_[1]->{ w } || 0) || + ($_[0]->{ u } cmp $_[1]->{ u }) || + ($_[0]->{ u } cmp $_[1]->{ v }); +} + +sub val { + @{ $_[0] }{ qw(u v w) }; +} + +1; diff --git a/perllib/Graph/TransitiveClosure.pm b/perllib/Graph/TransitiveClosure.pm new file mode 100644 index 0000000..fd5a0a8 --- /dev/null +++ b/perllib/Graph/TransitiveClosure.pm @@ -0,0 +1,155 @@ +package Graph::TransitiveClosure; + +# COMMENT THESE OUT FOR TESTING AND PRODUCTION. +# $SIG{__DIE__ } = sub { use Carp; confess }; +# $SIG{__WARN__} = sub { use Carp; confess }; + +use base 'Graph'; +use Graph::TransitiveClosure::Matrix; + +sub _G () { Graph::_G() } + +sub new { + my ($class, $g, %opt) = @_; + $g->expect_non_multiedged; + %opt = (path_vertices => 1) unless %opt; + my $attr = Graph::_defattr(); + if (exists $opt{ attribute_name }) { + $attr = $opt{ attribute_name }; + # No delete $opt{ attribute_name } since we need to pass it on. + } + $opt{ reflexive } = 1 unless exists $opt{ reflexive }; + my $tcm = $g->new( $opt{ reflexive } ? + ( vertices => [ $g->vertices ] ) : ( ) ); + my $tcg = $g->get_graph_attribute('_tcg'); + if (defined $tcg && $tcg->[ 0 ] == $g->[ _G ]) { + $tcg = $tcg->[ 1 ]; + } else { + $tcg = Graph::TransitiveClosure::Matrix->new($g, %opt); + $g->set_graph_attribute('_tcg', [ $g->[ _G ], $tcg ]); + } + my $tcg00 = $tcg->[0]->[0]; + my $tcg11 = $tcg->[1]->[1]; + for my $u ($tcg->vertices) { + my $tcg00i = $tcg00->[ $tcg11->{ $u } ]; + for my $v ($tcg->vertices) { + next if $u eq $v && ! $opt{ reflexive }; + my $j = $tcg11->{ $v }; + if ( + # $tcg->is_transitive($u, $v) + # $tcg->[0]->get($u, $v) + vec($tcg00i, $j, 1) + ) { + my $val = $g->_get_edge_attribute($u, $v, $attr); + $tcm->_set_edge_attribute($u, $v, $attr, + defined $val ? $val : + $u eq $v ? + 0 : 1); + } + } + } + $tcm->set_graph_attribute('_tcm', $tcg); + bless $tcm, $class; +} + +sub is_transitive { + my $g = shift; + Graph::TransitiveClosure::Matrix::is_transitive($g); +} + +1; +__END__ +=pod + +Graph::TransitiveClosure - create and query transitive closure of graph + +=head1 SYNOPSIS + + use Graph::TransitiveClosure; + use Graph::Directed; # or Undirected + + my $g = Graph::Directed->new; + $g->add_...(); # build $g + + # Compute the transitive closure graph. + my $tcg = Graph::TransitiveClosure->new($g); + $tcg->is_reachable($u, $v) # Identical to $tcg->has_edge($u, $v) + + # Being reflexive is the default, meaning that null transitions + # (transitions from a vertex to the same vertex) are included. + my $tcg = Graph::TransitiveClosure->new($g, reflexive => 1); + my $tcg = Graph::TransitiveClosure->new($g, reflexive => 0); + + # is_reachable(u, v) is always reflexive. + $tcg->is_reachable($u, $v) + + # The reflexivity of is_transitive(u, v) depends of the reflexivity + # of the transitive closure. + $tcg->is_transitive($u, $v) + + # You can check any graph for transitivity. + $g->is_transitive() + + my $tcg = Graph::TransitiveClosure->new($g, path_length => 1); + $tcg->path_length($u, $v) + + # path_vertices is automatically always on so this is a no-op. + my $tcg = Graph::TransitiveClosure->new($g, path_vertices => 1); + $tcg->path_vertices($u, $v) + + # Both path_length and path_vertices. + my $tcg = Graph::TransitiveClosure->new($g, path => 1); + $tcg->path_vertices($u, $v) + $tcg->length($u, $v) + + my $tcg = Graph::TransitiveClosure->new($g, attribute_name => 'length'); + $tcg->path_length($u, $v) + +=head1 DESCRIPTION + +You can use C 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 new file mode 100644 index 0000000..be56f2a --- /dev/null +++ b/perllib/Graph/TransitiveClosure/Matrix.pm @@ -0,0 +1,488 @@ +package Graph::TransitiveClosure::Matrix; + +use strict; + +use Graph::AdjacencyMatrix; +use Graph::Matrix; + +sub _new { + my ($g, $class, $opt, $want_transitive, $want_reflexive, $want_path, $want_path_vertices) = @_; + my $m = Graph::AdjacencyMatrix->new($g, %$opt); + my @V = $g->vertices; + my $am = $m->adjacency_matrix; + my $dm; # The distance matrix. + my $pm; # The predecessor matrix. + my @di; + my %di; @di{ @V } = 0..$#V; + my @ai = @{ $am->[0] }; + my %ai = %{ $am->[1] }; + my @pi; + my %pi; + unless ($want_transitive) { + $dm = $m->distance_matrix; + @di = @{ $dm->[0] }; + %di = %{ $dm->[1] }; + $pm = Graph::Matrix->new($g); + @pi = @{ $pm->[0] }; + %pi = %{ $pm->[1] }; + for my $u (@V) { + my $diu = $di{$u}; + my $aiu = $ai{$u}; + for my $v (@V) { + my $div = $di{$v}; + my $aiv = $ai{$v}; + next unless + # $am->get($u, $v) + vec($ai[$aiu], $aiv, 1) + ; + # $dm->set($u, $v, $u eq $v ? 0 : 1) + $di[$diu]->[$div] = $u eq $v ? 0 : 1 + unless + defined + # $dm->get($u, $v) + $di[$diu]->[$div] + ; + $pi[$diu]->[$div] = $v unless $u eq $v; + } + } + } + # XXX (see the bits below): sometimes, being nice and clean is the + # wrong thing to do. In this case, using the public API for graph + # transitive matrices and bitmatrices makes things awfully slow. + # Instead, we go straight for the jugular of the data structures. + for my $u (@V) { + my $diu = $di{$u}; + my $aiu = $ai{$u}; + my $didiu = $di[$diu]; + my $aiaiu = $ai[$aiu]; + for my $v (@V) { + my $div = $di{$v}; + my $aiv = $ai{$v}; + my $didiv = $di[$div]; + my $aiaiv = $ai[$aiv]; + if ( + # $am->get($v, $u) + vec($aiaiv, $aiu, 1) + || ($want_reflexive && $u eq $v)) { + my $aivivo = $aiaiv; + if ($want_transitive) { + if ($want_reflexive) { + for my $w (@V) { + next if $w eq $u; + my $aiw = $ai{$w}; + return 0 + if vec($aiaiu, $aiw, 1) && + !vec($aiaiv, $aiw, 1); + } + # See XXX above. + # for my $w (@V) { + # my $aiw = $ai{$w}; + # if ( + # # $am->get($u, $w) + # vec($aiaiu, $aiw, 1) + # || ($u eq $w)) { + # return 0 + # if $u ne $w && + # # !$am->get($v, $w) + # !vec($aiaiv, $aiw, 1) + # ; + # # $am->set($v, $w) + # vec($aiaiv, $aiw, 1) = 1 + # ; + # } + # } + } else { + # See XXX above. + # for my $w (@V) { + # my $aiw = $ai{$w}; + # if ( + # # $am->get($u, $w) + # vec($aiaiu, $aiw, 1) + # ) { + # return 0 + # if $u ne $w && + # # !$am->get($v, $w) + # !vec($aiaiv, $aiw, 1) + # ; + # # $am->set($v, $w) + # vec($aiaiv, $aiw, 1) = 1 + # ; + # } + # } + $aiaiv |= $aiaiu; + } + } else { + if ($want_reflexive) { + $aiaiv |= $aiaiu; + vec($aiaiv, $aiu, 1) = 1; + # See XXX above. + # for my $w (@V) { + # my $aiw = $ai{$w}; + # if ( + # # $am->get($u, $w) + # vec($aiaiu, $aiw, 1) + # || ($u eq $w)) { + # # $am->set($v, $w) + # vec($aiaiv, $aiw, 1) = 1 + # ; + # } + # } + } else { + $aiaiv |= $aiaiu; + # See XXX above. + # for my $w (@V) { + # my $aiw = $ai{$w}; + # if ( + # # $am->get($u, $w) + # vec($aiaiu, $aiw, 1) + # ) { + # # $am->set($v, $w) + # vec($aiaiv, $aiw, 1) = 1 + # ; + # } + # } + } + } + if ($aiaiv ne $aivivo) { + $ai[$aiv] = $aiaiv; + $aiaiu = $aiaiv if $u eq $v; + } + } + if ($want_path && !$want_transitive) { + for my $w (@V) { + my $aiw = $ai{$w}; + next unless + # See XXX above. + # $am->get($v, $u) + vec($aiaiv, $aiu, 1) + && + # See XXX above. + # $am->get($u, $w) + vec($aiaiu, $aiw, 1) + ; + my $diw = $di{$w}; + my ($d0, $d1a, $d1b); + if (defined $dm) { + # See XXX above. + # $d0 = $dm->get($v, $w); + # $d1a = $dm->get($v, $u) || 1; + # $d1b = $dm->get($u, $w) || 1; + $d0 = $didiv->[$diw]; + $d1a = $didiv->[$diu] || 1; + $d1b = $didiu->[$diw] || 1; + } else { + $d1a = 1; + $d1b = 1; + } + my $d1 = $d1a + $d1b; + if (!defined $d0 || ($d1 < $d0)) { + # print "d1 = $d1a ($v, $u) + $d1b ($u, $w) = $d1 ($v, $w) (".(defined$d0?$d0:"-").")\n"; + # See XXX above. + # $dm->set($v, $w, $d1); + $didiv->[$diw] = $d1; + $pi[$div]->[$diw] = $pi[$div]->[$diu] + if $want_path_vertices; + } + } + # $dm->set($u, $v, 1) + $didiu->[$div] = 1 + if $u ne $v && + # $am->get($u, $v) + vec($aiaiu, $aiv, 1) + && + # !defined $dm->get($u, $v); + !defined $didiu->[$div]; + } + } + } + return 1 if $want_transitive; + my %V; @V{ @V } = @V; + $am->[0] = \@ai; + $am->[1] = \%ai; + if (defined $dm) { + $dm->[0] = \@di; + $dm->[1] = \%di; + } + if (defined $pm) { + $pm->[0] = \@pi; + $pm->[1] = \%pi; + } + bless [ $am, $dm, $pm, \%V ], $class; +} + +sub new { + my ($class, $g, %opt) = @_; + my %am_opt = (distance_matrix => 1); + if (exists $opt{attribute_name}) { + $am_opt{attribute_name} = $opt{attribute_name}; + delete $opt{attribute_name}; + } + if ($opt{distance_matrix}) { + $am_opt{distance_matrix} = $opt{distance_matrix}; + } + delete $opt{distance_matrix}; + if (exists $opt{path}) { + $opt{path_length} = $opt{path}; + $opt{path_vertices} = $opt{path}; + delete $opt{path}; + } + my $want_path_length; + if (exists $opt{path_length}) { + $want_path_length = $opt{path_length}; + delete $opt{path_length}; + } + my $want_path_vertices; + if (exists $opt{path_vertices}) { + $want_path_vertices = $opt{path_vertices}; + delete $opt{path_vertices}; + } + my $want_reflexive; + if (exists $opt{reflexive}) { + $want_reflexive = $opt{reflexive}; + delete $opt{reflexive}; + } + my $want_transitive; + if (exists $opt{is_transitive}) { + $want_transitive = $opt{is_transitive}; + $am_opt{is_transitive} = $want_transitive; + delete $opt{is_transitive}; + } + die "Graph::TransitiveClosure::Matrix::new: Unknown options: @{[map { qq['$_' => $opt{$_}]} keys %opt]}" + if keys %opt; + $want_reflexive = 1 unless defined $want_reflexive; + my $want_path = $want_path_length || $want_path_vertices; + # $g->expect_dag if $want_path; + _new($g, $class, + \%am_opt, + $want_transitive, $want_reflexive, + $want_path, $want_path_vertices); +} + +sub has_vertices { + my $tc = shift; + for my $v (@_) { + return 0 unless exists $tc->[3]->{ $v }; + } + return 1; +} + +sub is_reachable { + my ($tc, $u, $v) = @_; + return undef unless $tc->has_vertices($u, $v); + return 1 if $u eq $v; + $tc->[0]->get($u, $v); +} + +sub is_transitive { + if (@_ == 1) { # Any graph. + __PACKAGE__->new($_[0], is_transitive => 1); # Scary. + } else { # A TC graph. + my ($tc, $u, $v) = @_; + return undef unless $tc->has_vertices($u, $v); + $tc->[0]->get($u, $v); + } +} + +sub vertices { + my $tc = shift; + values %{ $tc->[3] }; +} + +sub path_length { + my ($tc, $u, $v) = @_; + return undef unless $tc->has_vertices($u, $v); + return 0 if $u eq $v; + $tc->[1]->get($u, $v); +} + +sub path_predecessor { + my ($tc, $u, $v) = @_; + return undef if $u eq $v; + return undef unless $tc->has_vertices($u, $v); + $tc->[2]->get($u, $v); +} + +sub path_vertices { + my ($tc, $u, $v) = @_; + return unless $tc->is_reachable($u, $v); + return wantarray ? () : 0 if $u eq $v; + my @v = ( $u ); + while ($u ne $v) { + last unless defined($u = $tc->path_predecessor($u, $v)); + push @v, $u; + } + $tc->[2]->set($u, $v, [ @v ]) if @v; + return @v; +} + +1; +__END__ +=pod + +=head1 NAME + +Graph::TransitiveClosure::Matrix - create and query transitive closure of graph + +=head1 SYNOPSIS + + use Graph::TransitiveClosure::Matrix; + use Graph::Directed; # or Undirected + + my $g = Graph::Directed->new; + $g->add_...(); # build $g + + # Compute the transitive closure matrix. + my $tcm = Graph::TransitiveClosure::Matrix->new($g); + + # Being reflexive is the default, + # meaning that null transitions are included. + my $tcm = Graph::TransitiveClosure::Matrix->new($g, reflexive => 1); + $tcm->is_reachable($u, $v) + + # is_reachable(u, v) is always reflexive. + $tcm->is_reachable($u, $v) + + # The reflexivity of is_transitive(u, v) depends of the reflexivity + # of the transitive closure. + $tcg->is_transitive($u, $v) + + my $tcm = Graph::TransitiveClosure::Matrix->new($g, path_length => 1); + $tcm->path_length($u, $v) + + my $tcm = Graph::TransitiveClosure::Matrix->new($g, path_vertices => 1); + $tcm->path_vertices($u, $v) + + my $tcm = Graph::TransitiveClosure::Matrix->new($g, attribute_name => 'length'); + $tcm->path_length($u, $v) + + $tcm->vertices + +=head1 DESCRIPTION + +You can use C 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 new file mode 100644 index 0000000..edfc5b1 --- /dev/null +++ b/perllib/Graph/Traversal.pm @@ -0,0 +1,714 @@ +package Graph::Traversal; + +use strict; + +# $SIG{__DIE__ } = sub { use Carp; confess }; +# $SIG{__WARN__} = sub { use Carp; confess }; + +sub DEBUG () { 0 } + +sub reset { + my $self = shift; + $self->{ unseen } = { map { $_ => $_ } $self->{ graph }->vertices }; + $self->{ seen } = { }; + $self->{ order } = [ ]; + $self->{ preorder } = [ ]; + $self->{ postorder } = [ ]; + $self->{ roots } = [ ]; + $self->{ tree } = + Graph->new( directed => $self->{ graph }->directed ); + delete $self->{ terminate }; +} + +my $see = sub { + my $self = shift; + $self->see; +}; + +my $see_active = sub { + my $self = shift; + delete @{ $self->{ active } }{ $self->see }; +}; + +sub has_a_cycle { + my ($u, $v, $t, $s) = @_; + $s->{ has_a_cycle } = 1; + $t->terminate; +} + +sub find_a_cycle { + my ($u, $v, $t, $s) = @_; + my @cycle = ( $u ); + push @cycle, $v unless $u eq $v; + my $path = $t->{ order }; + if (@$path) { + my $i = $#$path; + while ($i >= 0 && $path->[ $i ] ne $v) { $i-- } + if ($i >= 0) { + unshift @cycle, @{ $path }[ $i+1 .. $#$path ]; + } + } + $s->{ a_cycle } = \@cycle; + $t->terminate; +} + +sub configure { + my ($self, %attr) = @_; + $self->{ pre } = $attr{ pre } if exists $attr{ pre }; + $self->{ post } = $attr{ post } if exists $attr{ post }; + $self->{ pre_vertex } = $attr{ pre_vertex } if exists $attr{ pre_vertex }; + $self->{ post_vertex } = $attr{ post_vertex } if exists $attr{ post_vertex }; + $self->{ pre_edge } = $attr{ pre_edge } if exists $attr{ pre_edge }; + $self->{ post_edge } = $attr{ post_edge } if exists $attr{ post_edge }; + if (exists $attr{ successor }) { # Graph 0.201 compatibility. + $self->{ tree_edge } = $self->{ non_tree_edge } = $attr{ successor }; + } + if (exists $attr{ unseen_successor }) { + if (exists $self->{ tree_edge }) { # Graph 0.201 compatibility. + my $old_tree_edge = $self->{ tree_edge }; + $self->{ tree_edge } = sub { + $old_tree_edge->( @_ ); + $attr{ unseen_successor }->( @_ ); + }; + } else { + $self->{ tree_edge } = $attr{ unseen_successor }; + } + } + if ($self->graph->multiedged || $self->graph->countedged) { + $self->{ seen_edge } = $attr{ seen_edge } if exists $attr{ seen_edge }; + if (exists $attr{ seen_successor }) { # Graph 0.201 compatibility. + $self->{ seen_edge } = $attr{ seen_edge }; + } + } + $self->{ non_tree_edge } = $attr{ non_tree_edge } if exists $attr{ non_tree_edge }; + $self->{ pre_edge } = $attr{ tree_edge } if exists $attr{ tree_edge }; + $self->{ back_edge } = $attr{ back_edge } if exists $attr{ back_edge }; + $self->{ down_edge } = $attr{ down_edge } if exists $attr{ down_edge }; + $self->{ cross_edge } = $attr{ cross_edge } if exists $attr{ cross_edge }; + if (exists $attr{ start }) { + $attr{ first_root } = $attr{ start }; + $attr{ next_root } = undef; + } + if (exists $attr{ get_next_root }) { + $attr{ next_root } = $attr{ get_next_root }; # Graph 0.201 compat. + } + $self->{ next_root } = + exists $attr{ next_root } ? + $attr{ next_root } : + $attr{ next_alphabetic } ? + \&Graph::_next_alphabetic : + $attr{ next_numeric } ? + \&Graph::_next_numeric : + \&Graph::_next_random; + $self->{ first_root } = + exists $attr{ first_root } ? + $attr{ first_root } : + exists $attr{ next_root } ? + $attr{ next_root } : + $attr{ next_alphabetic } ? + \&Graph::_next_alphabetic : + $attr{ next_numeric } ? + \&Graph::_next_numeric : + \&Graph::_next_random; + $self->{ next_successor } = + exists $attr{ next_successor } ? + $attr{ next_successor } : + $attr{ next_alphabetic } ? + \&Graph::_next_alphabetic : + $attr{ next_numeric } ? + \&Graph::_next_numeric : + \&Graph::_next_random; + if (exists $attr{ has_a_cycle }) { + my $has_a_cycle = + ref $attr{ has_a_cycle } eq 'CODE' ? + $attr{ has_a_cycle } : \&has_a_cycle; + $self->{ back_edge } = $has_a_cycle; + if ($self->{ graph }->is_undirected) { + $self->{ down_edge } = $has_a_cycle; + } + } + if (exists $attr{ find_a_cycle }) { + my $find_a_cycle = + ref $attr{ find_a_cycle } eq 'CODE' ? + $attr{ find_a_cycle } : \&find_a_cycle; + $self->{ back_edge } = $find_a_cycle; + if ($self->{ graph }->is_undirected) { + $self->{ down_edge } = $find_a_cycle; + } + } + $self->{ add } = \&add_order; + $self->{ see } = $see; + delete @attr{ qw( + pre post pre_edge post_edge + successor unseen_successor seen_successor + tree_edge non_tree_edge + back_edge down_edge cross_edge seen_edge + start get_next_root + next_root next_alphabetic next_numeric next_random next_successor + first_root + has_a_cycle find_a_cycle + ) }; + if (keys %attr) { + require Carp; + my @attr = sort keys %attr; + Carp::croak(sprintf "Graph::Traversal: unknown attribute%s @{[map { qq['$_'] } @attr]}\n", @attr == 1 ? '' : 's'); + } +} + +sub new { + my $class = shift; + my $g = shift; + unless (ref $g && $g->isa('Graph')) { + require Carp; + Carp::croak("Graph::Traversal: first argument is not a Graph"); + } + my $self = { graph => $g, state => { } }; + bless $self, $class; + $self->reset; + $self->configure( @_ ); + return $self; +} + +sub terminate { + my $self = shift; + $self->{ terminate } = 1; +} + +sub add_order { + my ($self, @next) = @_; + push @{ $self->{ order } }, @next; +} + +sub visit { + my ($self, @next) = @_; + delete @{ $self->{ unseen } }{ @next }; + print "unseen = @{[sort keys %{$self->{unseen}}]}\n" if DEBUG; + @{ $self->{ seen } }{ @next } = @next; + print "seen = @{[sort keys %{$self->{seen}}]}\n" if DEBUG; + $self->{ add }->( $self, @next ); + print "order = @{$self->{order}}\n" if DEBUG; + if (exists $self->{ pre }) { + my $p = $self->{ pre }; + for my $v (@next) { + $p->( $v, $self ); + } + } +} + +sub visit_preorder { + my ($self, @next) = @_; + push @{ $self->{ preorder } }, @next; + for my $v (@next) { + $self->{ preordern }->{ $v } = $self->{ preorderi }++; + } + print "preorder = @{$self->{preorder}}\n" if DEBUG; + $self->visit( @next ); +} + +sub visit_postorder { + my ($self) = @_; + my @post = reverse $self->{ see }->( $self ); + push @{ $self->{ postorder } }, @post; + for my $v (@post) { + $self->{ postordern }->{ $v } = $self->{ postorderi }++; + } + print "postorder = @{$self->{postorder}}\n" if DEBUG; + if (exists $self->{ post }) { + my $p = $self->{ post }; + for my $v (@post) { + $p->( $v, $self ) ; + } + } + if (exists $self->{ post_edge }) { + my $p = $self->{ post_edge }; + my $u = $self->current; + if (defined $u) { + for my $v (@post) { + $p->( $u, $v, $self, $self->{ state }); + } + } + } +} + +sub _callbacks { + my ($self, $current, @all) = @_; + return unless @all; + my $nontree = $self->{ non_tree_edge }; + my $back = $self->{ back_edge }; + my $down = $self->{ down_edge }; + my $cross = $self->{ cross_edge }; + my $seen = $self->{ seen_edge }; + my $bdc = defined $back || defined $down || defined $cross; + if (defined $nontree || $bdc || defined $seen) { + my $u = $current; + my $preu = $self->{ preordern }->{ $u }; + my $postu = $self->{ postordern }->{ $u }; + for my $v ( @all ) { + my $e = $self->{ tree }->has_edge( $u, $v ); + if ( !$e && (defined $nontree || $bdc) ) { + if ( exists $self->{ seen }->{ $v }) { + $nontree->( $u, $v, $self, $self->{ state }) + if $nontree; + if ($bdc) { + my $postv = $self->{ postordern }->{ $v }; + if ($back && + (!defined $postv || $postv >= $postu)) { + $back ->( $u, $v, $self, $self->{ state }); + } else { + my $prev = $self->{ preordern }->{ $v }; + if ($down && $prev > $preu) { + $down ->( $u, $v, $self, $self->{ state }); + } elsif ($cross && $prev < $preu) { + $cross->( $u, $v, $self, $self->{ state }); + } + } + } + } + } + if ($seen) { + my $c = $self->graph->get_edge_count($u, $v); + while ($c-- > 1) { + $seen->( $u, $v, $self, $self->{ state } ); + } + } + } + } +} + +sub next { + my $self = shift; + return undef if $self->{ terminate }; + my @next; + while ($self->seeing) { + my $current = $self->current; + print "current = $current\n" if DEBUG; + @next = $self->{ graph }->successors( $current ); + print "next.0 - @next\n" if DEBUG; + my %next; @next{ @next } = @next; +# delete $next{ $current }; + print "next.1 - @next\n" if DEBUG; + @next = keys %next; + my @all = @next; + print "all = @all\n" if DEBUG; + delete @next{ $self->seen }; + @next = keys %next; + print "next.2 - @next\n" if DEBUG; + if (@next) { + @next = $self->{ next_successor }->( $self, \%next ); + print "next.3 - @next\n" if DEBUG; + for my $v (@next) { + $self->{ tree }->add_edge( $current, $v ); + } + if (exists $self->{ pre_edge }) { + my $p = $self->{ pre_edge }; + my $u = $self->current; + for my $v (@next) { + $p->( $u, $v, $self, $self->{ state }); + } + } + last; + } else { + $self->visit_postorder; + } + return undef if $self->{ terminate }; + $self->_callbacks($current, @all); +# delete $next{ $current }; + } + print "next.4 - @next\n" if DEBUG; + unless (@next) { + unless ( @{ $self->{ roots } } ) { + my $first = $self->{ first_root }; + if (defined $first) { + @next = + ref $first eq 'CODE' ? + $self->{ first_root }->( $self, $self->{ unseen } ) : + $first; + return unless @next; + } + } + unless (@next) { + return unless defined $self->{ next_root }; + return unless @next = + $self->{ next_root }->( $self, $self->{ unseen } ); + } + return if exists $self->{ seen }->{ $next[0] }; # Sanity check. + print "next.5 - @next\n" if DEBUG; + push @{ $self->{ roots } }, $next[0]; + } + print "next.6 - @next\n" if DEBUG; + if (@next) { + $self->visit_preorder( @next ); + } + return $next[0]; +} + +sub _order { + my ($self, $order) = @_; + 1 while defined $self->next; + my $wantarray = wantarray; + if ($wantarray) { + @{ $self->{ $order } }; + } elsif (defined $wantarray) { + shift @{ $self->{ $order } }; + } +} + +sub preorder { + my $self = shift; + $self->_order( 'preorder' ); +} + +sub postorder { + my $self = shift; + $self->_order( 'postorder' ); +} + +sub unseen { + my $self = shift; + values %{ $self->{ unseen } }; +} + +sub seen { + my $self = shift; + values %{ $self->{ seen } }; +} + +sub seeing { + my $self = shift; + @{ $self->{ order } }; +} + +sub roots { + my $self = shift; + @{ $self->{ roots } }; +} + +sub is_root { + my ($self, $v) = @_; + for my $u (@{ $self->{ roots } }) { + return 1 if $u eq $v; + } + return 0; +} + +sub tree { + my $self = shift; + $self->{ tree }; +} + +sub graph { + my $self = shift; + $self->{ graph }; +} + +sub vertex_by_postorder { + my ($self, $i) = @_; + exists $self->{ postorder } && $self->{ postorder }->[ $i ]; +} + +sub postorder_by_vertex { + my ($self, $v) = @_; + exists $self->{ postordern } && $self->{ postordern }->{ $v }; +} + +sub postorder_vertices { + my ($self, $v) = @_; + exists $self->{ postordern } ? %{ $self->{ postordern } } : (); +} + +sub vertex_by_preorder { + my ($self, $i) = @_; + exists $self->{ preorder } && $self->{ preorder }->[ $i ]; +} + +sub preorder_by_vertex { + my ($self, $v) = @_; + exists $self->{ preordern } && $self->{ preordern }->{ $v }; +} + +sub preorder_vertices { + my ($self, $v) = @_; + exists $self->{ preordern } ? %{ $self->{ preordern } } : (); +} + +sub has_state { + my ($self, $var) = @_; + exists $self->{ state } && exists $self->{ state }->{ $var }; +} + +sub get_state { + my ($self, $var) = @_; + exists $self->{ state } ? $self->{ state }->{ $var } : undef; +} + +sub set_state { + my ($self, $var, $val) = @_; + $self->{ state }->{ $var } = $val; + return 1; +} + +sub delete_state { + my ($self, $var) = @_; + delete $self->{ state }->{ $var }; + delete $self->{ state } unless keys %{ $self->{ state } }; + return 1; +} + +1; +__END__ +=pod + +=head1 NAME + +Graph::Traversal - traverse graphs + +=head1 SYNOPSIS + +Don't use Graph::Traversal directly, use Graph::Traversal::DFS +or Graph::Traversal::BFS instead. + + use Graph; + my $g = Graph->new; + $g->add_edge(...); + use Graph::Traversal::...; + my $t = Graph::Traversal::...->new(%opt); + $t->... + +=head1 DESCRIPTION + +You can control how the graph is traversed by the various callback +parameters in the C<%opt>. In the parameters descriptions below the +$u and $v are vertices, and the $self is the traversal object itself. + +=head2 Callback parameters + +The following callback parameters are available: + +=over 4 + +=item tree_edge + +Called when traversing an edge that belongs to the traversal tree. +Called with arguments ($u, $v, $self). + +=item non_tree_edge + +Called when an edge is met which either leads back to the traversal tree +(either a C, 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 new file mode 100644 index 0000000..2678f72 --- /dev/null +++ b/perllib/Graph/Traversal/BFS.pm @@ -0,0 +1,59 @@ +package Graph::Traversal::BFS; + +use strict; + +use Graph::Traversal; +use base 'Graph::Traversal'; + +sub current { + my $self = shift; + $self->{ order }->[ 0 ]; +} + +sub see { + my $self = shift; + shift @{ $self->{ order } }; +} + +*bfs = \&Graph::Traversal::postorder; + +1; +__END__ +=pod + +=head1 NAME + +Graph::Traversal::BFS - breadth-first traversal of graphs + +=head1 SYNOPSIS + + use Graph; + my $g = Graph->new; + $g->add_edge(...); + use Graph::Traversal::BFS; + my $b = Graph::Traversal::BFS->new(%opt); + $b->bfs; # Do the traversal. + +=head1 DESCRIPTION + +With this class one can traverse a Graph in breadth-first order. + +The callback parameters %opt are explained in L. + +=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 new file mode 100644 index 0000000..4b109bd --- /dev/null +++ b/perllib/Graph/Traversal/DFS.pm @@ -0,0 +1,59 @@ +package Graph::Traversal::DFS; + +use strict; + +use Graph::Traversal; +use base 'Graph::Traversal'; + +sub current { + my $self = shift; + $self->{ order }->[ -1 ]; +} + +sub see { + my $self = shift; + pop @{ $self->{ order } }; +} + +*dfs = \&Graph::Traversal::postorder; + +1; +__END__ +=pod + +=head1 NAME + +Graph::Traversal::DFS - depth-first traversal of graphs + +=head1 SYNOPSIS + + use Graph; + my $g = Graph->new; + $g->add_edge(...); + use Graph::Traversal::DFS; + my $d = Graph::Traversal::DFS->new(%opt); + $d->dfs; # Do the traversal. + +=head1 DESCRIPTION + +With this class one can traverse a Graph in depth-first order. + +The callback parameters %opt are explained in L. + +=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 new file mode 100644 index 0000000..3993bb1 --- /dev/null +++ b/perllib/Graph/Undirected.pm @@ -0,0 +1,49 @@ +package Graph::Undirected; + +use Graph; +use base 'Graph'; +use strict; + +=pod + +=head1 NAME + +Graph::Undirected - undirected graphs + +=head1 SYNOPSIS + + use Graph::Undirected; + my $g = Graph::Undirected->new; + + # Or alternatively: + + use Graph; + my $g = Graph->new(undirected => 1); + my $g = Graph->new(directed => 0); + +=head1 DESCRIPTION + +Graph::Undirected allows you to create undirected graphs. + +For the available methods, see L. + +=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 new file mode 100644 index 0000000..83a921f --- /dev/null +++ b/perllib/Graph/UnionFind.pm @@ -0,0 +1,183 @@ +package Graph::UnionFind; + +use strict; + +sub _PARENT () { 0 } +sub _RANK () { 1 } + +sub new { + my $class = shift; + bless { }, $class; +} + +sub add { + my ($self, $elem) = @_; + $self->{ $elem } = [ $elem, 0 ]; +} + +sub has { + my ($self, $elem) = @_; + exists $self->{ $elem }; +} + +sub _parent { + return undef unless defined $_[1]; + if (@_ == 2) { + exists $_[0]->{ $_[ 1 ] } ? $_[0]->{ $_[1] }->[ _PARENT ] : undef; + } elsif (@_ == 3) { + $_[0]->{ $_[1] }->[ _PARENT ] = $_[2]; + } else { + require Carp; + Carp::croak(__PACKAGE__ . "::_parent: bad arity"); + } +} + +sub _rank { + return unless defined $_[1]; + if (@_ == 2) { + exists $_[0]->{ $_[1] } ? $_[0]->{ $_[1] }->[ _RANK ] : undef; + } elsif (@_ == 3) { + $_[0]->{ $_[1] }->[ _RANK ] = $_[2]; + } else { + require Carp; + Carp::croak(__PACKAGE__ . "::_rank: bad arity"); + } +} + +sub find { + my ($self, $x) = @_; + my $px = $self->_parent( $x ); + return unless defined $px; + $self->_parent( $x, $self->find( $px ) ) if $px ne $x; + $self->_parent( $x ); +} + +sub union { + my ($self, $x, $y) = @_; + $self->add($x) unless $self->has($x); + $self->add($y) unless $self->has($y); + my $px = $self->find( $x ); + my $py = $self->find( $y ); + return if $px eq $py; + my $rx = $self->_rank( $px ); + my $ry = $self->_rank( $py ); + # print "union($x, $y): px = $px, py = $py, rx = $rx, ry = $ry\n"; + if ( $rx > $ry ) { + $self->_parent( $py, $px ); + } else { + $self->_parent( $px, $py ); + $self->_rank( $py, $ry + 1 ) if $rx == $ry; + } +} + +sub same { + my ($uf, $u, $v) = @_; + my $fu = $uf->find($u); + return undef unless defined $fu; + my $fv = $uf->find($v); + return undef unless defined $fv; + $fu eq $fv; +} + +1; +__END__ +=pod + +=head1 NAME + +Graph::UnionFind - union-find data structures + +=head1 SYNOPSIS + + use Graph::UnionFind; + my $uf = Graph::UnionFind->new; + + # Add the vertices to the data structure. + $uf->add($u); + $uf->add($v); + + # Join the partitions of the vertices. + $uf->union( $u, $v ); + + # Find the partitions the vertices belong to + # in the union-find data structure. If they + # are equal, they are in the same partition. + # If the vertex has not been seen, + # undef is returned. + my $pu = $uf->find( $u ); + my $pv = $uf->find( $v ); + $uf->same($u, $v) # Equal to $pu eq $pv. + + # Has the union-find seen this vertex? + $uf->has( $v ) + +=head1 DESCRIPTION + +I 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 new file mode 100644 index 0000000..40ae5dc --- /dev/null +++ b/perllib/Heap071/Elem.pm @@ -0,0 +1,159 @@ +package Heap071::Elem; + +use strict; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); + +require Exporter; +require AutoLoader; + +@ISA = qw(Exporter AutoLoader); + +# No names exported. +# No names available for export. + +@EXPORT = ( ); + +$VERSION = '0.71'; + + +# Preloaded methods go here. + +# new will usually be superceded by child, +# but provide an empty hash as default and +# accept any provided filling for it. +sub new { + my $self = shift; + my $class = ref($self) || $self; + + return bless { heap=>undef, @_ }, $class; +} + +sub heap { + my $self = shift; + @_ ? ($self->{heap} = shift) : $self->{heap}; +} + +sub cmp { + die "This cmp method must be superceded by one that knows how to compare elements." +} + +# Autoload methods go after =cut, and are processed by the autosplit program. + +1; +__END__ +# Below is the stub of documentation for your module. You better edit it! + +=head1 NAME + +Heap::Elem - Perl extension for elements to be put in Heaps + +=head1 SYNOPSIS + + use Heap::Elem::SomeInheritor; + + use Heap::SomeHeapClass; + + $elem = Heap::Elem::SomeInheritor->new( $value ); + $heap = Heap::SomeHeapClass->new; + + $heap->add($elem); + +=head1 DESCRIPTION + +This is an inheritable class for Heap Elements. It provides +the interface documentation and some inheritable methods. +Only a child classes can be used - this class is not complete. + +=head1 METHODS + +=over 4 + +=item $elem = Heap::Elem::SomeInheritor->new( [args] ); + +Creates a new Elem. + +=item $elem->heap( $val ); $elem->heap; + +Provides a method for use by the Heap processing routines. +If a value argument is provided, it will be saved. The +new saved value is always returned. If no value argument +is provided, the old saved value is returned. + +The Heap processing routines use this method to map an element +into its internal structure. This is needed to support the +Heap methods that affect elements that are not are the top +of the heap - I 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 new file mode 100644 index 0000000..3308bf3 --- /dev/null +++ b/perllib/Heap071/Fibonacci.pm @@ -0,0 +1,482 @@ +package Heap071::Fibonacci; + +use strict; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); + +require Exporter; +require AutoLoader; + +@ISA = qw(Exporter AutoLoader); + +# No names exported. +# No names available for export. +@EXPORT = ( ); + +$VERSION = '0.71'; + + +# Preloaded methods go here. + +# common names +# h - heap head +# el - linkable element, contains user-provided value +# v - user-provided value + +################################################# debugging control + +my $debug = 0; +my $validate = 0; + +# enable/disable debugging output +sub debug { + @_ ? ($debug = shift) : $debug; +} + +# enable/disable validation checks on values +sub validate { + @_ ? ($validate = shift) : $validate; +} + +my $width = 3; +my $bar = ' | '; +my $corner = ' +-'; +my $vfmt = "%3d"; + +sub set_width { + $width = shift; + $width = 2 if $width < 2; + + $vfmt = "%${width}d"; + $bar = $corner = ' ' x $width; + substr($bar,-2,1) = '|'; + substr($corner,-2,2) = '+-'; +} + +sub hdump; + +sub hdump { + my $el = shift; + my $l1 = shift; + my $b = shift; + + my $ch; + my $ch1; + + unless( $el ) { + print $l1, "\n"; + return; + } + + hdump $ch1 = $el->{child}, + $l1 . sprintf( $vfmt, $el->{val}->val), + $b . $bar; + + if( $ch1 ) { + for( $ch = $ch1->{right}; $ch != $ch1; $ch = $ch->{right} ) { + hdump $ch, $b . $corner, $b . $bar; + } + } +} + +sub heapdump { + my $h; + + while( $h = shift ) { + my $top = $$h or last; + my $el = $top; + + do { + hdump $el, sprintf( "%02d: ", $el->{degree}), ' '; + $el = $el->{right}; + } until $el == $top; + print "\n"; + } +} + +sub bhcheck; + +sub bhcheck { + my $el = shift; + my $p = shift; + + my $cur = $el; + my $prev; + my $ch; + do { + $prev = $cur; + $cur = $cur->{right}; + die "bad back link" unless $cur->{left} == $prev; + die "bad parent link" + unless (defined $p && defined $cur->{p} && $cur->{p} == $p) + || (!defined $p && !defined $cur->{p}); + die "bad degree( $cur->{degree} > $p->{degree} )" + if $p && $p->{degree} <= $cur->{degree}; + die "not heap ordered" + if $p && $p->{val}->cmp($cur->{val}) > 0; + $ch = $cur->{child} and bhcheck $ch, $cur; + } until $cur == $el; +} + + +sub heapcheck { + my $h; + my $el; + while( $h = shift ) { + heapdump $h if $validate >= 2; + $el = $$h and bhcheck $el, undef; + } +} + + +################################################# forward declarations + +sub ascending_cut; +sub elem; +sub elem_DESTROY; +sub link_to_left_of; + +################################################# heap methods + +# Cormen et al. use two values for the heap, a pointer to an element in the +# list at the top, and a count of the number of elements. The count is only +# used to determine the size of array required to hold log(count) pointers, +# but perl can set array sizes as needed and doesn't need to know their size +# when they are created, so we're not maintaining that field. +sub new { + my $self = shift; + my $class = ref($self) || $self; + my $h = undef; + bless \$h, $class; +} + +sub DESTROY { + my $h = shift; + + elem_DESTROY $$h; +} + +sub add { + my $h = shift; + my $v = shift; + $validate && do { + die "Method 'heap' required for element on heap" + unless $v->can('heap'); + die "Method 'cmp' required for element on heap" + unless $v->can('cmp'); + }; + my $el = elem $v; + my $top; + if( !($top = $$h) ) { + $$h = $el; + } else { + link_to_left_of $top->{left}, $el ; + link_to_left_of $el,$top; + $$h = $el if $v->cmp($top->{val}) < 0; + } +} + +sub top { + my $h = shift; + $$h && $$h->{val}; +} + +*minimum = \⊤ + +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