remove the _then bind methods
[scpubgit/DKit.git] / lib / DX / State.pm
1 package DX::State;
2
3 use Return::MultiLevel qw(with_return);
4 use DX::Op::Backtrack;
5 use Scalar::Util qw(blessed);
6 use Moo;
7
8 has next_op => (is => 'ro', required => 1);
9
10 has return_stack => (is => 'ro', required => 1);
11
12 has by_id => (is => 'ro', required => 1);
13
14 has scope => (is => 'ro', required => 1);
15
16 has last_choice => (is => 'ro', required => 1);
17
18 has id_gen => (is => 'ro', default => sub { {} });
19
20 has rule_set => (is => 'ro');
21
22 has facts => (is => 'ro');
23
24 has dependencies => (is => 'ro', default => sub { {} });
25
26 sub scope_var {
27   my ($self, $name) = @_;
28   $self->by_id->{$self->scope->{$name}};
29 }
30
31 sub allocate_var {
32   my ($self, $name, $var, $id_gen) = @_;
33   my $id = join('_', $name, ++($id_gen->{$name}||='000'));
34   DX::Var->new(id => $id, %$var);
35 }
36
37 sub expand_vars {
38   my ($self, %vars) = @_;
39   my %by_id = %{$self->by_id};
40   my %id_gen = %{$self->id_gen};
41   foreach my $name (keys %vars) {
42     unless (blessed($vars{$name})) {
43       my $var = $vars{$name} = $self->allocate_var(
44         $name, $vars{$name}, \%id_gen
45       );
46       $by_id{$var->id} = $var;
47     }
48   }
49   $self->but(
50     by_id => \%by_id, id_gen => \%id_gen,
51   ), %vars;
52 }
53
54 sub assign_vars {
55   my ($self, %vars) = @_;
56   my ($state, %expanded) = $self->expand_vars(%vars);
57   $state->but(
58     scope => { %{$self->scope}, map +($_ => $expanded{$_}->id), keys %expanded }
59   );
60 }
61
62 sub bind_value {
63   my ($self, $var_id, $value) = @_;
64   my $bound = $self->by_id->{$var_id}->with_value($value);
65   $self->but(
66     by_id => { %{$self->by_id}, $var_id => $bound },
67   );
68 }
69
70 sub bind_stream {
71   my ($self, $var, $stream) = @_;
72   my $bound = $var->with_stream($stream);
73   $self->but(
74     by_id => { %{$self->by_id}, $var->id => $bound },
75   )->mark_choice($bound);
76 }
77
78 sub bind_root_set {
79   my ($self, $var_id, $set) = @_;
80   my $bound = $self->by_id->{$var_id}->with_root_set($set);
81   $self->but(
82     by_id => { %{$self->by_id}, $var_id => $bound },
83   )->mark_choice($bound);
84 }
85
86 sub mark_choice {
87   my ($self, $var) = @_;
88   $self->but(last_choice => [ $self, $var ]);
89 }
90
91 sub backtrack {
92   my ($self) = @_;
93   my ($state, $var) = ($self);
94   while (($state, $var) = @{$state->last_choice}) {
95     $var->bound_value; $var->clear_bound_value;
96     return $state->mark_choice($var) unless $var->bound_stream->is_exhausted;
97   }
98   $self->return_from_run(undef);
99 }
100
101 sub then {
102   my ($self, $then) = @_;
103   $self->but(next_op => $then);
104 }
105
106 sub return_from_run {
107   my (undef, $return) = @_;
108   (our $Run_Return)->($return);
109 }
110
111 sub return_from_op {
112   my (undef, $return) = @_;
113   if (our $Op_Return) {
114     $Op_Return->($return);
115   }
116 }
117
118 sub run {
119   my ($state) = @_;
120   with_return {
121     my ($return) = @_;
122     local our $Run_Return = $return;
123     while (my $op = $state->next_op) {
124       my $backtrack = with_return {
125         my ($return) = @_;
126         local our $Op_Return = $return;
127         $state = $op->run($state);
128         return;
129       };
130       if ($backtrack) { $state = $state->backtrack }
131     }
132     return $state;
133   }
134 }
135
136 sub push_backtrack {
137   $_[0]->then(DX::Op::Backtrack->new);
138 }
139
140 sub but {
141   my ($self, @but) = @_;
142   $self->new(%$self, @but);
143 }
144
145 sub pop_return_stack {
146   my ($self) = @_;
147   my @stack = @{$self->return_stack};
148   my $top = pop @stack;
149   $self->but(return_stack => \@stack, next_op => $top->[0]);
150 }
151
152 sub push_return_then {
153   my ($self, $return, $then) = @_;
154   $self->but(
155     return_stack => [ @{$self->return_stack}, [ $return, $self ] ],
156     next_op => $then
157   );
158 }
159
160 sub add_dependencies {
161   my ($self, @pairs) = @_;
162   my %deps = %{$self->dependencies};
163   while (my ($from, $to) = splice(@pairs, 0, 2)) {
164     unless ($deps{$from}{$to}) {
165       $deps{$from} = { %{$deps{$from}||{}}, $to => 1 };
166     }
167   }
168   $self->but(dependencies => \%deps);
169 }
170
171 sub action_dependencies {
172   my ($self, @ids) = @_;
173   my @found;
174   my $deps = $self->dependencies;
175   my $by_id = $self->by_id;
176   my %seen;
177   my @queue = @ids;
178   while (my $id = shift @queue) {
179     $seen{$id}++;
180     push @found, $id if $by_id->{$id}->has_action;
181     push @queue, grep !$seen{$_}, keys %{$deps->{$id}};
182   }
183   return @found;
184 }
185
186 sub copy_vars {
187   my ($self) = @_;
188   my $by_id = $self->by_id;
189   $self->but(by_id => {
190     map +($_ => $by_id->{$_}->copy), keys %$by_id
191   });
192 }
193
194 1;