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_then {
  71   my ($self, $var, $stream, $then) = @_;
  72   my $bound = $var->with_stream($stream);
  73   $self->but(
  74     by_id => { %{$self->by_id}, $var->id => $bound },
  75     next_op => $then
  76   )->mark_choice($bound);
  77 }
  78
  79 sub bind_root_set_then {
  80   my ($self, $var_id, $set, $then) = @_;
  81   my $bound = $self->by_id->{$var_id}->with_root_set($set);
  82   $self->but(
  83     by_id => { %{$self->by_id}, $var_id => $bound },
  84     next_op => $then
  85   )->mark_choice($bound);
  86 }
  87
  88 sub mark_choice {
  89   my ($self, $var) = @_;
  90   $self->but(last_choice => [ $self, $var ]);
  91 }
  92
  93 sub backtrack {
  94   my ($self) = @_;
  95   my ($state, $var) = ($self);
  96   while (($state, $var) = @{$state->last_choice}) {
  97     $var->bound_value; $var->clear_bound_value;
  98     return $state->mark_choice($var) unless $var->bound_stream->is_exhausted;
  99   }
 100   $self->return_from_run(undef);
 101 }
 102
 103 sub then {
 104   my ($self, $then) = @_;
 105   $self->but(next_op => $then);
 106 }
 107
 108 sub return_from_run {
 109   my (undef, $return) = @_;
 110   (our $Run_Return)->($return);
 111 }
 112
 113 sub return_from_op {
 114   my (undef, $return) = @_;
 115   if (our $Op_Return) {
 116     $Op_Return->($return);
 117   }
 118 }
 119
 120 sub run {
 121   my ($state) = @_;
 122   with_return {
 123     my ($return) = @_;
 124     local our $Run_Return = $return;
 125     while (my $op = $state->next_op) {
 126       my $backtrack = with_return {
 127         my ($return) = @_;
 128         local our $Op_Return = $return;
 129         $state = $op->run($state);
 130         return;
 131       };
 132       if ($backtrack) { $state = $state->backtrack }
 133     }
 134     return $state;
 135   }
 136 }
 137
 138 sub push_backtrack {
 139   $_[0]->then(DX::Op::Backtrack->new);
 140 }
 141
 142 sub but {
 143   my ($self, @but) = @_;
 144   $self->new(%$self, @but);
 145 }
 146
 147 sub pop_return_stack {
 148   my ($self) = @_;
 149   my @stack = @{$self->return_stack};
 150   my $top = pop @stack;
 151   $self->but(return_stack => \@stack, next_op => $top->[0]);
 152 }
 153
 154 sub push_return_then {
 155   my ($self, $return, $then) = @_;
 156   $self->but(
 157     return_stack => [ @{$self->return_stack}, [ $return, $self ] ],
 158     next_op => $then
 159   );
 160 }
 161
 162 sub add_dependencies {
 163   my ($self, @pairs) = @_;
 164   my %deps = %{$self->dependencies};
 165   while (my ($from, $to) = splice(@pairs, 0, 2)) {
 166     unless ($deps{$from}{$to}) {
 167       $deps{$from} = { %{$deps{$from}||{}}, $to => 1 };
 168     }
 169   }
 170   $self->but(dependencies => \%deps);
 171 }
 172
 173 sub action_dependencies {
 174   my ($self, @ids) = @_;
 175   my @found;
 176   my $deps = $self->dependencies;
 177   my $by_id = $self->by_id;
 178   my %seen;
 179   my @queue = @ids;
 180   while (my $id = shift @queue) {
 181     $seen{$id}++;
 182     push @found, $id if $by_id->{$id}->has_action;
 183     push @queue, grep !$seen{$_}, keys %{$deps->{$id}};
 184   }
 185   return @found;
 186 }
 187
 188 sub copy_vars {
 189   my ($self) = @_;
 190   my $by_id = $self->by_id;
 191   $self->but(by_id => {
 192     map +($_ => $by_id->{$_}->copy), keys %$by_id
 193   });
 194 }
 195
 196 1;