—

              
package Graph::Simple;
#ABSTRACT: simple and intuitive interface for manipulating graph
use Moo;
use Carp 'croak';
# graphs are represented with adjency lists
has _adjencies => (
    is      => 'rw',
    default => sub { {} },
);
# if weights are provided, stored for each edge(u,v)
has _weights => (
    is      => 'rw',
    default => sub { {} },
);
has is_weighted => (
    is      => 'ro',
    default => sub {0},
);
has is_directed => (
    is      => 'ro',
    default => sub {0},
);
sub vertices {
    my $self = shift;
    return keys %{ $self->_adjencies };
}
sub add_edge {
    my ( $self, $u, $v, $weight ) = @_;
    $self->_add_edge( $u, $v, $weight );
    # if the graph is not directed, adding u,v adds v,u
    $self->_add_edge( $v, $u, $weight ) if !$self->is_directed;
    return "$u,$v";
}
sub _add_edge {
    my ( $self, $u, $v, $weight ) = @_;
    $weight ||= 0;
    $self->_adjencies->{$u} ||= [];
    push @{ $self->_adjencies->{$u} }, $v;
    $self->_weights->{$u}->{$v} = $weight
      if $self->is_weighted;
}
sub delete_edge {
    my ( $self, $u, $v ) = @_;
    $self->_delete_edge( $u, $v );
    $self->_delete_edge( $v, $u ) if !$self->is_directed;
}
sub _delete_edge {
    my ( $self, $u, $v ) = @_;
    my @neighbors = $self->neighbors($u);
    my @new;
    foreach my $e (@neighbors) {
        push @new, $e if $e ne $v;
    }
    $self->_adjencies->{$u} = \@new;
}
sub neighbors {
    my ( $self, $v ) = @_;
    croak "Unknown vertex '$v'"
      if !grep {/^$v$/} $self->vertices;
    return @{ $self->_adjencies->{$v} };
}
sub weight {
    my ( $self, $u, $v, $w ) = @_;
    if ( @_ == 3 ) {
        return $self->_weights->{$u}->{$v};
    }
    else {
        $self->_weights->{$u}->{$v} = $w;
    }
}
sub is_adjacent {
    my ( $self, $u, $v ) = @_;
    return grep {/^$v$/} @{ $self->_adjencies->{$u} };
}
sub breadth_first_search {
    my ( $self, $v, %options ) = @_;
    my @queue   = ($v);
    my $parents = {};
    my $states  = { $v => 'grey' };
    my $cb_vertex_discovered = $options{cb_vertex_discovered} || sub {
    };
    my $cb_vertex_processed = $options{cb_vertex_processed} || sub {
    };
    my $cb_edge_discovered = $options{cb_edge_discovered} || sub {
    };
    while ( my $vertex = shift(@queue) ) {
        $cb_vertex_discovered->($vertex);
        foreach my $n ( $self->neighbors($vertex) ) {
            my $state = $states->{$n} || 'white';
            next if $state eq 'black';
            if ( $state eq 'grey' ) {
                $cb_edge_discovered->( $vertex, $n );
                next;
            }
            push @queue, $n;
            $states->{$n}  = 'grey';
            $parents->{$n} = $vertex;
        }
        $states->{$vertex} = 'black';
        $cb_vertex_processed->($vertex);
    }
    return $parents;
}
sub depth_first_search {
    my ( $self, $start, %options ) = @_;
    # init phase of the DFS traversal
    my $states ||= {};
    my $cb_vd = $options{cb_vertex_discovered} || sub { };
    my $cb_vp = $options{cb_vertex_processed}  || sub { };
    my $cb_ed = $options{cb_edge_discovered}   || sub { };
    foreach my $v ( $self->vertices ) {
        $states->{$v} = 'unknown';
    }
    # DFS traversal is recursively done on each new vertex
    $self->_dfs_visit(
        $start, $states,
        {   cb_vertex_discovered => $cb_vd,
            cb_vertex_processed  => $cb_vp,
            cb_edge_discovered   => $cb_ed,
        }
    );
}
sub _dfs_visit {
    my ( $self, $vertex, $states, $callbacks ) = @_;
    $states->{$vertex} = 'discovered';
    $callbacks->{cb_vertex_discovered}->($vertex);
    foreach my $n ( $self->neighbors($vertex) ) {
        $callbacks->{cb_edge_discovered}->( $vertex, $n );
        my $state = $states->{$n};
        if ( $state eq 'unknown' ) {
            $self->_dfs_visit( $n, $states, $callbacks );
        }
    }
    $callbacks->{cb_vertex_processed}->($vertex);
    $states->{$vertex} = 'processed';
}
sub prim {
    my ( $self, $start ) = @_;
    my $spanning_tree =
      Graph::Simple->new( is_weighted => 0, is_directed => 0 );
    my %non_tree_vertices = map { $_ => 1 } $self->vertices;
    my %tree_vertices = ( $start => 1 );
    my $current = $start;
    while ( keys %non_tree_vertices ) {
        delete $non_tree_vertices{$current};
        # select the edge of minimum weight between a tree and a nontree vertex
        my $min_weight;
        my $new_edge;
        foreach my $u ( keys %tree_vertices ) {
            foreach my $v ( $self->neighbors($u) ) {
                next if exists $tree_vertices{$v};
                my $w = $self->weight( $u, $v );
                # print " - $u, $v weights $w\n";
                $min_weight = $w if !defined $min_weight;
                if ( $w <= $min_weight ) {
                    $new_edge = [ $u, $v ];
                    $min_weight = $w;
                }
            }
        }
        # Adding $v to the spanning tree
        my ( $u, $v ) = @$new_edge;
        # print "Minimum vertex is $u -> $v\n";
        $spanning_tree->add_edge( $u, $v );
        delete $non_tree_vertices{$v};
        $tree_vertices{$v} = 1;
    }
    return $spanning_tree;
}
sub dijkstra {
    my ( $self, $vertex ) = @_;
    my $spanning_tree = Graph::Simple->new;
    my %distances = ( $vertex => 0 );
    my %non_tree_vertices = map { $_ => 1 } $self->vertices;
    my %tree_vertices = ( $vertex => 1 );
    my $current = $vertex;
    while ( keys %non_tree_vertices ) {
        delete $non_tree_vertices{$current};
        # select the edge of minimum weight between a tree and a nontree vertex
        my $min_dist;
        my $new_edge;
        foreach my $u ( keys %tree_vertices ) {
            foreach my $v ( $self->neighbors($u) ) {
                next if exists $tree_vertices{$v};
                my $w = $self->weight( $u, $v );
                my $distance = $distances{$u} + $w;
                $min_dist = $distance if !defined $min_dist;
                if ( $distance <= $min_dist ) {
                    $new_edge      = [ $u, $v ];
                    $min_dist      = $distance;
                    $distances{$v} = $distance;
                }
            }
        }
        # Adding $v to the spanning tree
        my ( $u, $v ) = @$new_edge;
        $spanning_tree->add_edge( $u, $v );
        delete $non_tree_vertices{$v};
        $tree_vertices{$v} = 1;
    }
    return { spanning_tree => $spanning_tree, distances => \%distances };
}
sub shortest_path {
    my ( $self, $source, $destination ) = @_;
    my $dijkstra = $self->dijkstra($source);
    my $mst = $dijkstra->{spanning_tree};
 # we build a reverse path, starting from the destination, and backtracking the
 # source each step with the neighbors of the vertex in the spanning tree
    my @reverse_path;
    my $current = $destination;
    while ( $current ne $source ) {
        push @reverse_path, $current;
        foreach my $n ( $mst->neighbors($current) ) {
            if ( $n eq $source ) {
                push @reverse_path, $n;
                return reverse @reverse_path;
            }
            else {
                $current = $n;
            }
        }
    }
    return reverse @reverse_path;
}
1;
HideShow 204 lines of Pod
=pod
=head1 NAME
Graph::Simple - simple and intuitive interface for manipulating graph
=head1 VERSION
version 0.04
=head1 DESCRIPTION
In computer science, a graph is an abstract data type that is meant to implement
the graph and hypergraph concepts from mathematics.
A graph data structure consists of a finite (and possibly mutable) set of
ordered pairs, called I<edges>, of certain entities called I<vertices>.
As in mathematics, an edge (x,y) is said to point or go from x to y.
A graph data structure may also associate to each edge some edge value, such as
a symbolic label or a numeric attribute (cost, capacity, length, etc.) most
oftenly refered to as the I<weight> of the edge. 
See L<Wikipedia|http://en.wikipedia.org/wiki/Graph_(abstract_data_type)> for
more details about the theory.
This class provides an easy to use and intuitive API for manipulating graphs in
Perl. It's a native Perl implementation based on L<Moo>.
=head1 ATTRIBUTES
=head2 is_weighted
Boolean flag to tell if the graph is weighted
=head2 is_directed
Boolean flag to tell if the graph is directed
=head1 METHODS
=head2 vertices
Return the array of vertices
    my @vertices = $g->vertices;
=head2 add_edge
Adds a new edge to the graph, and add the corresponding vertices.
Note that on undirected graphs, adding u,v also adds v,u.
    $g->add_edge("Foo", "Bar");
On weighted graph, it's possible to pass the weight of the edge as a third
argument
    $g->add_edge("Foo", "Bar", 3);
=head2 delete_edge
    $g->delete_edge(x, y)
Removes the edge from x to y, if it is there.
=head2 neighbors
    my @neighbors = $g->neighbors('u');
Lists all vertices y such that there is an edge from x to y.
=head2 weight
Accessor to the weight of the edge. If called with two arguments, return the
value previously set, with three arguments, set the weight:
    # reader
    my $w = $g->weight('u', 'v');
    # setter
    $g->weight('u', 'v', 42);
=head2 is_adjacent
    $g->is_adjacent(x, y)
Tests whether there is an edge from node x to node y.
=head2 breadth_first_search
Performs a BFS traversal on the graph, returns the parents hash produced.
Callbacks can be given to trigger code when edges or vertices are
discovered/processed.
    $g->breadth_first_search($vertex, 
        cb_vertex_discovered => sub { print "discovered vertex @_" },
        cb_vertex_processed => sub { print "processed vertex @_" },
        cb_edge_discovered => sub { print "new edge: @_" });
=head2 depth_first_search
Performs a DFS traversal on the graph, returns the parents hash produced.
Callbacks can be given to trigger code when edges or vertices are
discovered/processed.
    $g->breadth_first_search('Foo',
        cb_vertex_discovered => sub { print "discovered vertex @_" },
        cb_vertex_processed  => sub { print "processed vertex @_" },
        cb_edge_discovered   => sub { print "new edge: @_" },
    );
=head2 prim
Implementation of the Prim algorithm to grow a Minimum Spanning Tree of the
graph.
Return the tree produced (as a C<Graph::Simple> object).
    my $mst = $g->prim('Foo');
=head2 dijkstra
Implementation of the Dijkstra algorithm to find all possible shortest paths from
a vertex C<$s> to all other vertices of the graph.
The return value of this method is a hashref containing the following entries:
=over 4
=item spanning_tree
A L<Graph::Simple> object representing the minimum spanning tree produced by the
Dijkstra traversal.
=item distances
An hashref containing for each vertices the distance between that vertex and the
source vertex.
=back
    my $dijkstra = $g->dijkstra('E');
=head2 shortest_path
Return the shortest path between two vertices as a list of vertices.
    my @path = $g->shortest_path('A', 'E');
    # eg: ( 'A', 'D', 'F', 'E' )
Note that internally, this method uses the spanning tree produced by the
Dijkstra algorithm to compute the shortest path.
=head1 SYNOPSYS
    my $g = Graph::Simple->new ( is_directed => 1, is_weighted => 1);
    $g->add_edge( 'Al',  'Bob', 2 );
    $g->add_edge( 'Al',  'Jim', 3 );
    $g->add_edge( 'Joe',  'Jim', 3 );
     
    $g->neighbors('Al');
=head1 SEE ALSO
This distribution has been written because when I looked on CPAN for an easy to
use and lightweight interface for manipulating graphs in Perl, I dind't find
something that fitted my expectations.
Other distributions exist though:
=over 4
=item L<Graph>
A rather feature-rich implementation but with a complex API.
=item L<Graph::Fast>
Less features than Graph but presumably faster. Appears to
be unmaintained since 2010 though.
=item L<Graph::Boost>
Perl bindings to the C++ graph library Boost. Certainly the fastest
implementation but depends on C++, obviously.
=back
=head1 AUTHOR
Alexis Sukrieh <sukria@sukria.net>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2013 by Alexis Sukrieh.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
__END__