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