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 sub scope_var {
  25   my ($self, $name) = @_;
  26   $self->by_id->{$self->scope->{$name}};
  27 }
  28
  29 sub allocate_var {
  30   my ($self, $name, $var, $id_gen) = @_;
  31   my $id = join('_', $name, ++($id_gen->{$name}||='000'));
  32   DX::Var->new(id => $id, %$var);
  33 }
  34
  35 sub expand_vars {
  36   my ($self, %vars) = @_;
  37   my %by_id = %{$self->by_id};
  38   my %id_gen = %{$self->id_gen};
  39   foreach my $name (keys %vars) {
  40     unless (blessed($vars{$name})) {
  41       my $var = $vars{$name} = $self->allocate_var(
  42         $name, $vars{$name}, \%id_gen
  43       );
  44       $by_id{$var->id} = $var;
  45     }
  46   }
  47   $self->but(
  48     by_id => \%by_id, id_gen => \%id_gen,
  49   ), %vars;
  50 }
  51
  52 sub assign_vars {
  53   my ($self, %vars) = @_;
  54   my ($state, %expanded) = $self->expand_vars(%vars);
  55   $state->but(
  56     scope => { %{$self->scope}, map +($_ => $expanded{$_}->id), keys %expanded }
  57   );
  58 }
  59
  60 sub bind_var_then {
  61   my ($self, $var, $value, $then) = @_;
  62   my $bound = $var->with_value($value);
  63   $self->but(
  64     by_id => { %{$self->by_id}, $var->id => $bound },
  65     next_op => $then
  66   );
  67 }
  68
  69 sub bind_stream_then {
  70   my ($self, $var, $stream, $then) = @_;
  71   my $bound = $var->with_stream($stream);
  72   $self->but(
  73     by_id => { %{$self->by_id}, $var->id => $bound },
  74     next_op => $then
  75   )->mark_choice($bound);
  76 }
  77
  78 sub mark_choice {
  79   my ($self, $var) = @_;
  80   $self->but(last_choice => [ $self, $var ]);
  81 }
  82
  83 sub backtrack {
  84   my ($self) = @_;
  85   my ($state, $var) = ($self);
  86   while (($state, $var) = @{$state->last_choice}) {
  87     $var->bound_value; $var->clear_bound_value;
  88     return $state->mark_choice($var) unless $var->bound_stream->is_exhausted;
  89   }
  90   $self->return_from_run(undef);
  91 }
  92
  93 sub then {
  94   my ($self, $then) = @_;
  95   $self->but(next_op => $then);
  96 }
  97
  98 sub return_from_run {
  99   my (undef, $return) = @_;
 100   (our $Run_Return)->($return);
 101 }
 102
 103 sub return_from_op {
 104   my (undef, $return) = @_;
 105   if (our $Op_Return) {
 106     $Op_Return->($return);
 107   }
 108 }
 109
 110 sub run {
 111   my ($state) = @_;
 112   with_return {
 113     my ($return) = @_;
 114     local our $Run_Return = $return;
 115     while (my $op = $state->next_op) {
 116       my $backtrack = with_return {
 117         my ($return) = @_;
 118         local our $Op_Return = $return;
 119         $state = $op->run($state);
 120         return;
 121       };
 122       if ($backtrack) { $state = $state->backtrack }
 123     }
 124     return $state;
 125   }
 126 }
 127
 128 sub push_backtrack {
 129   $_[0]->then(DX::Op::Backtrack->new);
 130 }
 131
 132 sub but {
 133   my ($self, @but) = @_;
 134   $self->new(%$self, @but);
 135 }
 136
 137 sub pop_return_stack {
 138   my ($self) = @_;
 139   my @stack = @{$self->return_stack};
 140   my $top = pop @stack;
 141   $self->but(return_stack => \@stack, next_op => $top->[0]);
 142 }
 143
 144 sub push_return_then {
 145   my ($self, $return, $then) = @_;
 146   $self->but(
 147     return_stack => [ @{$self->return_stack}, [ $return, $self ] ],
 148     next_op => $then
 149   );
 150 }
 151
 152 1;