--- /dev/null
+package DX::Op::ApplyConstraint;
+
+use Moo;
+
+with 'DX::Role::Op';
+
+has vars => (is => 'ro', required => 1);
+has constraint => (is => 'ro', required => 1);
+
+sub run {
+ my ($self, $state) = @_;
+ my @vars = map $state->scope_var($_)->bound_value, @{$self->vars};
+ if ($self->constraint->(@vars)) {
+ return $state->then($self->next);
+ }
+ return $state->backtrack;
+}
+
+1;
--- /dev/null
+package DX::Op::CallRule;
+
+use DX::Op::SetScope;
+use DX::Op::FromCode;
+use DX::Var;
+use DX::ArrayStream;
+use Moo;
+
+with 'DX::Role::Op';
+
+has rule_name => (is => 'ro', required => 1);
+has rule_args => (is => 'ro', required => 1);
+has full_name => (is => 'lazy', builder => sub {
+ my ($self) = @_;
+ join('/', $self->rule_name, scalar @{$self->rule_args});
+});
+
+sub run {
+ my ($self, $state) = @_;
+ my @args = map {
+ if (!ref($_)) {
+ $state->scope_var($_)
+ } elsif (ref($_) eq 'ARRAY') {
+ if ($_->[0] eq 'value') {
+ +{ bound_value => $_->[1] };
+ } else {
+ die "Arrayref in argspec is not value";
+ }
+ } else {
+ die "Argspec incomprehensible";
+ }
+ } @{$self->rule_args};
+ my @rules = @{$state->rule_set->rules->{$self->full_name}||[]};
+ die "No rules for ${\$self->full_name}" unless @rules;
+ my $var = DX::Var->new(id => 'OR')
+ ->with_stream(DX::ArrayStream->from_array(@rules));
+ my $invoke = DX::Op::FromCode->new(
+ code => sub {
+ my ($self, $state) = @_;
+ my ($names, $body) = @{$var->bound_value};
+ my %new; @new{@$names} = @args;
+ $state->but(scope => {})->assign_vars(%new)->then($body);
+ }
+ );
+ my $ret_op = DX::Op::SetScope->new(
+ scope => $state->scope, next => $self->next
+ );
+ $state->push_return_then($ret_op, $invoke)->mark_choice($var);
+}
+
+1;
--- /dev/null
+package DX::Op::MemberLookup;
+
+use Moo;
+
+with 'DX::Role::Op';
+
+has member_var => (is => 'ro', required => 1);
+has coll_name => (is => 'ro', required => 1);
+has key_name => (is => 'ro', required => 1);
+has key_var => (is => 'ro', required => 1);
+
+sub run {
+ my ($self, $state) = @_;
+ my ($member, $key) = map $state->scope_var($self->$_), qw(member_var key_var);
+ die "key unbound" unless $key->is_bound;
+ die "member bound" if $member->is_bound;
+ my $set = $state->facts->{$self->coll_name};
+ if (my $value = $set->{$key->bound_value}) {
+ return $state->bind_var_then($member, $value, $self->next);
+ }
+ return $state->backtrack;
+}
+
+1;
--- /dev/null
+package DX::Op::MemberOf;
+
+use DX::ArrayStream;
+use Moo;
+
+with 'DX::Role::Op';
+
+has member_var => (is => 'ro', required => 1);
+has coll_name => (is => 'ro', required => 1);
+
+sub run {
+ my ($self, $state) = @_;
+ my $member = $state->scope_var($self->member_var);
+ die "member bound" if $member->is_bound;
+ my $set = $state->facts->{$self->coll_name};
+ my $stream = DX::ArrayStream->from_array(@{$set}{sort keys %$set});
+ return $state->bind_stream_then($member, $stream, $self->next);
+}
+
+1;
--- /dev/null
+package DX::Op::Return;
+
+use Moo;
+
+with 'DX::Role::Op';
+
+sub run { $_[1]->pop_return_stack };
+
+1;
--- /dev/null
+package DX::Op::SetScope;
+
+use Moo;
+
+with 'DX::Role::Op';
+
+has scope => (is => 'ro', required => 1);
+
+sub run {
+ my ($self, $state) = @_;
+ $state->but(scope => $self->scope, next_op => $self->next);
+}
+
+1;
--- /dev/null
+package DX::RuleSet;
+
+use Moo;
+use DX::Op::CallRule;
+use DX::Op::MemberOf;
+use DX::Op::MemberLookup;
+use DX::Op::ApplyConstraint;
+use DX::Op::Return;
+use List::Util qw(reduce);
+
+has rules => (is => 'ro', default => sub { {} });
+
+sub add_rule {
+ my ($self, $name, $vars, @body) = @_;
+ my $full_name = join('/', $name, scalar @$vars);
+ push @{$self->rules->{$full_name}}, $self->_make_rule($vars, @body);
+ return $self;
+}
+
+sub _make_rule {
+ my ($self, $vars, @body) = @_;
+ my $head = reduce { $b->but(next => $a) }
+ DX::Op::Return->new,
+ reverse map $self->expand(@$_), @body;
+ [ $vars, $head ];
+}
+
+sub expand {
+ my ($self, $type, @rest) = @_;
+ $self->${\"_expand_${type}"}(@rest);
+}
+
+sub _expand_call {
+ my ($self, $name, @args) = @_;
+ DX::Op::CallRule->new(rule_name => $name, rule_args => \@args);
+}
+
+sub _expand_member_of {
+ my ($self, $member_var, $coll_name) = @_;
+ DX::Op::MemberOf->new(
+ member_var => $member_var,
+ coll_name => $coll_name,
+ );
+}
+
+sub _expand_member_lookup {
+ my ($self, $member_var, $coll_name, $key_name, $key_var) = @_;
+ DX::Op::MemberLookup->new(
+ member_var => $member_var,
+ coll_name => $coll_name,
+ key_name => $key_name,
+ key_var => $key_var
+ );
+}
+
+sub _expand_constrain {
+ my ($self, $vars, $constraint) = @_;
+ DX::Op::ApplyConstraint->new(
+ vars => $vars,
+ constraint => $constraint
+ );
+}
+
+1;
--- /dev/null
+package DX::Solver;
+
+use DX::RuleSet;
+use DX::State;
+use DX::ResultStream;
+use List::Util qw(reduce);
+use Moo;
+
+has rule_set => (is => 'lazy', handles => [ 'add_rule' ], builder => sub {
+ DX::RuleSet->new
+});
+
+has facts => (is => 'ro', required => 1);
+
+sub query {
+ my ($self, $vars, @terms) = @_;
+ my $rule_set = $self->rule_set;
+ my $head = reduce { $b->but(next => $a) }
+ reverse map $rule_set->expand(@$_), @terms;
+ my $state = DX::State->new(
+ next_op => $head,
+ return_stack => [],
+ by_id => {},
+ scope => {},
+ last_choice => [],
+ facts => $self->facts,
+ rule_set => $rule_set,
+ )->assign_vars(map +($_ => {}), @$vars);
+ return DX::ResultStream->new(
+ for_state => $state
+ );
+}
+
+1;
has id_gen => (is => 'ro', default => sub { {} });
+has rule_set => (is => 'ro');
+
+has facts => (is => 'ro');
+
sub scope_var {
my ($self, $name) = @_;
$self->by_id->{$self->scope->{$name}};
sub assign_vars {
my ($self, %vars) = @_;
my %by_id = %{$self->by_id};
+ my $state = $self->but(id_gen => { %{$self->id_gen} });
foreach my $name (keys %vars) {
warn "assign: ${name}";
unless (blessed($vars{$name})) {
- my $var = $vars{$name} = $self->allocate_var($name, $vars{$name});
+ my $var = $vars{$name} = $state->allocate_var($name, $vars{$name});
$by_id{$var->id} = $var;
}
}
- $self->but(
+ $state->but(
by_id => \%by_id,
scope => { %{$self->scope}, map +($_ => $vars{$_}->id), keys %vars }
);
--- /dev/null
+use strictures 1;
+use Test::More;
+use DX::Solver;
+
+my @servers = qw(
+ kitty.scsys.co.uk
+ jim.example.com
+ joe.example.com
+ pryde.scsys.co.uk
+ bob.example.com
+);
+
+my %servers = map +($_ => { name => $_ }), @servers;
+
+my @shells = qw(csh bash);
+
+my %shells = (
+ bash => { name => 'bash',
+ installed_on => {
+ map +($_ => 1),
+ qw(joe.example.com kitty.scsys.co.uk)
+ },
+ },
+ csh => { name => 'csh',
+ installed_on => {
+ map +($_ => 1),
+ qw(jim.example.com joe.example.com bob.example.com)
+ },
+ },
+);
+
+my $solver = DX::Solver->new(
+ facts => { servers => \%servers, shells => \%shells }
+);
+
+$solver->add_rule(server => [ 'S' ] => [ member_of => qw(S servers) ]);
+
+my $s = $solver->query([ 'S' ], [ call => server => 'S' ]);
+
+is_deeply([ map $_->{S}{name}, $s->results ], [ sort @servers ]);
+
+$solver->add_rule(shell => [ 'S' ] => [ member_of => qw(S shells) ])
+ ->add_rule(name => [ qw(T N) ],
+ [ constrain => [ qw(T N) ],
+ sub { ::Dwarn(\@_); $_[0]->{name} eq $_[1] } ]
+ )
+ ->add_rule(shell_installed_on => [ qw(Shell Srv) ],
+ [ constrain => [ qw(Shell Srv) ],
+ sub { $_[0]->{installed_on}{$_[1]->{name}} } ]
+ );
+
+$s = $solver->query(
+ [ qw(Shell Srv) ],
+ [ call => shell => 'Shell' ],
+ [ call => name => 'Shell', [ value => 'bash' ] ],
+ [ call => server => 'Srv' ],
+ [ call => shell_installed_on => qw(Shell Srv) ],
+ );
+
+::Dwarn($s->results);
+
+done_testing;
projects / scpubgit/DKit.git / commitdiff