better naming and help command for KeyMangler

[scpubgit/DKit.git] / lib / DX / State.pm

package DX::State;

use Return::MultiLevel qw(with_return);
use DX::Op::Backtrack;
use Scalar::Util qw(blessed);
use List::MoreUtils qw(uniq);
use Safe::Isa;
use Moo;

has next_op => (is => 'ro', required => 1);

has return_stack => (is => 'ro', required => 1);

has by_id => (is => 'ro', required => 1);

has scope => (is => 'ro', required => 1);

has last_choice => (is => 'ro', required => 1);

has id_gen => (is => 'ro', default => sub { {} });

has rule_set => (is => 'ro');

has facts => (is => 'ro');

has dependencies => (is => 'ro', default => sub { {} });

has allow_actions => (is => 'ro', default => sub { 1 });

has actions => (is => 'ro', default => sub { {} });

sub has_scope_var {
  my ($self, $name) = @_;
  return !!$self->scope->{$name};
}

sub scope_var {
  my ($self, $name) = @_;
  my $id = $self->scope->{$name}
    or die "no such variable in scope: $name";
  $self->by_id->{$id};
}

sub resolve_value {
  my ($self, $var) = @_;
die("FUCK") unless $var;
  die "Can't resolve unbound ${\$var->id}" unless $var->is_bound;
  my $val = $var->bound_value;
  if ($val->$_does('DX::Role::Ref')) {
    return $val->resolve($self);
  }
  return $val;
}

sub allocate_var {
  my ($self, $name, $var, $id_gen) = @_;
  my $id = join('_', $name, ++($id_gen->{$name}||='000'));
  DX::Var->new(id => $id, %$var);
}

sub expand_vars {
  my ($self, %vars) = @_;
  my %by_id = %{$self->by_id};
  my %id_gen = %{$self->id_gen};
  foreach my $name (keys %vars) {
    unless (blessed($vars{$name})) {
      my $var = $vars{$name} = $self->allocate_var(
        $name, $vars{$name}, \%id_gen
      );
      $by_id{$var->id} = $var;
    }
  }
  $self->but(
    by_id => \%by_id, id_gen => \%id_gen,
  ), %vars;
}

sub record_action {
  my ($self, $action) = @_;
  my %id_gen = %{$self->id_gen};
  my ($type) = (ref($action) =~ /([^:]+)$/);
  my $id = join('_', $type, ++($id_gen{$type}||='000'));
  my $recorded = $action->but(id => $id);
  $self->but(
    id_gen => \%id_gen,
    actions => { %{$self->actions}, $id => $recorded }
  ), $id;
}

sub assign_vars {
  my ($self, %vars) = @_;
  my ($state, %expanded) = $self->expand_vars(%vars);
  $state->but(
    scope => { %{$self->scope}, map +($_ => $expanded{$_}->id), keys %expanded }
  );
}

sub bind_value {
  my ($self, $var_id, $value) = @_;
  my $bound = $self->by_id->{$var_id}->with_value($value);
  $self->but(
    by_id => { %{$self->by_id}, $var_id => $bound },
  );
}

sub bind_stream {
  my ($self, $var, $stream) = @_;
  my $bound = $var->with_stream($stream);
  $self->but(
    by_id => { %{$self->by_id}, $var->id => $bound },
  )->mark_choice($bound);
}

sub bind_root_set {
  my ($self, $var_id, $set) = @_;
  my $bound = $self->by_id->{$var_id}->with_root_set($set);
  $self->but(
    by_id => { %{$self->by_id}, $var_id => $bound },
  )->mark_choice($bound);
}

sub mark_choice {
  my ($self, $var) = @_;
  $self->but(last_choice => [ $self, $var ]);
}

sub backtrack {
  my ($self) = @_;
  my ($state, $var) = ($self);
  while (($state, $var) = @{$state->last_choice}) {
    $var->bound_value; $var->clear_bound_value;
    return $state->mark_choice($var) unless $var->bound_stream->is_exhausted;
  }
  $self->return_from_run(undef);
}

sub then {
  my ($self, $then) = @_;
  $self->but(next_op => $then);
}

sub return_from_run {
  my (undef, $return) = @_;
  (our $Run_Return)->($return);
}

sub return_from_op {
  my (undef, $return) = @_;
  if (our $Op_Return) {
    $Op_Return->($return);
  }
}

sub run {
  my ($state) = @_;
  with_return {
    my ($return) = @_;
    local our $Run_Return = $return;
    while (my $op = $state->next_op) {
      my $backtrack = with_return {
        my ($return) = @_;
        local our $Op_Return = $return;
        $state = $op->run($state);
        return;
      };
      if ($backtrack) { $state = $state->backtrack }
    }
    return $state;
  }
}

sub push_backtrack {
  $_[0]->then(DX::Op::Backtrack->new);
}

sub but {
  my ($self, @but) = @_;
  $self->new(%$self, @but);
}

sub pop_return_stack {
  my ($self) = @_;
  my @stack = @{$self->return_stack};
  my $top = pop @stack;
  $self->but(return_stack => \@stack, next_op => $top->[0]);
}

sub push_return_then {
  my ($self, $return, $then) = @_;
  $self->but(
    return_stack => [ @{$self->return_stack}, [ $return, $self ] ],
    next_op => $then
  );
}

sub add_dependencies {
  my ($self, @pairs) = @_;
  my %deps = %{$self->dependencies};
  while (my ($from, $to) = splice(@pairs, 0, 2)) {
    unless ($deps{$from}{$to}) {
      $deps{$from} = { %{$deps{$from}||{}}, $to => 1 };
    }
  }
  $self->but(dependencies => \%deps);
}

sub action_dependencies {
  my ($self, @ids) = @_;
  my @found;
  my $deps = $self->dependencies;
  my $by_id = $self->by_id;
  my %seen;
  my @queue = @ids;
  while (my $id = shift @queue) {
    $seen{$id}++;
    my $value = $self->resolve_value($by_id->{$id});
    push @found, $value if $value->$_does('DX::Role::Fact')
                           and $value->has_required_action;
    push @queue, grep !$seen{$_}, keys %{$deps->{$id}};
  }
  return uniq map $_->required_action, @found;
}

sub copy_vars {
  my ($self) = @_;
  my $by_id = $self->by_id;
  $self->but(by_id => {
    map +($_ => $by_id->{$_}->copy), keys %$by_id
  });
}

1;