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