Commit | Line | Data |
b40e416a |
1 | package DX::RuleSet; |
2 | |
3 | use Moo; |
4 | use DX::Op::CallRule; |
5 | use DX::Op::MemberOf; |
b40e416a |
6 | use DX::Op::ApplyConstraint; |
7 | use DX::Op::Return; |
734376d9 |
8 | use DX::Op::Cut; |
71217e42 |
9 | use DX::Op::Backtrack; |
5ef4d923 |
10 | use DX::Op::Observe; |
71217e42 |
11 | use DX::Op::Not; |
12 | use DX::Op::ProposeAction; |
13 | use DX::Op::Materialize; |
b40e416a |
14 | use List::Util qw(reduce); |
15 | |
16 | has rules => (is => 'ro', default => sub { {} }); |
17 | |
18 | sub add_rule { |
19 | my ($self, $name, $vars, @body) = @_; |
20 | my $full_name = join('/', $name, scalar @$vars); |
21 | push @{$self->rules->{$full_name}}, $self->_make_rule($vars, @body); |
22 | return $self; |
23 | } |
24 | |
25 | sub _make_rule { |
26 | my ($self, $vars, @body) = @_; |
71217e42 |
27 | my $head = $self->_expand_and_link(DX::Op::Return->new, @body); |
b40e416a |
28 | [ $vars, $head ]; |
29 | } |
30 | |
71217e42 |
31 | sub _expand_and_link { |
32 | my ($self, $last, @body) = @_; |
33 | return reduce { $b->but(next => $a) } |
34 | $last, |
35 | reverse map $self->expand(@$_), @body; |
36 | } |
37 | |
b40e416a |
38 | sub expand { |
39 | my ($self, $type, @rest) = @_; |
71217e42 |
40 | if ($self->can(my $expand_meth = "_expand_op_${type}")) { |
6d533c9d |
41 | return $self->$expand_meth(@rest); |
42 | } |
43 | return $self->_expand_call($type, @rest); |
b40e416a |
44 | } |
45 | |
46 | sub _expand_call { |
47 | my ($self, $name, @args) = @_; |
48 | DX::Op::CallRule->new(rule_name => $name, rule_args => \@args); |
49 | } |
50 | |
71217e42 |
51 | sub _expand_op_cut { return DX::Op::Cut->new } |
734376d9 |
52 | |
71217e42 |
53 | sub _expand_op_fail { return DX::Op::Backtrack->new } |
54 | |
55 | sub _expand_op_not { |
56 | my ($self, @contents) = @_; |
57 | my $cut = DX::Op::Cut->new(next => DX::Op::Backtrack->new); |
58 | DX::Op::Not->new( |
59 | body => $self->_expand_and_link($cut, @contents) |
60 | ); |
61 | } |
62 | |
63 | sub _expand_op_member_of { |
385fa954 |
64 | my ($self, $member_var, $coll_var) = @_; |
b40e416a |
65 | DX::Op::MemberOf->new( |
66 | member_var => $member_var, |
385fa954 |
67 | coll_var => $coll_var, |
b40e416a |
68 | ); |
69 | } |
70 | |
71217e42 |
71 | sub _expand_op_constrain { |
b40e416a |
72 | my ($self, $vars, $constraint) = @_; |
73 | DX::Op::ApplyConstraint->new( |
74 | vars => $vars, |
75 | constraint => $constraint |
76 | ); |
77 | } |
78 | |
71217e42 |
79 | sub _expand_op_observe { |
5ef4d923 |
80 | my ($self, $vars, $builder) = @_; |
81 | DX::Op::Observe->new( |
82 | vars => $vars, |
83 | builder => $builder, |
84 | ); |
85 | } |
86 | |
71217e42 |
87 | sub _expand_op_act { |
88 | my ($self, $vars, $builder) = @_; |
89 | DX::Op::ProposeAction->new( |
90 | vars => $vars, |
91 | builder => $builder, |
92 | ); |
93 | } |
94 | |
95 | sub _expand_op_materialize { |
96 | my ($self, $var_name) = @_; |
97 | DX::Op::Materialize->new(var_name => $var_name); |
98 | } |
99 | |
b40e416a |
100 | 1; |