Commit | Line | Data |
60cda014 |
1 | package DX::State; |
2 | |
5622b4df |
3 | use Return::MultiLevel qw(with_return); |
71217e42 |
4 | use DX::Op::Backtrack; |
b373788e |
5 | use Scalar::Util qw(blessed); |
e02a5c0a |
6 | use List::MoreUtils qw(uniq); |
4ce2e778 |
7 | use Safe::Isa; |
60cda014 |
8 | use Moo; |
9 | |
10 | has next_op => (is => 'ro', required => 1); |
11 | |
12 | has return_stack => (is => 'ro', required => 1); |
13 | |
14 | has by_id => (is => 'ro', required => 1); |
15 | |
16 | has scope => (is => 'ro', required => 1); |
17 | |
18 | has last_choice => (is => 'ro', required => 1); |
19 | |
b373788e |
20 | has id_gen => (is => 'ro', default => sub { {} }); |
21 | |
b40e416a |
22 | has rule_set => (is => 'ro'); |
23 | |
24 | has facts => (is => 'ro'); |
25 | |
deec7cc4 |
26 | has dependencies => (is => 'ro', default => sub { {} }); |
27 | |
7ca660cb |
28 | has allow_actions => (is => 'ro', default => sub { 1 }); |
29 | |
577a2146 |
30 | has actions => (is => 'ro', default => sub { {} }); |
31 | |
a5c3a041 |
32 | sub has_scope_var { |
33 | my ($self, $name) = @_; |
34 | return !!$self->scope->{$name}; |
35 | } |
36 | |
60cda014 |
37 | sub scope_var { |
38 | my ($self, $name) = @_; |
e09f23e1 |
39 | my $id = $self->scope->{$name} |
40 | or die "no such variable in scope: $name"; |
41 | $self->by_id->{$id}; |
60cda014 |
42 | } |
43 | |
0676b282 |
44 | sub resolve_value { |
45 | my ($self, $var) = @_; |
e02a5c0a |
46 | die("FUCK") unless $var; |
47 | die "Can't resolve unbound ${\$var->id}" unless $var->is_bound; |
4ce2e778 |
48 | my $val = $var->bound_value; |
49 | if ($val->$_does('DX::Role::Ref')) { |
50 | return $val->resolve($self); |
51 | } |
52 | return $val; |
0676b282 |
53 | } |
54 | |
b373788e |
55 | sub allocate_var { |
606537d1 |
56 | my ($self, $name, $var, $id_gen) = @_; |
57 | my $id = join('_', $name, ++($id_gen->{$name}||='000')); |
b373788e |
58 | DX::Var->new(id => $id, %$var); |
59 | } |
60 | |
606537d1 |
61 | sub expand_vars { |
b373788e |
62 | my ($self, %vars) = @_; |
63 | my %by_id = %{$self->by_id}; |
606537d1 |
64 | my %id_gen = %{$self->id_gen}; |
b373788e |
65 | foreach my $name (keys %vars) { |
b373788e |
66 | unless (blessed($vars{$name})) { |
606537d1 |
67 | my $var = $vars{$name} = $self->allocate_var( |
68 | $name, $vars{$name}, \%id_gen |
69 | ); |
b373788e |
70 | $by_id{$var->id} = $var; |
71 | } |
72 | } |
606537d1 |
73 | $self->but( |
74 | by_id => \%by_id, id_gen => \%id_gen, |
75 | ), %vars; |
76 | } |
77 | |
577a2146 |
78 | sub record_action { |
79 | my ($self, $action) = @_; |
80 | my %id_gen = %{$self->id_gen}; |
81 | my ($type) = (ref($action) =~ /([^:]+)$/); |
82 | my $id = join('_', $type, ++($id_gen{$type}||='000')); |
83 | my $recorded = $action->but(id => $id); |
84 | $self->but( |
85 | id_gen => \%id_gen, |
86 | actions => { %{$self->actions}, $id => $recorded } |
87 | ), $id; |
88 | } |
89 | |
606537d1 |
90 | sub assign_vars { |
91 | my ($self, %vars) = @_; |
92 | my ($state, %expanded) = $self->expand_vars(%vars); |
b40e416a |
93 | $state->but( |
606537d1 |
94 | scope => { %{$self->scope}, map +($_ => $expanded{$_}->id), keys %expanded } |
b373788e |
95 | ); |
96 | } |
97 | |
0de441cd |
98 | sub bind_value { |
859049a3 |
99 | my ($self, $var_id, $value) = @_; |
100 | my $bound = $self->by_id->{$var_id}->with_value($value); |
b40d5c51 |
101 | $self->but( |
859049a3 |
102 | by_id => { %{$self->by_id}, $var_id => $bound }, |
b40d5c51 |
103 | ); |
104 | } |
105 | |
7a0670cd |
106 | sub bind_stream { |
107 | my ($self, $var, $stream) = @_; |
60cda014 |
108 | my $bound = $var->with_stream($stream); |
03079510 |
109 | $self->but( |
60cda014 |
110 | by_id => { %{$self->by_id}, $var->id => $bound }, |
60cda014 |
111 | )->mark_choice($bound); |
112 | } |
113 | |
7a0670cd |
114 | sub bind_root_set { |
115 | my ($self, $var_id, $set) = @_; |
1b6999da |
116 | my $bound = $self->by_id->{$var_id}->with_root_set($set); |
d95799c4 |
117 | $self->but( |
1b6999da |
118 | by_id => { %{$self->by_id}, $var_id => $bound }, |
d95799c4 |
119 | )->mark_choice($bound); |
120 | } |
121 | |
60cda014 |
122 | sub mark_choice { |
123 | my ($self, $var) = @_; |
03079510 |
124 | $self->but(last_choice => [ $self, $var ]); |
60cda014 |
125 | } |
126 | |
127 | sub backtrack { |
128 | my ($self) = @_; |
94565614 |
129 | my ($state, $var) = ($self); |
130 | while (($state, $var) = @{$state->last_choice}) { |
60cda014 |
131 | $var->bound_value; $var->clear_bound_value; |
94565614 |
132 | return $state->mark_choice($var) unless $var->bound_stream->is_exhausted; |
60cda014 |
133 | } |
b40d5c51 |
134 | $self->return_from_run(undef); |
60cda014 |
135 | } |
136 | |
137 | sub then { |
138 | my ($self, $then) = @_; |
03079510 |
139 | $self->but(next_op => $then); |
60cda014 |
140 | } |
141 | |
b40d5c51 |
142 | sub return_from_run { |
143 | my (undef, $return) = @_; |
71217e42 |
144 | (our $Run_Return)->($return); |
145 | } |
146 | |
147 | sub return_from_op { |
148 | my (undef, $return) = @_; |
149 | if (our $Op_Return) { |
150 | $Op_Return->($return); |
151 | } |
b40d5c51 |
152 | } |
153 | |
94565614 |
154 | sub run { |
155 | my ($state) = @_; |
5622b4df |
156 | with_return { |
157 | my ($return) = @_; |
71217e42 |
158 | local our $Run_Return = $return; |
54817920 |
159 | while (my $op = $state->next_op) { |
71217e42 |
160 | my $backtrack = with_return { |
161 | my ($return) = @_; |
162 | local our $Op_Return = $return; |
163 | $state = $op->run($state); |
164 | return; |
165 | }; |
166 | if ($backtrack) { $state = $state->backtrack } |
5622b4df |
167 | } |
168 | return $state; |
94565614 |
169 | } |
5622b4df |
170 | } |
171 | |
172 | sub push_backtrack { |
71217e42 |
173 | $_[0]->then(DX::Op::Backtrack->new); |
94565614 |
174 | } |
175 | |
03079510 |
176 | sub but { |
177 | my ($self, @but) = @_; |
178 | $self->new(%$self, @but); |
179 | } |
180 | |
b40d5c51 |
181 | sub pop_return_stack { |
182 | my ($self) = @_; |
183 | my @stack = @{$self->return_stack}; |
184 | my $top = pop @stack; |
734376d9 |
185 | $self->but(return_stack => \@stack, next_op => $top->[0]); |
b40d5c51 |
186 | } |
187 | |
188 | sub push_return_then { |
189 | my ($self, $return, $then) = @_; |
190 | $self->but( |
734376d9 |
191 | return_stack => [ @{$self->return_stack}, [ $return, $self ] ], |
b40d5c51 |
192 | next_op => $then |
193 | ); |
194 | } |
195 | |
deec7cc4 |
196 | sub add_dependencies { |
197 | my ($self, @pairs) = @_; |
198 | my %deps = %{$self->dependencies}; |
199 | while (my ($from, $to) = splice(@pairs, 0, 2)) { |
200 | unless ($deps{$from}{$to}) { |
201 | $deps{$from} = { %{$deps{$from}||{}}, $to => 1 }; |
202 | } |
203 | } |
204 | $self->but(dependencies => \%deps); |
205 | } |
206 | |
207 | sub action_dependencies { |
208 | my ($self, @ids) = @_; |
209 | my @found; |
210 | my $deps = $self->dependencies; |
211 | my $by_id = $self->by_id; |
212 | my %seen; |
213 | my @queue = @ids; |
214 | while (my $id = shift @queue) { |
215 | $seen{$id}++; |
9c7b21a2 |
216 | my $value = $self->resolve_value($by_id->{$id}); |
577a2146 |
217 | push @found, $value if $value->$_does('DX::Role::Fact') |
218 | and $value->has_required_action; |
deec7cc4 |
219 | push @queue, grep !$seen{$_}, keys %{$deps->{$id}}; |
220 | } |
e02a5c0a |
221 | return uniq map $_->required_action, @found; |
deec7cc4 |
222 | } |
223 | |
224 | sub copy_vars { |
225 | my ($self) = @_; |
226 | my $by_id = $self->by_id; |
227 | $self->but(by_id => { |
228 | map +($_ => $by_id->{$_}->copy), keys %$by_id |
229 | }); |
230 | } |
231 | |
60cda014 |
232 | 1; |