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 List::MoreUtils qw(uniq);
   7 use Safe::Isa;
   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
  20 has id_gen => (is => 'ro', default => sub { {} });
  21
  22 has rule_set => (is => 'ro');
  23
  24 has facts => (is => 'ro');
  25
  26 has dependencies => (is => 'ro', default => sub { {} });
  27
  28 has allow_actions => (is => 'ro', default => sub { 1 });
  29
  30 has actions => (is => 'ro', default => sub { {} });
  31
  32 sub has_scope_var {
  33   my ($self, $name) = @_;
  34   return !!$self->scope->{$name};
  35 }
  36
  37 sub scope_var {
  38   my ($self, $name) = @_;
  39   my $id = $self->scope->{$name}
  40     or die "no such variable in scope: $name";
  41   $self->by_id->{$id};
  42 }
  43
  44 sub resolve_value {
  45   my ($self, $var) = @_;
  46 die("FUCK") unless $var;
  47   die "Can't resolve unbound ${\$var->id}" unless $var->is_bound;
  48   my $val = $var->bound_value;
  49   if ($val->$_does('DX::Role::Ref')) {
  50     return $val->resolve($self);
  51   }
  52   return $val;
  53 }
  54
  55 sub allocate_var {
  56   my ($self, $name, $var, $id_gen) = @_;
  57   my $id = join('_', $name, ++($id_gen->{$name}||='000'));
  58   DX::Var->new(id => $id, %$var);
  59 }
  60
  61 sub expand_vars {
  62   my ($self, %vars) = @_;
  63   my %by_id = %{$self->by_id};
  64   my %id_gen = %{$self->id_gen};
  65   foreach my $name (keys %vars) {
  66     unless (blessed($vars{$name})) {
  67       my $var = $vars{$name} = $self->allocate_var(
  68         $name, $vars{$name}, \%id_gen
  69       );
  70       $by_id{$var->id} = $var;
  71     }
  72   }
  73   $self->but(
  74     by_id => \%by_id, id_gen => \%id_gen,
  75   ), %vars;
  76 }
  77
  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
  90 sub assign_vars {
  91   my ($self, %vars) = @_;
  92   my ($state, %expanded) = $self->expand_vars(%vars);
  93   $state->but(
  94     scope => { %{$self->scope}, map +($_ => $expanded{$_}->id), keys %expanded }
  95   );
  96 }
  97
  98 sub bind_value {
  99   my ($self, $var_id, $value) = @_;
 100   my $bound = $self->by_id->{$var_id}->with_value($value);
 101   $self->but(
 102     by_id => { %{$self->by_id}, $var_id => $bound },
 103   );
 104 }
 105
 106 sub bind_stream {
 107   my ($self, $var, $stream) = @_;
 108   my $bound = $var->with_stream($stream);
 109   $self->but(
 110     by_id => { %{$self->by_id}, $var->id => $bound },
 111   )->mark_choice($bound);
 112 }
 113
 114 sub bind_root_set {
 115   my ($self, $var_id, $set) = @_;
 116   my $bound = $self->by_id->{$var_id}->with_root_set($set);
 117   $self->but(
 118     by_id => { %{$self->by_id}, $var_id => $bound },
 119   )->mark_choice($bound);
 120 }
 121
 122 sub mark_choice {
 123   my ($self, $var) = @_;
 124   $self->but(last_choice => [ $self, $var ]);
 125 }
 126
 127 sub backtrack {
 128   my ($self) = @_;
 129   my ($state, $var) = ($self);
 130   while (($state, $var) = @{$state->last_choice}) {
 131     $var->bound_value; $var->clear_bound_value;
 132     return $state->mark_choice($var) unless $var->bound_stream->is_exhausted;
 133   }
 134   $self->return_from_run(undef);
 135 }
 136
 137 sub then {
 138   my ($self, $then) = @_;
 139   $self->but(next_op => $then);
 140 }
 141
 142 sub return_from_run {
 143   my (undef, $return) = @_;
 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   }
 152 }
 153
 154 sub run {
 155   my ($state) = @_;
 156   with_return {
 157     my ($return) = @_;
 158     local our $Run_Return = $return;
 159     while (my $op = $state->next_op) {
 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 }
 167     }
 168     return $state;
 169   }
 170 }
 171
 172 sub push_backtrack {
 173   $_[0]->then(DX::Op::Backtrack->new);
 174 }
 175
 176 sub but {
 177   my ($self, @but) = @_;
 178   $self->new(%$self, @but);
 179 }
 180
 181 sub pop_return_stack {
 182   my ($self) = @_;
 183   my @stack = @{$self->return_stack};
 184   my $top = pop @stack;
 185   $self->but(return_stack => \@stack, next_op => $top->[0]);
 186 }
 187
 188 sub push_return_then {
 189   my ($self, $return, $then) = @_;
 190   $self->but(
 191     return_stack => [ @{$self->return_stack}, [ $return, $self ] ],
 192     next_op => $then
 193   );
 194 }
 195
 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}++;
 216     my $value = $self->resolve_value($by_id->{$id});
 217     push @found, $value if $value->$_does('DX::Role::Fact')
 218                            and $value->has_required_action;
 219     push @queue, grep !$seen{$_}, keys %{$deps->{$id}};
 220   }
 221   return uniq map $_->required_action, @found;
 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
 232 1;