Initial commit of OpenSPARC T2 design and verification files.

[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / Graph / Base.pm

package Graph::Base;

use strict;
local $^W = 1;

use vars qw(@ISA);

=head1 NAME

Graph::Base - graph base class

=head1 SYNOPSIS

   use Graph::Directed;
   use Graph::Undirected;

   $d1 = new Graph;
   $d2 = new Graph::Directed;
   $u  = new Graph::Undirected;

=head1 DESCRIPTION

You create new graphs by calling the C<new> constructors of classes
C<Graph>, C<Graph::Directed>, and C<Graph::Undirected>.  The classes
C<Graph> and C<Graph::Directed> are identical.  After creating the
graph you can modify and explore the graph with following methods.

=over 4

=cut

require Exporter;
@ISA = qw(Exporter);

=pod

=item new

       $G = Graph->new(@V)

Returns a new graph $G with the optional vertices @V.

=cut

sub new {
  my $class = shift;

  my $G = { };

  bless $G, $class;

  $G->add_vertices(@_) if @_;

  return $G;
}

=pod

=item add_vertices

       $G = $G->add_vertices(@v)

Adds the vertices to the graph $G, returns the graph.

=cut

sub add_vertices {
   my ($G, @v) = @_;

   @{ $G->{ V } }{ @v } = @v;

   return $G;
}

=pod

=item add_vertex

       $G = $G->add_vertex($v)

Adds the vertex $v to the graph $G, returns the graph.

=cut

sub add_vertex {
   my ($G, $v) = @_;

   return $G->add_vertices($v);
}

=pod

=item vertices

       @V = $G->vertices

In list context returns the vertices @V of the graph $G.
In scalar context returns the number of the vertices.

=cut

sub vertices {
   my $G = shift;
   my @V = exists $G->{ V } ? sort values %{ $G->{ V } } : ();

   return @V;
}

=pod

=item has_vertices

       $G->has_vertices(@v)

In list context returns a list which contains the vertex
of the vertices @v if the vertex exists in the graph $G
and undef if it doesn't.  In scalar context returns the
number of the existing vertices.

=cut

sub has_vertices {
   my $G = shift;

   return wantarray ?
       map  { exists $G->{ V }->{ $_ } ? $_ : undef } @_ :
       grep { exists $G->{ V }->{ $_ }              } @_ ;
}

=pod

=item has_vertex

       $b = $G->has_vertex($v)

Returns true if the vertex $v exists in
the graph $G and false if it doesn't.

=cut

sub has_vertex {
   my ($G, $v) = @_;

   return defined $v && exists $G->{ V } && exists $G->{ V }->{ $v };
}

=pod

=item vertex

       $v = $G->has_vertex($v)

Returns the vertex $v if the vertex exists in the graph $G
or undef if it doesn't.

=cut

sub vertex {
   my ($G, $v) = @_;

   return defined $v && $G->{ V }->{ $v };
}

=pod

=item directed

       $b = $G->directed($d)

Set the directedness of the graph $G to $d or return the
current directedness.  Directedness defaults to true.

=cut

sub directed {
   my ($G, $d) = @_;

   if (defined $d) {
       if ($d) {
           my $o = $G->{ D }; # Old directedness.

           $G->{ D } = $d;
           if (not $o) {
               my @E = $G->edges;

               while (my ($u, $v) = splice(@E, 0, 2)) {
                   $G->add_edge($v, $u);
               }
           }

           return bless $G, 'Graph::Directed'; # Re-bless.
       } else {
           return $G->undirected(not $d);
       }
   }

   return $G->{ D };
}

=pod

=item undirected

       $b = $G->undirected($d)

Set the undirectedness of the graph $G to $u or return the
current undirectedness.  Undirectedness defaults to false.

=cut

sub undirected {
   my ($G, $u) = @_;

   $G->{ D } = 1 unless defined $G->{ D };

   if (defined $u) {
       if ($u) {
           my $o = $G->{ D }; # Old directedness.

           $G->{ D } = not $u;
           if ($o) {
               my @E = $G->edges;
               my %E;

               while (my ($u, $v) = splice(@E, 0, 2)) {
                   # Throw away duplicate edges.
                   $G->delete_edge($u, $v) if exists $E{$v}->{$u};
                   $E{$u}->{$v}++;
               }
           }

           return bless $G, 'Graph::Undirected'; # Re-bless.
       } else {
           return $G->directed(not $u);
       }
   }

   return not $G->{ D };
}

=pod

=item has_edge

       $b = $G->has_edge($u, $v)

Return true if the graph $G has the edge between
the vertices $u, $v.

=cut

sub has_edge {
   my ($G, $u, $v) = @_;

   return exists $G->{ Succ }->{ $u }->{ $v } ||
          ($G->undirected && exists $G->{ Succ }->{ $v }->{ $u });
}

=pod

=item has_edges

       $G->has_edges($u1, $v1, $u2, $v2, ...)

In list context returns a list which contains true for each
edge in the graph $G defined by the vertices $u1, $v1, ...,
and false for each non-existing edge.  In scalar context
returns the number of the existing edges.

=cut

sub has_edges {
   my $G = shift;
   my @e;

   while (my ($u, $v) = splice(@_, 0, 2)) {
       push @e, $G->has_edge($u, $v);
   }

   return wantarray ? @e : grep { $_ } @e;
}

=pod

=item has_path

       $G->has_path($u, $v, ...)

Return true if the graph $G has the cycle defined by
the vertices $u, $v, ..., false otherwise.

=cut

sub has_path {
   my $G = shift;
   my $u = shift;

   while (my $v = shift) {
       return 0 unless $G->has_edge($u, $v);
       $u = $v;
   }

   return 1;
}

=pod

=item has_cycle

       $G->has_cycle($u, $v, ...)

Return true if the graph $G has the cycle defined by
the vertices $u, $v, ...,false otherwise.

=cut

sub has_cycle {
   my $G = shift;

   return $G->has_path(@_, $_[0]); # Just wrap around.
}

# _union_vertex_set
#
#       $G->_union_vertex_set($u, $v)
#
#       (INTERNAL USE ONLY)
#       Adds the vertices $u and $v in the graph $G to the same vertex set.
#
sub _union_vertex_set {
   my ($G, $u, $v) = @_;

   my $su = $G->vertex_set( $u );
   my $sv = $G->vertex_set( $v );

   return if $su eq $sv;

   my $ru = $G->{ VertexSetRank }->{ $su };
   my $rv = $G->{ VertexSetRank }->{ $sv };
   
   if ( $ru < $rv ) {  # Union by rank (weight balancing).
       $G->{ VertexSetParent }->{ $su } = $sv;
   } else {
       $G->{ VertexSetParent }->{ $sv } = $su;
       $G->{ VertexSetRank   }->{ $sv }++ if $ru == $rv;
   }
}

=pod

=item vertex_set

       $s = $G->vertex_set($v)

Returns the vertex set of the vertex $v in the graph $G.
A "vertex set" is represented by its parent vertex.

=cut

sub vertex_set {
   my ($G, $v) = @_;

   if ( exists  $G->{ VertexSetParent }->{ $v } ) {
       # Path compression.
       $G->{ VertexSetParent }->{ $v } =
         $G->vertex_set( $G->{ VertexSetParent }->{ $v } )
           if $v ne $G->{ VertexSetParent }->{ $v };
   } else {
       $G->{ VertexSetParent }->{ $v } = $v;
       $G->{ VertexSetRank   }->{ $v } = 0;
   }

   return $G->{ VertexSetParent }->{ $v };
}

=pod

=item add_edge

       $G = $G->add_edge($u, $v)

Adds the edge defined by the vertices $u, $v, to the graph $G.
Also implicitly adds the vertices.  Returns the graph.

=cut

sub add_edge {
   my ($G, $u, $v) = @_;

   $G->add_vertex($u);
   $G->add_vertex($v);
   $G->_union_vertex_set( $u, $v );
   push @{ $G->{ Succ }->{ $u }->{ $v } }, $v;
   push @{ $G->{ Pred }->{ $v }->{ $u } }, $u;

   return $G;
}

=pod

=item add_edges

       $G = $G->add_edges($u1, $v1, $u2, $v2, ...)

Adds the edge defined by the vertices $u1, $v1, ...,
to the graph $G.  Also implicitly adds the vertices.
Returns the graph.

=cut

sub add_edges {
   my $G = shift;

   while (my ($u, $v) = splice(@_, 0, 2)) {
       $G->add_edge($u, $v);
   }

   return $G;
}

=pod

=item add_path

       $G->add_path($u, $v, ...)

Adds the path defined by the vertices $u, $v, ...,
to the graph $G.   Also implicitly adds the vertices.
Returns the graph.

=cut

sub add_path {
   my $G = shift;
   my $u = shift;

   while (my $v = shift) {
       $G->add_edge($u, $v);
       $u = $v;
   }

   return $G;
}

=pod

=item add_cycle

       $G = $G->add_cycle($u, $v, ...)

Adds the cycle defined by the vertices $u, $v, ...,
to the graph $G.  Also implicitly adds the vertices.
Returns the graph.

=cut

sub add_cycle {
   my $G = shift;

   $G->add_path(@_, $_[0]); # Just wrap around.
}

# _successors
#
#       @s = $G->_successors($v)
#
#       (INTERNAL USE ONLY, use only on directed graphs)
#       Returns the successor vertices @s of the vertex
#       in the graph $G.
#
sub _successors {
   my ($G, $v) = @_;

   my @s =
       defined $G->{ Succ }->{ $v } ?
           map { @{ $G->{ Succ }->{ $v }->{ $_ } } }
               sort keys %{ $G->{ Succ }->{ $v } } :
           ( );

   return @s;
}

# _predecessors
#
#       @p = $G->_predecessors($v)
#
#       (INTERNAL USE ONLY, use only on directed graphs)
#       Returns the predecessor vertices @p of the vertex $v
#       in the graph $G.
#
sub _predecessors {
   my ($G, $v) = @_;

   my @p =
       defined $G->{ Pred }->{ $v } ?
           map { @{ $G->{ Pred }->{ $v }->{ $_ } } }
               sort keys %{ $G->{ Pred }->{ $v } } :
           ( );

   return @p;
}

=pod

=item neighbors

       @n = $G->neighbors($v)

Returns the neighbor vertices of the vertex in the graph.
(Also 'neighbours' works.)

=cut

sub neighbors {
   my ($G, $v) = @_;

   my @n = ($G->_successors($v), $G->_predecessors($v));

   return @n;
}

use vars '*neighbours';
*neighbours = \&neighbors; # Keep both sides of the Atlantic happy.

=pod

=item successors

       @s = $G->successors($v)

Returns the successor vertices of the vertex in the graph.

=cut

sub successors {
   my ($G, $v) = @_;

   return $G->directed ? $G->_successors($v) : $G->neighbors($v);
}

=pod

=item predecessors

       @p = $G->predecessors($v)

Returns the predecessor vertices of the vertex in the graph.

=cut

sub predecessors {
   my ($G, $v) = @_;

   return $G->directed ? $G->_predecessors($v) : $G->neighbors($v);
}

=pod

=item out_edges

       @e = $G->out_edges($v)

Returns the edges leading out of the vertex $v in the graph $G.
In list context returns the edges as ($start_vertex, $end_vertex)
pairs.  In scalar context returns the number of the edges.

=cut

sub out_edges {
   my ($G, $v) = @_;

   return () unless $G->has_vertex($v);

   my @e = $G->_edges($v, undef);

   return wantarray ? @e : @e / 2;
}

=pod

=item in_edges

       @e = $G->in_edges($v)

Returns the edges leading into the vertex $v in the graph $G.
In list context returns the edges as ($start_vertex, $end_vertex)
pairs; in scalar context returns the number of the edges.

=cut

sub in_edges {
   my ($G, $v) = @_;

   return () unless $G->has_vertex($v);

   my @e = $G->_edges(undef, $v);

   return wantarray ? @e : @e / 2;
}

=pod

=item edges

       @e = $G->edges($u, $v)

Returns the edges between the vertices $u and $v, or if $v
is undefined, the edges leading into or out of the vertex $u,
or if $u is undefined, returns all the edges, of the graph $G.
In list context returns the edges as a list of
$start_vertex, $end_vertex pairs; in scalar context
returns the number of the edges.

=cut

sub edges {
   my ($G, $u, $v) = @_;

   return () if defined $v and not $G->has_vertex($v);

   my @e =
       defined $u ?
           ( defined $v ?
             $G->_edges($u, $v) :
             ($G->in_edges($u), $G->out_edges($u)) ) :
           $G->_edges;

   return wantarray ? @e : @e / 2;
}

=pod

=item delete_edge

       $G = $G->delete_edge($u, $v)

Deletes an edge defined by the vertices $u, $v from the graph $G.
Note that the edge need not actually exist.
Returns the graph.

=cut

sub delete_edge {
   my ($G, $u, $v) = @_;

   pop @{ $G->{ Succ }->{ $u }->{ $v } };
   pop @{ $G->{ Pred }->{ $v }->{ $u } };

   delete $G->{ Succ }->{ $u }->{ $v }
       unless @{ $G->{ Succ }->{ $u }->{ $v } };
   delete $G->{ Pred }->{ $v }->{ $u }
       unless @{ $G->{ Pred }->{ $v }->{ $u } };

   delete $G->{ Succ }->{ $u }
       unless keys %{ $G->{ Succ }->{ $u } };
   delete $G->{ Pred }->{ $v }
       unless keys %{ $G->{ Pred }->{ $v } };

   return $G;
}

=pod

=item delete_edges

       $G = $G->delete_edges($u1, $v1, $u2, $v2, ..)

Deletes edges defined by the vertices $u1, $v1, ...,
from the graph $G.
Note that the edges need not actually exist.
Returns the graph.

=cut

sub delete_edges {
   my $G = shift;

   while (my ($u, $v) = splice(@_, 0, 2)) {
       if (defined $v) {
           $G->delete_edge($u, $v);
       } else {
           my @e = $G->edges($u);

           while (($u, $v) = splice(@e, 0, 2)) {
               $G->delete_edge($u, $v);
           }
       }
   }

   return $G;
}

=pod

=item delete_path

       $G = $G->delete_path($u, $v, ...)

Deletes a path defined by the vertices $u, $v, ..., from the graph $G.
Note that the path need not actually exist. Returns the graph.

=cut

sub delete_path {
   my $G = shift;
   my $u = shift;

   while (my $v = shift) {
       $G->delete_edge($u, $v);
       $u = $v;
   }

   return $G;
}

=pod

=item delete_cycle

       $G = $G->delete_cycle($u, $v, ...)

Deletes a cycle defined by the vertices $u, $v, ..., from the graph $G.
Note that the cycle need not actually exist. Returns the graph.

=cut

sub delete_cycle {
   my $G = shift;

   $G->delete_path(@_, $_[0]); # Just wrap around.
}

=pod

=item delete_vertex

       $G = $G->delete_vertex($v)

Deletes the vertex $v and all its edges from the graph $G.
Note that the vertex need not actually exist.
Returns the graph.

=cut

sub delete_vertex {
   my ($G, $v) = @_;

   $G->delete_edges($v);

   delete $G->{ V }->{ $v };

   return $G;
}

=pod

=item delete_vertices

       $G = $G->delete_vertices(@v)

Deletes the vertices @v and all their edges from the graph $G.
Note that the vertices need not actually exist.
Returns the graph.

=cut

sub delete_vertices {
   my $G = shift;

   foreach my $v (@_) {
       $G->delete_vertex($v);
   }

   return $G;
}

=pod

=item in_degree

       $d = $G->in_degree($v)

Returns the in-degree of the vertex $v in the graph $G,
or, if $v is undefined, the total in-degree of all the
vertices of the graph, or undef if the vertex doesn't
exist in the graph.

=cut

sub in_degree {
   my ($G, $v) = @_;

   return undef unless $G->has_vertex($v);

   if ($G->directed) {
       if (defined $v) {
           return scalar $G->in_edges($v);
       } else {
           my $in = 0;
       
           foreach my $v ($G->vertices) {
               $in += $G->in_degree($v);
           }
       
           return $in;
       }
   } else {
       return scalar $G->edges($v);
   }
}

=pod

=item out_degree

       $d = $G->out_degree($v)

Returns the out-degree of the vertex $v in the graph $G,
or, if $v is undefined, the total out-degree of all the
vertices of the graph, of undef if the vertex doesn't
exist in the graph.

=cut

sub out_degree {
   my ($G, $v) = @_;

   return undef unless $G->has_vertex($v);

   if ($G->directed) {
       if (defined $v) {
           return scalar $G->out_edges($v);
       } else {
           my $out = 0;
       
           foreach my $v ($G->vertices) {
               $out += $G->out_degree($v);
           }
       
           return $out;
       }
   } else {
       return scalar $G->edges($v);
   }
}

=pod

=item degree

       $d = $G->degree($v)

Returns the degree of the vertex $v in the graph $G
or, if $v is undefined, the total degree of all the
vertices of the graph, or undef if the vertex $v
doesn't exist in the graph.

=cut

sub degree {
   my ($G, $v) = @_;

   if (defined $v) {
       return undef unless $G->has_vertex($v);

       if ($G->directed) {
           return $G->in_degree($v) - $G->out_degree($v);
       } else {
           return $G->edges($v);
       }
   } else {
       if ($G->directed) {
           return 0;
       } else {
           my $deg = 0;
       
           foreach my $v ($G->vertices) {
               $deg += $G->degree($v);
           }
       
           return $deg;
       }
   }
}

=pod

=item average_degree

       $d = $G->average_degree

Returns the average degree of the vertices of the graph $G.

=cut

sub average_degree {
   my $G = shift;
   my $V = $G->vertices;

   return $V ? $G->degree / $V : 0;
}

=pod

=item is_source_vertex

       $b = $G->is_source_vertex($v)

Returns true if the vertex $v is a source vertex of the graph $G.

=cut

sub is_source_vertex {
   my ($G, $v) = @_;

   $G->in_degree($v) == 0 && $G->out_degree($v) >  0;
}

=pod

=item is_sink_vertex

       $b = $G->is_sink_vertex($v)

Returns true if the vertex $v is a sink vertex of the graph $G.

=cut

sub is_sink_vertex {
   my ($G, $v) = @_;

   $G->in_degree($v) >  0 && $G->out_degree($v) == 0;
}

=pod

=item is_isolated_vertex

       $b = $G->is_isolated_vertex($v)

Returns true if the vertex $v is a isolated vertex of the graph $G.

=cut

sub is_isolated_vertex {
   my ($G, $v) = @_;

   $G->in_degree($v) == 0 && $G->out_degree($v) == 0;
}

=pod

=item is_exterior_vertex

       $b = $G->is_exterior_vertex($v)

Returns true if the vertex $v is a exterior vertex of the graph $G.

=cut

sub is_exterior_vertex {
   my ($G, $v) = @_;

   $G->in_degree($v) == 0 xor $G->out_degree($v) == 0;
}

=pod

=item is_interior_vertex

       $b = $G->is_interior_vertex($v)

Returns true if the vertex $v is a interior vertex of the graph $G.

=cut

sub is_interior_vertex {
   my ($G, $v) = @_;

   $G->in_degree($v)      && $G->out_degree($v);
}

=pod

=item is_self_loop_vertex

       $b = $G->is_self_loop_vertex($v)

Returns true if the vertex $v is a self-loop vertex of the graph $G.

=cut

sub is_self_loop_vertex {
   my ($G, $v) = @_;

   exists $G->{ Succ }->{ $v }->{ $v };
}

=pod

=item source_vertices

       @s = $G->source_vertices

Returns the source vertices @s of the graph $G.

=cut

sub source_vertices {
   my $G = shift;

   return grep { $G->is_source_vertex($_) } $G->vertices;
}

=pod

=item sink_vertices

       @s = $G->sink_vertices

Returns the sink vertices @s of the graph $G.

=cut

sub sink_vertices {
   my $G = shift;

   return grep { $G->is_sink_vertex($_) } $G->vertices;
}

=pod

=item isolated_vertices

       @i = $G->isolated_vertices

Returns the isolated vertices @i of the graph $G.

=cut

sub isolated_vertices {
   my $G = shift;

   return grep { $G->is_isolated_vertex($_) } $G->vertices;
}

=pod

=item exterior_vertices

       @e = $G->exterior_vertices

Returns the exterior vertices @e of the graph $G.

=cut

sub exterior_vertices {
   my $G = shift;

   return grep { $G->is_exterior_vertex($_) } $G->vertices;
}

=pod

=item interior_vertices

       @i = $G->interior_vertices

Returns the interior vertices @i of the graph $G.

=cut

sub interior_vertices {
   my $G = shift;

   return grep { $G->is_interior_vertex($_) } $G->vertices;
}

=pod

=item self_loop_vertices

       @s = $G->self_loop_vertices

Returns the self-loop vertices @s of the graph $G.

=cut

sub self_loop_vertices {
   my $G = shift;

   return grep { $G->is_self_loop_vertex($_) } $G->vertices;
}

=pod

=item density_limits

       ($sparse, $dense, $complete) = $G->density_limits

Returns the density limits for the number of edges
in the graph $G.  Note that reaching $complete edges
does not really guarantee completeness because we
can have multigraphs.  The limit of sparse is less
than 1/4 of the edges of the complete graph, the
limit of dense is more than 3/4 of the edges of the
complete graph.

=cut

sub density_limits {
   my $G = shift;

   my $V = $G->vertices;
   my $M = $V * ($V - 1);

   $M = $M / 2 if $G->undirected;

   return ($M/4, 3*$M/4, $M);
}

=pod

=item density

       $d = $G->density

Returns the density $d of the graph $G.

=cut

sub density {
   my $G = shift;
   my ($sparse, $dense, $complete) = $G->density_limits;

   return $complete ? $G->edges / $complete : 0;
}

=pod

=item is_sparse

       $d = $G->is_sparse

Returns true if the graph $G is sparse.

=cut

sub is_sparse {
   my $G = shift;
   my ($sparse, $dense, $complete) = $G->density_limits;

   return $complete ? $G->edges / $complete <= $dense : 1;
}

=pod

=item is_dense

       $d = $G->is_dense

Returns true if the graph $G is dense.

=cut

sub is_dense {
   my $G = shift;
   my ($sparse, $dense, $complete) = $G->density_limits;

   return $complete ? $G->edges / $complete >= $dense : 0;
}

=pod

=item complete

       $C = $G->complete;

Returns a new complete graph $C corresponding to the graph $G.

=cut

sub complete {
   my $G = shift;
   my $C = (ref $G)->new;
   my @V = $G->vertices;

   if ($G->directed) {
       foreach my $u (@V) {
           foreach my $v (@V) {
               $C->add_edge($u, $v) unless $u eq $v;
           }
       }
   } else {
       my %E;

       foreach my $u (@V) {
           foreach my $v (@V) {
               next if $u eq $v or $E{$u}->{$v} || $E{$v}->{$u};
               $C->add_edge($u, $v);
               $E{$u}->{$v}++;
               $E{$v}->{$u}++;
           }
       }
   }

   $C->directed($G->directed);

   return $C;
}

=pod

=item complement

       $C = $G->complement;

Returns a new complement graph $C corresponding to the graph $G.

=cut

sub complement {
   my $G = shift;
   my $C = $G->complete;

   if (my @E = $G->edges) {
       while (my ($u, $v) = splice(@E, 0, 2)) {
           $C->delete_edge($u, $v);
       }
   }

   return $C;
}

=pod

=item copy

       $C = $G->copy;

Returns a new graph $C corresponding to the graph $G.

=cut

sub copy {
   my $G = shift;
   my $C = (ref $G)->new($G->vertices);

   if (my @E = $G->edges) {
       while (my ($u, $v) = splice(@E, 0, 2)) {
           $C->add_edge($u, $v);
       }
   }

   $C->directed($G->directed);

   return $C;
}

=pod

=item transpose

       $T = $G->transpose;

Returns a new transpose graph $T corresponding to the graph $G.

=cut

sub transpose {
   my $G = shift;

   return $G->copy if $G->undirected;

   my $T = (ref $G)->new($G->vertices);

   if (my @E = $G->edges) {
       while (my ($u, $v) = splice(@E, 0, 2)) {
           $T->add_edge($v, $u);
       }
   }

   return $T;
}

# _stringify
#
#       $s = $G->_stringify($connector, $separator)
#
#       (INTERNAL USE ONLY)
#       Returns a string representation of the graph $G.
#       The edges are represented by $connector and edges/isolated
#       vertices are represented by $separator.
#
sub _stringify {
   my ($G, $connector, $separator) = @_;
   my @E = $G->edges;
   my @e = map { [ $_ ] } $G->isolated_vertices;

   while (my ($u, $v) = splice(@E, 0, 2)) {
       push @e, [$u, $v];
   }

   return join($separator,
              map { @$_ == 2 ?
                        join($connector, $_->[0], $_->[1]) :
                        $_->[0] }
                  sort { $a->[0] cmp $b->[0] || @$a <=> @$b } @e);
}

=pod

=item set_attribute

       $G->set_attribute($attribute, $value)
       $G->set_attribute($attribute, $v, $value)
       $G->set_attribute($attribute, $u, $v, $value)

Sets the $attribute of graph/vertex/edge to $value
but only if the vertex/edge already exists.  Returns
true if the attribute is set successfully, false if not.

=cut

sub set_attribute {
   my $G         = shift;
   my $attribute = shift;
   my $value     = pop;
   my ($u, $v)   = @_;

   if (defined $u) {
       return 0 unless $G->has_vertex($u);
       if (defined $v) {
           return 0 unless $G->has_edge($u, $v);
           $G->{ Attr }->{ E }->{ $u }->{ $v }->{ $attribute } = $value;
           $G->{ Attr }->{ E }->{ $v }->{ $u }->{ $attribute } = $value
               if $G->undirected;
       } else {
           $G->{ Attr }->{ V }->{ $u }->{ $attribute }         = $value;
       }
   } else {
       $G->{ Attr }->{ G }->{ $attribute }                     = $value;
   }

   return 1;
}

=pod

=item get_attribute

       $value = $G->get_attribute($attribute)
       $value = $G->get_attribute($attribute, $v)
       $value = $G->get_attribute($attribute, $u, $v)

Returns the $value of $attribute of graph/vertex/edge.

=cut

sub get_attribute {
   my $G         = shift;
   my $attribute = shift;
   my ($u, $v)   = @_;

   if (defined $u) {
       if (defined $v) {
           return undef
               unless exists $G->{ Attr }->{ E };

           my $E = $G->{ Attr }->{ E };

           if ( $G->directed ) {
               return $E->{ $u }->{ $v }->{ $attribute };
           } else {
               return undef
                   unless exists $G->{ Attr }->{ E };

               return $E->{ $u }->{ $v }->{ $attribute }
                   if exists $E->{ $u }->{ $v }->{ $attribute };

               return $E->{ $v }->{ $u }->{ $attribute };
           }
       } else {
           return $G->{ Attr }->{ V }->{ $u }->{ $attribute };
       }
   } else {
       return $G->{ Attr }->{ G }->{ $attribute };
   }
}

=pod

=item has_attribute

       $value = $G->has_attribute($attribute)
       $value = $G->has_attribute($attribute, $v)
       $value = $G->has_attribute($attribute, $u, $v)

Returns the $value of $attribute of graph/vertex/edge.

=cut

sub has_attribute {
   my $G         = shift;
   my $attribute = shift;
   my ($u, $v)   = @_;

   if (defined $u) {
       if (defined $v) {
           return undef
               unless exists $G->{ Attr }->{ E };

           my $E = $G->{ Attr }->{ E };

           if ( $G->directed ) {
               return exists $E->{ $u }->{ $v }->{ $attribute };
           } else {
               return exists $E->{ $u }->{ $v }->{ $attribute } or
                   exists $E->{ $v }->{ $u }->{ $attribute };
           }
       } else {
           exists $G->{ Attr }->{ V }->{ $u }->{ $attribute };
       }
   } else {
       exists $G->{ Attr } &&
           exists $G->{ Attr }->{ G }->{ $attribute };
   }
}

=pod

=item get_attributes

       %attributes = $G->get_attributes()
       %attributes = $G->get_attributes($v)
       %attributes = $G->get_attributes($u, $v)

Returns as a hash all the attribute names and values
of graph/vertex/edge.

=cut

sub get_attributes {
   my $G       = shift;
   my ($u, $v) = @_;

   return ( ) unless exists $G->{ Attr };
   if (defined $u) {
       if (defined $v) {
           return exists $G->{ Attr }->{ E } &&
                  exists $G->{ Attr }->{ E }->{ $u } &&
                  exists $G->{ Attr }->{ E }->{ $u }->{ $v } ?
                             %{ $G->{ Attr }->{ E }->{ $u }->{ $v } } :
                             ( );
       } else {
           return exists $G->{ Attr }->{ V } &&
                  exists $G->{ Attr }->{ V }->{ $u } ?
                      %{ $G->{ Attr }->{ V }->{ $u } } : ( );
       }
   } else {
       return exists $G->{ Attr }->{ G } ?
                  %{ $G->{ Attr }->{ G } } : ( );
   }
}

=pod

=item delete_attribute

       $G->delete_attribute($attribute)
       $G->delete_attribute($attribute, $v)
       $G->delete_attribute($attribute, $u, $v)

Deletes the $attribute of graph/vertex/edge.

=cut

sub delete_attribute {
   my $G         = shift;
   my $attribute = shift;
   my ($u, $v)   = @_;

   if (defined $u) {
       if (defined $v) {
           return undef
               unless exists $G->{ Attr }->{ E };

           my $E = $G->{ Attr }->{ E };

           if ( $G->directed ) {
               delete $E->{ $u }->{ $v }->{ $attribute };
           } else {
               delete $E->{ $v }->{ $u }->{ $attribute };
               delete $E->{ $v }->{ $u }->{ $attribute };
           }
       } else {
           delete $G->{ Attr }->{ V }->{ $u }->{ $attribute };
       }
   } else {
       delete $G->{ Attr }->{ G }->{ $attribute };
   }
}

=pod

=item delete_attributes

       $G->delete_attributes()
       $G->delete_attributes($v)
       $G->delete_attributes($u, $v)

Deletes all the attributes of graph/vertex/edge.

=cut

sub delete_attributes {
   my $G       = shift;
   my ($u, $v) = @_;

   if (defined $u) {
       if (defined $v) {
           delete $G->{ Attr }->{ E }->{ $u }->{ $v };
       } else {
           delete $G->{ Attr }->{ V }->{ $u };
       }
   } else {
       delete $G->{ Attr }->{ G };
   }
}

=pod

=item add_weighted_edge

       $G->add_weighted_edge($u, $w, $v, $a)

Adds in the graph $G an edge from vertex $u to vertex $v
and the edge attribute 'weight' set to $w.

=cut

sub add_weighted_edge {
   my ($G, $u, $w, $v, $a) = @_;

   $G->add_edge($u, $v);
   $G->set_attribute('weight', $u, $v, $w);
}

=pod

=item add_weighted_edges

       $G->add_weighted_edges($u1, $w1, $v1, $u2, $w2, $v2, ...)

Adds in the graph $G the weighted edges.

=cut

sub add_weighted_edges {
   my $G = shift;

   while (my ($u, $w, $v) = splice(@_, 0, 3)) {
       $G->add_weighted_edge($u, $w, $v);
   }
}

=pod

=item add_weighted_path

       $G->add_weighted_path($v1, $w1, $v2, $w2, ..., $wnm1, $vn)

Adds in the graph $G the n edges defined by the path $v1 ... $vn
with the n-1 'weight' attributes $w1 ... $wnm1

=cut

sub add_weighted_path {
   my $G = shift;
   my $u = shift;

   while (my ($w, $v) = splice(@_, 0, 2)) {
       $G->add_weighted_edge($u, $w, $v);
       $u = $v;
   }
}

=pod

=item MST_Kruskal

       $MST = $G->MST_Kruskal;

Returns Kruskal's Minimum Spanning Tree (as a graph) of
the graph $G based on the 'weight' attributes of the edges.
(Needs the ->vertex_set() method.)

=cut

sub MST_Kruskal {
   my $G   = shift;
   my $MST = (ref $G)->new;
   my @E   = $G->edges;
   my (@W, $u, $v, $w);

   while (($u, $v) = splice(@E, 0, 2)) {
       $w = $G->get_attribute('weight', $u, $v);
       next unless defined $w; # undef weight == infinitely heavy
       push @W, [ $u, $v, $w ];
   }

   $MST->directed( $G->directed );

   # Sort by weights.
   foreach my $e ( sort { $a->[ 2 ] <=> $b->[ 2 ] } @W ) {
       ($u, $v, $w) = @$e;
       $MST->add_weighted_edge( $u, $w, $v )
           unless $MST->vertex_set( $u ) eq $MST->vertex_set( $v );
   }

   return $MST;
}

=pod

=item edge_classify

       @C = $G->edge_classify(%param)

Returns the edge classification as a list where each element
is a triplet [$u, $v, $class] the $u, $v being the vertices
of an edge and $class being the class.  The %param can be
used to control the search.

=cut

sub edge_classify {
   my $G = shift;

   my $unseen_successor =
       sub {
           my ($u, $v, $T) = @_;
               
           # Freshly seen successors make for tree edges.
           push @{ $T->{ edge_class_list } },
                [ $u, $v, 'tree' ];
       };
   my $seen_successor =
       sub {
           my ($u, $v, $T) = @_;
                       
           my $class;
       
           if ( $T->{ G }->directed ) {
               $class = 'cross'; # Default for directed non-tree edges.

               unless ( exists $T->{ vertex_finished }->{ $v } ) {
                   $class = 'back';
               } elsif ( $T->{ vertex_found }->{ $u } <
                         $T->{ vertex_found }->{ $v }) {
                   $class = 'forward';
               }
           } else {
               # No cross nor forward edges in
               # an undirected graph, by definition.
               $class = 'back';
           }
       
           push @{ $T->{ edge_class_list } }, [ $u, $v, $class ];
       };
   use Graph::DFS;
   my $d =
       Graph::DFS->
           new( $G,
                unseen_successor => $unseen_successor,
                seen_successor   => $seen_successor,
                @_);

   $d->preorder;

   return @{ $d->{ edge_class_list } };
}

=pod

=item toposort

       @toposort = $G->toposort

Returns the vertices of the graph $G sorted topologically.

=cut

sub toposort {
   my $G = shift;
   my $d = Graph::DFS->new($G);

   reverse $d->postorder; # That's it.
}

# _strongly_connected
#
#       $s = $G->_strongly_connected
#
#       (INTERNAL USE ONLY)
#       Returns a graph traversal object that can be used for
#       strong connection computations.
#
sub _strongly_connected {
   my $G = shift;
   my $T = $G->transpose;

   Graph::DFS->
       new($T,
           # Pick the potential roots in their DFS postorder.
           strong_root_order => [ reverse Graph::DFS->new($G)->postorder ],
           get_next_root     =>
               sub {
                   my ($T, %param) = @_;
               
                   while (my $root =
                          shift @{ $param{ strong_root_order } }) {
                       return $root if exists $T->{ pool }->{ $root };
                   }
               }
          );
}

=pod

=item strongly_connected_components

       @S = $G->strongly_connected_components

Returns the strongly connected components @S of the graph $G
as a list of anonymous lists of vertices, each anonymous list
containing the vertices belonging to one strongly connected
component.

=cut

sub strongly_connected_components {
   my $G = shift;
   my $T = $G->_strongly_connected;
   my %R = $T->_vertex_roots;
   my @C;

   # Clump together vertices having identical root vertices.
   while (my ($v, $r) = each %R) { push @{ $C[ $r ] }, $v }

   return @C;
}

=pod

=item strongly_connected_graph

       $T = $G->strongly_connected_graph

Returns the strongly connected graph $T of the graph $G.
The names of the strongly connected components are
formed from their constituent vertices by concatenating
their names by '+'-characters: "a" and "b" --> "a+b".

=cut

sub strongly_connected_graph {
   my $G = shift;
   my $C = (ref $G)->new;
   my $T = $G->_strongly_connected;
   my %R = $T->_vertex_roots;
   my @C; # We're not calling the strongly_connected_components()
          # method because we will need also the %R.

   # Create the strongly connected components.
   while (my ($v, $r) = each %R) { push @{ $C[$r] }, $v }
   foreach my $c (@C)            { $c = join("+", @$c)  }

   $C->directed( $G->directed );

   my @E = $G->edges;

   # Copy the edges between strongly connected components.
   my $edge_cnt = 0;
   my %n;
   while (my ($u, $v) = splice(@E, 0, 2)) {
       if ($R{ $u } != $R{ $v }) {
           $C->add_edge( $C[ $R{ $u } ], $C[ $R{ $v } ] );
           $edge_cnt++;
       } elsif ($edge_cnt == 0) {
           $n{ $u } = '';
       }
   }
   if ($edge_cnt == 0) {
       $C->add_vertex(join("+", keys %n));
   }

   return $C;
}

=pod

=item APSP_Floyd_Warshall

       $APSP = $G->APSP_Floyd_Warshall

Returns the All-pairs Shortest Paths graph of the graph $G
computed using the Floyd-Warshall algorithm and the attribute
'weight' on the edges.
The returned graph has an edge for each shortest path.
An edge has attributes "weight" and "path"; for the length of
the shortest path and for the path (an anonymous list) itself.

=cut

sub APSP_Floyd_Warshall {
   my $G = shift;

   my @V = $G->vertices;
   my @E = $G->edges;
   my (%V2I, @I2V);
   my (@P, @W);

   # Compute the vertex <-> index mappings.
   @V2I{ @V     } = 0..$#V;
   @I2V[ 0..$#V ] = @V;

   # Initialize the predecessor matrix @P and the weight matrix @W.
   # (The graph is converted into adjacency-matrix representation.)
   # (The matrix is a list of lists.)
   foreach my $i ( 0..$#V ) { $W[ $i ][ $i ] = 0 }
   while ( my ($u, $v) = splice(@E, 0, 2) ) {
       my ( $ui, $vi ) = ( $V2I{ $u }, $V2I{ $v } );
       $P[ $ui ][ $vi ] = $ui unless $ui == $vi;
       $W[ $ui ][ $vi ] = $G->get_attribute( 'weight', $u, $v );
   }

   # Do the O(N**3) loop.
   for ( my $k = 0; $k < @V; $k++ ) {
       my (@nP, @nW); # new @P, new @W

       for ( my $i = 0; $i < @V; $i++ ) {
           for ( my $j = 0; $j < @V; $j++ ) {
               my $w_ij    = $W[ $i ][ $j ];
               my $w_ik_kj = $W[ $i ][ $k ] + $W[ $k ][ $j ]
                   if defined $W[ $i ][ $k ] and
                      defined $W[ $k ][ $j ];

               # Choose the minimum of w_ij and w_ik_kj.
               if ( defined $w_ij ) {
                   if ( defined $w_ik_kj ) {
                       if ( $w_ij <= $w_ik_kj ) {
                         $nP[ $i ][ $j ] = $P[ $i ][ $j ];
                         $nW[ $i ][ $j ] = $w_ij;
                       } else {
                         $nP[ $i ][ $j ] = $P[ $k ][ $j ];
                         $nW[ $i ][ $j ] = $w_ik_kj;
                       }
                   } else {
                       $nP[ $i ][ $j ] = $P[ $i ][ $j ];
                       $nW[ $i ][ $j ] = $w_ij;
                   }
               } elsif ( defined $w_ik_kj ) {
                   $nP[ $i ][ $j ] = $P[ $k ][ $j ];
                   $nW[ $i ][ $j ] = $w_ik_kj;
               }
           }
       }

       @P = @nP; @W = @nW; # Update the predecessors and weights.
   }

   # Now construct the APSP graph.

   my $APSP = (ref $G)->new;

   $APSP->directed( $G->directed ); # Copy the directedness.

   # Convert the adjacency-matrix representation
   # into a Graph (adjacency-list representation).
   for ( my $i = 0; $i < @V; $i++ ) {
       my $iv = $I2V[ $i ];

       for ( my $j = 0; $j < @V; $j++ ) {
           if ( $i == $j ) {
               $APSP->add_weighted_edge( $iv, 0, $iv );
               $APSP->set_attribute("path", $iv, $iv, [ $iv ]);
               next;
           }
           next unless defined $W[ $i ][ $j ];

           my $jv = $I2V[ $j ];

           $APSP->add_weighted_edge( $iv, $W[ $i ][ $j ], $jv );

           my @path = ( $jv );
           if ( $P[ $i ][ $j ] != $i ) {
               my $k = $P[ $i ][ $j ];  # Walk back the path.

               while ( $k != $i ) {
                   push @path, $I2V[ $k ];
                   $k = $P[ $i ][ $k ]; # Keep walking.
               }
           }
           $APSP->set_attribute( "path", $iv, $jv, [ $iv, reverse @path ] );
       }
   }

   return $APSP;
}

=pod

=item TransitiveClosure_Floyd_Warshall

       $TransitiveClosure = $G->TransitiveClosure_Floyd_Warshall

Returns the Transitive Closure graph of the graph $G computed
using the Floyd-Warshall algorithm.
The resulting graph has an edge between each *ordered* pair of
vertices in which the second vertex is reachable from the first.

=cut

sub TransitiveClosure_Floyd_Warshall {
   my $G = shift;

   my @V = $G->vertices;
   my @E = $G->edges;
   my (%V2I, @I2V);
   my @C = ( '' ) x @V;

   # Compute the vertex <-> index mappings.
   @V2I{ @V     } = 0..$#V;
   @I2V[ 0..$#V ] = @V;

   # Initialize the closure matrix @C.
   # (The graph is converted into adjacency-matrix representation.)
   # (The matrix is a bit matrix.  Well, a list of bit vectors.)
   foreach my $i ( 0..$#V ) { vec( $C[ $i ], $i, 1 ) = 1 }
   while ( my ($u, $v) = splice(@E, 0, 2) ) {
       vec( $C[ $V2I{ $u } ], $V2I{ $v }, 1 ) = 1
   }

   # Do the O(N**3) loop.
   for ( my $k = 0; $k < @V; $k++ ) {
       my @nC = ( '' ) x @V; # new @C

       for ( my $i = 0; $i < @V; $i++ ) {
           for ( my $j = 0; $j < @V; $j++ ) {
               vec( $nC[ $i ], $j, 1 ) =
                 vec( $C[ $i ], $j, 1 ) |
                   vec( $C[ $i ], $k, 1 ) & vec( $C[ $k ], $j, 1 );
           }
       }

       @C = @nC; # Update the closure.
   }

   # Now construct the TransitiveClosure graph.

   my $TransitiveClosure = (ref $G)->new;

   $TransitiveClosure->directed( $G->directed );

   # Convert the (closure-)adjacency-matrix representation
   # into a Graph (adjacency-list representation).
   for ( my $i = 0; $i < @V; $i++ ) {
       for ( my $j = 0; $j < @V; $j++ ) {
           $TransitiveClosure->add_edge( $I2V[ $i ], $I2V[ $j ] )
               if vec( $C[ $i ], $j, 1 );
       }
   }

   return $TransitiveClosure;
}

=pod

=item articulation points

       @A = $G->articulation_points(%param)

Returns the articulation points (vertices) @A of the graph $G.
The %param can be used to control the search.

=cut

sub articulation_points {
   my $G = shift;
   my $articulate =
       sub {
           my ( $u, $T ) = @_;
                               
           my $ap = $T->{ vertex_found }->{ $u };
       
           my @S = @{ $T->{ active_list } }; # Current stack.

           $T->{ articulation_point }->{ $u } = $ap
               unless exists $T->{ articulation_point }->{ $u };

           # Walk back the stack marking the active DFS branch
           # (below $u) as belonging to the articulation point $ap.
           for ( my $i = 1; $i < @S; $i++ ) {
               my $v = $S[ -$i ];

               last if $v eq $u;

               $T->{ articulation_point }->{ $v } = $ap
                   if not exists $T->{ articulation_point }->{ $v } or
                      $ap < $T->{ articulation_point }->{ $v };
           }
       };
   my $unseen_successor =
       sub {
           my ($u, $v, $T) = @_;

           # We need to know the number of children for root vertices.
           $T->{ articulation_children }->{ $u }++;
       };
   my $seen_successor =
       sub {
           my ($u, $v, $T) = @_;
       
           # If the $v is still active, articulate it.
           $articulate->( $v, $T ) if exists $T->{ active_pool }->{ $v };
       };
   my $d =
       Graph::DFS->new($G,
                       articulate       => $articulate,
                       unseen_successor => $unseen_successor,
                       seen_successor   => $seen_successor,
               );

   $d->preorder;

   # Now we need to find (the indices of) unique articulation points
   # and map them back to vertices.

   my (%ap, @vf);

   foreach my $v ( $G->vertices ) {
       $ap{ $d->{ articulation_point }->{ $v } } = $v;
       $vf[ $d->{ vertex_found       }->{ $v } ] = $v;
   }

   %ap = map { ( $vf[ $_ ], $_ ) } keys %ap;

   # DFS tree roots are articulation points only
   # iff they have more than one children.
   foreach my $r ( $d->roots ) {
       delete $ap{ $r } if $d->{ articulation_children }->{ $r } < 2;
   }

   keys %ap;
}

=pod

=item is_biconnected

       $b = $G->is_biconnected

Returns true is the graph $G is biconnected
(has no articulation points), false otherwise.

=cut

sub is_biconnected {
   my $G = shift;

   return $G->articulation_points == 0;
}

=pod

=item largest_out_degree

       $v = $G->largest_out_degree( @V )

Selects the vertex $v from the vertices @V having
the largest out degree in the graph $G.

=cut

sub largest_out_degree {
   my $G = shift;
   my $L = shift;
   my $O = $G->out_degree($L);

   for my $e (@_) {
       my $o = $G->out_degree($e);
       if ($o > $O) {
           $L = $e;
           $O = $o;
       }
   }

   return $L;
}

# _heap_init
#
#       $G->_heap_init($heap, $u, \%in_heap, \%weight, \%parent)
#
#       (INTERNAL USE ONLY)
#       Initializes the $heap with the vertex $u as the initial
#       vertex, its weight being zero, and marking all vertices
#       of the graph $G to be $in_heap,
#
sub _heap_init {
   my ($G, $heap, $u, $in_heap, $W, $P) = @_;

   use Graph::HeapElem;

   foreach my $v ( $G->vertices ) {
       my $e = Graph::HeapElem->new( $v, $W, $P );
       $heap->add( $e );
       $in_heap->{ $v } = $e;
   }

   $W->{ $u } = 0;
}

=pod

=item MST_Prim

       $MST = $G->MST_Prim($u)

Returns Prim's Minimum Spanning Tree (as a graph) of
the graph $G based on the 'weight' attributes of the edges.
The optional start vertex is $u, if none is given, a hopefully
good one (a vertex with a large out degree) is chosen.

=cut

sub MST_Prim {
   my ( $G, $u ) = @_;
   my $MST       = (ref $G)->new;

   $u = $G->largest_out_degree( $G->vertices ) unless defined $u;

   use Heap::Fibonacci;
   my $heap = Heap::Fibonacci->new;
   my ( %in_heap, %weight, %parent );

   $G->_heap_init( $heap, $u, \%in_heap, \%weight, \%parent );

   # Walk the edges at the current BFS front
   # in the order of their increasing weight.
   while ( defined $heap->minimum ) {
       $u = $heap->extract_minimum;
       delete $in_heap{ $u->vertex };
       
       # Now extend the BFS front.
       
       foreach my $v ( $G->successors( $u->vertex ) ) {
           if ( defined( $v = $in_heap{ $v } ) ) {
               my $nw = $G->get_attribute( 'weight',
                                           $u->vertex, $v->vertex );
               my $ow = $v->weight;
               
               if ( not defined $ow or $nw < $ow ) {
                   $v->weight( $nw );
                   $v->parent( $u->vertex );
                   $heap->decrease_key( $v );
               }
           }
       }
   }

   foreach my $v ( $G->vertices ) {
       $MST->add_weighted_edge( $v, $weight{ $v }, $parent{ $v } )
           if defined $parent{ $v };
   }

   return $MST;
}

# _SSSP_construct
#
#       $SSSP = $G->_SSSP_construct( $s, $W, $P );
#
#       (INTERNAL USE ONLY)
#       Return the SSSP($s) graph of graph $G based on the computed
#       anonymous hashes for weights and parents: $W and $P.
#       The vertices of the graph will have two attributes: "weight",
#       which tells the length of the shortest single-source path,
#       and "path", which is an anymous list containing the path.
#
sub _SSSP_construct {
   my ($G, $s, $W, $P ) = @_;
   my $SSSP = (ref $G)->new;

   foreach my $u ( $G->vertices ) {
       $SSSP->add_vertex( $u );

       $SSSP->set_attribute( "weight", $u, $W->{ $u } || 0 );

       my @path = ( $u );
       if ( defined $P->{ $u } ) {
           $SSSP->add_edge($P->{ $u }, $u );
           $SSSP->set_attribute( "weight", $P->{ $u }, $u, $G->get_attribute("weight",$P->{ $u }, $u) || 0 );
           push @path, $P->{ $u };
           if ( $P->{ $u } ne $s ) {
               my $v = $P->{ $u };

               while ( defined $v && exists $P->{ $v } && $v ne $s ) {
                   push @path, $P->{ $v };
                   $v = $P->{ $v };
               }
           }
       }
       $SSSP->set_attribute( "path",   $u, [ reverse @path ] );
   }

   return $SSSP;
}

=pod

=item SSSP_Dijkstra

       $SSSP = $G->SSSP_Dijkstra($s)

Returns the Single-source Shortest Paths (as a graph)
of the graph $G starting from the vertex $s using Dijktra's
SSSP algorithm.

=cut

sub SSSP_Dijkstra {
   my ( $G, $s ) = @_;

   use Heap::Fibonacci;
   my $heap = Heap::Fibonacci->new;
   my ( %in_heap, %weight, %parent );

   # The other weights are by default undef (infinite).
   $weight{ $s } = 0;

   $G->_heap_init($heap, $s, \%in_heap, \%weight, \%parent );

   # Walk the edges at the current BFS front
   # in the order of their increasing weight.
   while ( defined $heap->minimum ) {
       my $u = $heap->extract_minimum;
       delete $in_heap{ $u->vertex };

       # Now extend the BFS front.
       my $uw = $u->weight;

       foreach my $v ( $G->successors( $u->vertex ) ) {
           if ( defined( $v = $in_heap{ $v } ) ) {
               my $ow = $v->weight;
               my $nw =
                 $G->get_attribute( 'weight', $u->vertex, $v->vertex ) +
                   ($uw || 0); # The || 0 helps for undefined $uw.

               # Relax the edge $u - $v.
               if ( not defined $ow or $ow > $nw ) {
                   $v->weight( $nw );
                   $v->parent( $u->vertex );
                   $heap->decrease_key( $v );
               }
           }
       }
   }

   return $G->_SSSP_construct( $s, \%weight, \%parent );
}

=pod

=item SSSP_Bellman_Ford

       $SSSP = $G->SSSP_Bellman_Ford($s)

Returns the Single-source Shortest Paths (as a graph)
of the graph $G starting from the vertex $s using Bellman-Ford
SSSP algorithm.  If there are one or more negatively weighted
cycles, returns undef.

=cut

sub SSSP_Bellman_Ford {
   my ( $G, $s ) = @_;
   my ( %weight, %parent );

   $weight{ $s } = 0;

   my $V = $G->vertices;
   my @E = $G->edges;

   foreach ( 1..$V ) { # |V|-1 times (*not* |V| times)
       my @C = @E;     # Copy.
       
       while (my ($u, $v) = splice(@C, 0, 2)) {
           my $ow = $weight{ $v };
           my $nw = $G->get_attribute( 'weight', $u, $v );

           $nw += $weight{ $u } if defined $weight{ $u };
           # Relax the edge $u - $w.
           if ( not defined $ow or $ow > $nw ) {
               $weight{ $v } = $nw;
               $parent{ $v } = $u;
           }
       }
   }

   my $negative;

   # Warn about detected negative cycles.
   while (my ($u, $v) = splice(@E, 0, 2)) {
       if ( $weight{ $v } >
            $weight{ $u } + $G->get_attribute( 'weight', $u, $v ) ) {
            warn "SSSP_Bellman_Ford: negative cycle $u $v\n";
            $negative++;
       }
   }

   # Bail out if found negative cycles.
   return undef if $negative;

   # Otherwise return the SSSP graph.
   return $G->_SSSP_construct( $s, \%weight, \%parent );
}

=pod

=item SSSP_DAG

       $SSSP = $G->SSSP_DAG($s)

Returns the Single-source Shortest Paths (as a graph)
of the DAG $G starting from vertex $s.

=cut

sub SSSP_DAG {
   my ( $G, $s ) = @_;
   my $SSSP      = (ref $G)->new;

   my ( %weight, %parent );

   $weight{ $s } = 0;

   # Because by definition there can be no cycles
   # we can freely explore each successor of each vertex.
   foreach my $u ( $G->toposort ) {
       foreach my $v ( $G->successors( $u ) ) {
           my $ow = $weight{ $v };
           my $nw = $G->get_attribute( 'weight', $u, $v );

           $nw += $weight{ $u } if defined $weight{ $u };

           # Relax the edge $u - $v.
           if ( not defined $ow or $ow > $nw ) {
               $weight{ $v } = $nw;
               $parent{ $v } = $u;
           }
       }
   }

   return $G->_SSSP_construct( $s, \%weight, \%parent );
}

=pod

=item add_capacity_edge

       $G->add_capacity_edge($u, $w, $v, $a)

Adds in the graph $G an edge from vertex $u to vertex $v
and the edge attribute 'capacity' set to $w.

=cut

sub add_capacity_edge {
   my ($G, $u, $w, $v, $a) = @_;

   $G->add_edge($u, $v);
   $G->set_attribute('capacity', $u, $v, $w);
}

=pod

=item add_capacity_edges

       $G->add_capacity_edges($u1, $w1, $v1, $u2, $w2, $v2, ...)

Adds in the graph $G the capacity edges.

=cut

sub add_capacity_edges {
   my $G = shift;

   while (my ($u, $w, $v) = splice(@_, 0, 3)) {
       $G->add_capacity_edge($u, $w, $v);
   }
}

=pod

=item add_capacity_path

       $G->add_capacity_path($v1, $w1, $v2, $w2, ..., $wnm1, $vn)

Adds in the graph $G the n edges defined by the path $v1 ... $vn
with the n-1 'capacity' attributes $w1 ... $wnm1

=cut

sub add_capacity_path {
   my $G = shift;
   my $u = shift;

   while (my ($w, $v) = splice(@_, 0, 2)) {
       $G->add_capacity_edge($u, $w, $v);
       $u = $v;
   }
}

=pod

=item Flow_Ford_Fulkerson

       $F = $G->Flow_Ford_Fulkerson($S)

Returns the (maximal) flow network of the flow network $G,
parametrized by the state $S.  The $G must have 'capacity'
attributes on its edges.  $S->{ source } must contain the
source vertex and $S->{ sink } the sink vertex, and
most importantly $S->{ next_augmenting_path } must contain
an anonymous subroutine which takes $F and $S as arguments
and returns the next potential augmenting path.
Flow_Ford_Fulkerson will do the augmenting.
The result graph $F will have 'flow' and (residual) 'capacity'
attributes on its edges.

=cut

sub Flow_Ford_Fulkerson {
   my ( $G, $S ) = @_;

   my $F = (ref $G)->new; # The flow network.
   my @E = $G->edges;
   my ( $u, $v );

   # Copy the edges and the capacities, zero the flows.
   while (($u, $v) = splice(@E, 0, 2)) {
       $F->add_edge( $u, $v );
       $F->set_attribute( 'capacity', $u, $v,
                          $G->get_attribute( 'capacity', $u, $v ) || 0 );
       $F->set_attribute( 'flow',     $u, $v, 0 );
   }

   # Walk the augmenting paths.
   while ( my $ap = $S->{ next_augmenting_path }->( $F, $S ) ) {
       my @aps = @$ap; # augmenting path segments
       my $apr;        # augmenting path residual capacity
       my $psr;        # path segment residual capacity

       # Find the minimum capacity of the path.
       for ( $u = shift @aps; @aps; $u = $v ) {
           $v   = shift @aps;
           $psr = $F->get_attribute( 'capacity', $u, $v ) -
                  $F->get_attribute( 'flow',     $u, $v );
           $apr = $psr
               if $psr >= 0 and ( not defined $apr or $psr < $apr );
       }

       if ( $apr > 0 ) { # Augment the path.
           for ( @aps = @$ap, $u = shift @aps; @aps; $u = $v ) {
               $v = shift @aps;
               $F->set_attribute( 'flow',
                                  $u, $v,
                                  $F->get_attribute( 'flow', $u, $v ) +
                                  $apr );
           }
       }
   }

   return $F;
}

=pod

=item Flow_Edmonds_Karp

       $F = $G->Flow_Edmonds_Karp($source, $sink)

Return the maximal flow network of the graph $G built
using the Edmonds-Karp version of Ford-Fulkerson.
The input graph $G must have 'capacity' attributes on
its edges; resulting flow graph will have 'capacity' and 'flow'
attributes on its edges.

=cut

sub Flow_Edmonds_Karp {
   my ( $G, $source, $sink ) = @_;

   my $S;

   $S->{ source } = $source;
   $S->{ sink   } = $sink;
   $S->{ next_augmenting_path } =
       sub {
           my ( $F, $S ) = @_;

           my $source = $S->{ source };
           my $sink   = $S->{ sink   };

           # Initialize our "todo" heap.
           unless ( exists $S->{ todo } ) {
               # The first element is a hash recording the vertices
               # seen so far, the rest are the path from the source.
               push @{ $S->{ todo } },
                    [ { $source => 1 }, $source ];
           }

           while ( @{ $S->{ todo } } ) {
               # $ap: The next augmenting path.
               my $ap = shift @{ $S->{ todo } };
               my $sv = shift @$ap;    # The seen vertices.
               my $v  = $ap->[ -1 ];   # The last vertex of path.

               if ( $v eq $sink ) {
                   return $ap;
               } else {
                   foreach my $s ( $G->successors( $v ) ) {
                       unless ( exists $sv->{ $s } ) {
                           push @{ $S->{ todo } },
                               [ { %$sv, $s => 1 }, @$ap, $s ];
                       }
                   }
               }
           }
       };

   return $G->Flow_Ford_Fulkerson( $S );
}

use overload 'eq' => \&eq;

=pod

=item eq

       $G->eq($H)

Return true if the graphs (actually, their string representations)
are identical.  This means really identical: they must have identical
vertex names and identical edges between the vertices, and they must
be similarly directed.  (Just isomorphism isn't enough.)

=cut

sub eq {
   my ($G, $H) = @_;

   return ref $H ? $G->stringify eq $H->stringify : $G->stringify eq $H;
}

=pod

=back

=head1 COPYRIGHT

Copyright 1999, O'Reilly & Associates.

This code is distributed under the same copyright terms as Perl itself.

=cut

1;