File Coverage

blib/lib/Graph/Simple.pm

Criterion	Covered	Total	%
statement	145	146	99.3
branch	32	32	100.0
condition	15	20	75.0
subroutine	22	22	100.0
pod	11	11	100.0
total	225	231	97.4

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;


=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, of certain entities called I.
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 of the edge.

See L 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.

=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 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 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

A rather feature-rich implementation but with a complex API.

=item L

Less features than Graph but presumably faster. Appears to
be unmaintained since 2010 though.

=item L

Perl bindings to the C++ graph library Boost. Certainly the fastest
implementation but depends on C++, obviously.

=back

=head1 AUTHOR

Alexis Sukrieh

=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__