From: Matt S Trout <mst@shadowcat.co.uk>
Date: Thu, 30 Jan 2014 22:35:58 +0000 (+0000)
Subject: wheeeeeeeeee
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b40e416a04d2a7914f77905ac13594f71ac881c9;p=scpubgit%2FDKit.git

wheeeeeeeeee
---

diff --git a/lib/DX/Op/ApplyConstraint.pm b/lib/DX/Op/ApplyConstraint.pm
new file mode 100644
index 0000000..1dfee28
--- /dev/null
+++ b/lib/DX/Op/ApplyConstraint.pm
@@ -0,0 +1,19 @@
+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;
diff --git a/lib/DX/Op/CallRule.pm b/lib/DX/Op/CallRule.pm
new file mode 100644
index 0000000..f97d187
--- /dev/null
+++ b/lib/DX/Op/CallRule.pm
@@ -0,0 +1,51 @@
+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;
diff --git a/lib/DX/Op/MemberLookup.pm b/lib/DX/Op/MemberLookup.pm
new file mode 100644
index 0000000..51827f2
--- /dev/null
+++ b/lib/DX/Op/MemberLookup.pm
@@ -0,0 +1,24 @@
+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;
diff --git a/lib/DX/Op/MemberOf.pm b/lib/DX/Op/MemberOf.pm
new file mode 100644
index 0000000..94eceb2
--- /dev/null
+++ b/lib/DX/Op/MemberOf.pm
@@ -0,0 +1,20 @@
+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;
diff --git a/lib/DX/Op/Return.pm b/lib/DX/Op/Return.pm
new file mode 100644
index 0000000..da187ab
--- /dev/null
+++ b/lib/DX/Op/Return.pm
@@ -0,0 +1,9 @@
+package DX::Op::Return;
+
+use Moo;
+
+with 'DX::Role::Op';
+
+sub run { $_[1]->pop_return_stack };
+
+1;
diff --git a/lib/DX/Op/SetScope.pm b/lib/DX/Op/SetScope.pm
new file mode 100644
index 0000000..132a044
--- /dev/null
+++ b/lib/DX/Op/SetScope.pm
@@ -0,0 +1,14 @@
+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;
diff --git a/lib/DX/RuleSet.pm b/lib/DX/RuleSet.pm
new file mode 100644
index 0000000..692ac8e
--- /dev/null
+++ b/lib/DX/RuleSet.pm
@@ -0,0 +1,64 @@
+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;
diff --git a/lib/DX/Solver.pm b/lib/DX/Solver.pm
new file mode 100644
index 0000000..05523ec
--- /dev/null
+++ b/lib/DX/Solver.pm
@@ -0,0 +1,34 @@
+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;
diff --git a/lib/DX/State.pm b/lib/DX/State.pm
index b4ad233..379b41f 100644
--- a/lib/DX/State.pm
+++ b/lib/DX/State.pm
@@ -17,6 +17,10 @@ has last_choice => (is => 'ro', required => 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}};
@@ -31,14 +35,15 @@ sub allocate_var {
 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 }
   );
diff --git a/t/basic_rule.t b/t/basic_rule.t
new file mode 100644
index 0000000..01a5e99
--- /dev/null
+++ b/t/basic_rule.t
@@ -0,0 +1,62 @@
+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;