lib/DX/RuleSet.pm

   1 package DX::RuleSet;
   2
   3 use Moo;
   4 use DX::Op::SetupScope;
   5 use DX::Op::CallRule;
   6 use DX::Op::MemberOf;
   7 use DX::Op::ApplyConstraint;
   8 use DX::Op::Return;
   9 use DX::Op::Cut;
  10 use DX::Op::Backtrack;
  11 use DX::Op::Observe;
  12 use DX::Op::Not;
  13 use DX::Op::ProposeAction;
  14 use DX::Op::ModifyAction;
  15 use DX::Op::Materialize;
  16 use DX::Op::Prop;
  17 use DX::Op::Exists;
  18 use DX::Op::Predicate;
  19 use List::Util qw(reduce);
  20
  21 has rules => (is => 'ro', default => sub { {} });
  22
  23 sub add_predicate {
  24   my ($self, $name, $vars, @cases) = @_;
  25   my $full_name = join('/', $name, scalar @$vars);
  26   push @{$self->rules->{$full_name}}, DX::Op::Predicate->new(
  27     arg_names => $vars, arg_cases => \@cases
  28   );
  29 }
  30
  31 sub add_rule {
  32   my ($self, $name, $vars, @body) = @_;
  33   my $full_name = join('/', $name, scalar @$vars);
  34   push @{$self->rules->{$full_name}}, $self->_make_rule($vars, @body);
  35   return $self;
  36 }
  37
  38 sub _make_rule {
  39   my ($self, $vars, @body) = @_;
  40   my $head = $self->expand_and_link(DX::Op::Return->new, @body);
  41   DX::Op::SetupScope->new(arg_names => $vars, next => $head);
  42 }
  43
  44 sub expand_and_link {
  45   my ($self, $last, @body) = @_;
  46   return reduce { $b->but(next => $a) }
  47            $last,
  48            reverse map $self->expand($_), @body;
  49 }
  50
  51 sub expand {
  52   my ($self, $thing) = @_;
  53   if (ref($thing) eq 'ARRAY') {
  54     my ($type, @rest) = @$thing;
  55     if ($self->can(my $expand_meth = "_expand_op_${type}")) {
  56       return $self->$expand_meth(@rest);
  57     }
  58     return $self->_expand_call(@$thing);
  59   }
  60   return $thing;
  61 }
  62
  63 sub _expand_call {
  64   my ($self, $name, @args) = @_;
  65   DX::Op::CallRule->new(rule_name => $name, rule_args => \@args);
  66 }
  67
  68 sub _expand_op_cut { return DX::Op::Cut->new }
  69
  70 sub _expand_op_fail { return DX::Op::Backtrack->new }
  71
  72 sub _expand_op_not {
  73   my ($self, @contents) = @_;
  74   my $cut = DX::Op::Cut->new(next => DX::Op::Backtrack->new);
  75   DX::Op::Not->new(
  76     body => $self->expand_and_link($cut, @contents)
  77   );
  78 }
  79
  80 sub _expand_op_member_of {
  81   my ($self, $member_var, $coll_var) = @_;
  82   DX::Op::MemberOf->new(
  83     member_var => $member_var,
  84     coll_var => $coll_var,
  85   );
  86 }
  87
  88 sub _expand_op_constrain {
  89   my ($self, $vars, $constraint) = @_;
  90   DX::Op::ApplyConstraint->new(
  91     vars => $vars,
  92     constraint => $constraint
  93   );
  94 }
  95
  96 sub _expand_op_observe {
  97   my ($self, $vars, $builder) = @_;
  98   DX::Op::Observe->new(
  99     vars => $vars,
 100     builder => $builder,
 101   );
 102 }
 103
 104 sub _expand_op_act {
 105   my ($self, $vars, $builder) = @_;
 106   DX::Op::ProposeAction->new(
 107     vars => $vars,
 108     builder => $builder,
 109   );
 110 }
 111
 112 sub _expand_op_react {
 113   my ($self, $vars, $builder) = @_;
 114   DX::Op::ModifyAction->new(
 115     vars => $vars,
 116     builder => $builder,
 117   );
 118 }
 119
 120 sub _expand_op_materialize {
 121   my ($self, $var_name) = @_;
 122   DX::Op::Materialize->new(var_name => $var_name);
 123 }
 124
 125 sub _expand_op_prop {
 126   my ($self, @args) = @_;
 127   my %new; @new{qw(of name value)} = @args;
 128   DX::Op::Prop->new(%new);
 129 }
 130
 131 sub _expand_op_exists {
 132   my ($self, $vars, @body) = @_;
 133   DX::Op::Exists->new(
 134     vars => $vars,
 135     body => $self->expand_and_link(DX::Op::Return->new, @body)
 136   );
 137 }
 138
 139 1;