view release on metacpan or  search on metacpan

lib/Algorithm/DependencySolver/Solver.pm  view on Meta::CPAN

package Algorithm::DependencySolver::Solver;
$Algorithm::DependencySolver::Solver::VERSION = '1.01';
use Moose;
use MooseX::FollowPBP;
use MooseX::Method::Signatures;

use List::Compare;
use List::MoreUtils qw(any);

use Graph::Directed;
use Graph::Easy;
use Graph::Convert;


=head1 NAME

Algorithm::DependencySolver - A dependency solver for scheduling access to a shared resource

=head1 VERSION

version 1.01

=head1 SYNOPSIS

    use Algorithm::DependencySolver::Solver;
    use Algorithm::DependencySolver::Traversal;
    use Algorithm::DependencySolver::Operation;

    my @operations = (
        Algorithm::DependencySolver::Operation->new(
            id            => 1,
            depends       => [qw(z)],
            affects       => [qw(x)],
            prerequisites => ["3"],
        ),
        Algorithm::DependencySolver::Operation->new(
            id            => 2,
            depends       => [qw(x)],
            affects       => [qw(y)],
            prerequisites => [],
        ),
        Algorithm::DependencySolver::Operation->new(
            id            => 3,
            depends       => [qw(y)],
            affects       => [qw(z)],
            prerequisites => [],
        ),
    );

    my $solver =
        Algorithm::DependencySolver::Solver->new(nodes => \@operations);

    $solver->to_png("pretty-graph.png");



    my $traversal = Algorithm::DependencySolver::Traversal->new(
        Solver => $solver,
        visit  => sub {
            my $operation = shift;
            print "Visited operation: ", $operation->id, "\n";
        },
    );

    $traversal->run;

=head1 DESCRIPTION

This dependency solver is somewhat different to the existing
L<Algorithm::Dependency> module.

L<Algorithm::Dependency> creates a heirarchy where each node depends
on a set of other nodes. In L<Algorithm::DependencySolver>, there
exists a set of operations and a set of resources, with a set of edges
from operations to resources (the dependencies), and a set of edges
from resources to operations (the affects). Given this input, the
module outputs a directed acyclic graph (DAG) containing just the
operations as its nodes.

Aditionally, L<Algorithm::DependencySolver> allows for input which
whould have resulted in a cyclic output graph to be resolved by means
of explicit sequencing. This is done by marking nodes as depending on
other nodes. See
L<Algorithm::DependencySolver::Operation::prerequisites>.


=head1 METHODS

=cut



has 'nodes' => (
    is       => 'ro',
#   isa      => 'ArrayRef[Operation]',
    required => 1,
);

has 'nodes_index' => (
    is       => 'ro',
#   isa      => 'HashRef[Operation]',
    builder  => 'build_nodes_index',
    lazy     => 1,
    init_arg => undef,
);

has 'relations' => (
    is       => 'ro',
    builder  => 'build_relations',
    lazy     => 1,
    init_arg => undef,
);

has 'affects_index' => (
    is       => 'ro',
    builder  => 'build_affects_index',
    lazy     => 1,
    init_arg => undef,
);

=head2 get_Graph

Returns the dependency graph as a L<Graph> object. Note that only
operations are included in the graph, not resources. This is of most
use to the L<Algorithm::DependencySolver::Traversal> module, and the
C<to_dot> and C<to_png> methods.

=cut

has 'Graph' => (
    is       => 'ro',
    builder  => 'build_Graph',
    lazy     => 1,
    init_arg => undef,
);

has 'GraphEasy' => (
    is       => 'ro',
    builder  => 'build_GraphEasy',
    lazy     => 1,
    init_arg => undef,
);


method build_nodes_index() {
    return { map { $_->id => $_ } @{$self->get_nodes} };
}

method build_relations() {

    my @relations;

    for my $node (@{$self->get_nodes()}) {
        for my $resource (@{$node->depends}) {
            for my $other (@{$self->get_affects_index->{$resource}}) {
                next if $node->id eq $other->id;
                push @relations, [$other, $node];
            }
        }
    }

    return \@relations;
}


method build_Graph() {

    my @vertices = keys %{$self->get_nodes_index};
    my @edges    = map {
        [ $_->[0]->id, $_->[1]->id ]
    } @{$self->get_relations};

    # Ensure that each explicit ordering (node.prerequisites) has an edge.
    for my $nodeB (@{$self->get_nodes}) {
        for my $nodeA_id (@{$nodeB->prerequisites}) {
            push @edges, [$nodeA_id, $nodeB->id];
        }
    }


    my $G = Graph::Directed->new(
        vertices    => \@vertices,
        edges       => \@edges,
#       refvertexed => 1,  # refvertexed is broken!
    );

lib/Algorithm/DependencySolver/Solver.pm  view on Meta::CPAN

another path from C<$n> to C<$b>: C<$n -&gt; $b -&gt; $a -&gt; b>. We
can, of course, detect such occurrences; however, I choose not to,
because it's not clear to me what the most elegant result should be in
these situations. Semantically, it does not matter whether the edge
from C<$n> to the C<$a,$b>-cycle is from C<$n> to C<$a>, or C<$n> to
C<$b>. Which should it be? Both, or one-or-the-other (presumably
decided arbitrarily)?

Properties:

* This method can be safely called on cyclic graphs (i.e., it will not
  enter a non-terminating loop)

* This method will not fail early if a cycle is encountered (i.e., it
  will do as much work as it can, even though the graph is probably
  invalid)

* If C<_apply_orderings> is to be called on the graph object, it
  I<must> be done I<before> calling C<_remove_redundancy>

=cut

method _remove_redundancy($G) {

    for my $node ($G->vertices) {
        for my $pred ($G->predecessors($node)) {
            next unless $G->has_edge($pred, $node);

            my @other_predecessors =
              grep { $_ ne $pred } $G->predecessors($node);

            my $other_paths_to_pred = grep {
                # Returns true only if the edge from $pred to $node can
                # safely be removed
                any { $_ eq $pred } $G->all_predecessors($_);
            } @other_predecessors;

            if ($other_paths_to_pred) {
                $G->delete_edge($pred, $node);
            }
        }
    }
}



method build_affects_index() {
    my %index;
    for my $node (@{$self->get_nodes}) {
        for my $resource (@{$node->affects}) {
            push @{$index{$resource}}, $node;
        }
    }
    return \%index;
}

method to_s() {
    return $self->get_GraphEasy->as_ascii();
}

=head2 to_png

  $solver->to_png($file)

Outputs a dependency graph (showing only operations) to the given file
in PNG format

=cut

method to_png($file) {
    die "Only sane file names, please (you gave: $file)" unless
      $file =~ m/^[a-z0-9_\-\.\/]+$/i;
    open my $dot, "|dot -Tpng -o'$file'" or die ("Cannot open pipe to dot (-o $file): $!");
    print $dot $self->get_GraphEasy->as_graphviz;
}


=head2 to_dot

  $solver->to_dot($file)

Outputs a dependency graph (showing only operations) to the given file
in Graphviz's dot format

=cut

method to_dot($file) {
    die "Only sane file names, please (you gave: $file)" unless
      $file =~ m/^[a-z0-9_\-\.\/]+$/i;
    open my $fh, ">", $file or die ("Cannot open to $file: $!");
    print $fh $self->get_GraphEasy->as_graphviz;
}



method build_GraphEasy() {
    return Graph::Convert->as_graph_easy($self->get_Graph);
}


no Moose;
__PACKAGE__->meta->make_immutable;