format aperture in backtrack trace

[scpubgit/DX.git] / lib / DX / QueryState.pm

package DX::QueryState;

use DX::Scope;
use DX::Hypothesis;
use DX::SearchProcess;
use DX::ResolvedPropositionSet;
use DX::ActionPolicy::Allow;
use DX::Step::MarkAsExhaustion;
use DX::Utils qw(:builders);
use DX::Class;

has predicates => (is => 'ro', isa => HashRef[Predicate], required => 1);

has globals => (is => 'ro', isa => DictValue, required => 1);

has proposition_sequence => (
  is => 'ro', isa => PropositionSequence, required => 1
);

has search_process => (
  is => 'lazy', isa => SearchProcess, builder => sub {
    $_[0]->new_search_process_for($_[0]->proposition_sequence)
  }, handles => { search_state => 'current_search_state' },
);

sub new_search_process_for {
  my ($self, $prop_seq) = @_;
  my @local_names = map { keys %{$_->introduced_names} }
                      @{$prop_seq->members};
  my $scope = DX::Scope->new(
    predicates => $self->predicates,
    globals => $self->globals,
    locals => [ dict() ],
    lex_map => { }
  );
  my $hyp = DX::Hypothesis->new(
    scope => $scope,
    resolved_propositions => DX::ResolvedPropositionSet->new_empty,
    actions => [],
    action_applications => [],
    action_policy => DX::ActionPolicy::Allow->new,
  );
  return DX::SearchProcess->new_for($hyp, $prop_seq);
}

sub with_additional_proposition {
  my ($self, $new_prop) = @_;
  my $old_prop_seq = $self->proposition_sequence;
  my $new_prop_seq = $old_prop_seq->with_additional_proposition($new_prop);
  my $old_ss = $self->search_process->current_search_state;
  my %seen;
  my $_munge; $_munge = sub {
    my ($ss) = @_;
    return $seen{$ss} ||= do {
      my %but = (
        decisions_taken => [
          map [ $_->[0], $_->[1]->$_munge ], @{$ss->decisions_taken}
        ]
      );
      if ($ss->propositions eq $old_prop_seq) {
        $but{propositions} = $new_prop_seq;
      }
      foreach my $type (qw(on_solution_step on_exhaustion_step)) {
        my $step = $ss->$type;
        if ($step and $step->can('resume_search_state')) {
          $but{$type}
            = $seen{$step}
            ||= $step->but(
                  resume_search_state => $step->resume_search_state->$_munge
                );
        }
      }
      if ((my $next_step = $ss->next_step)->can('original_search_state')) {
         $but{next_step}
           = $seen{$next_step}
           ||= $next_step->but(
                 original_search_state
                   => $next_step->original_search_state->$_munge
               );
      }
       
      $ss->but(%but);
    };
  };
  my $munged_ss = $old_ss->$_munge;
  undef($_munge);

  my $new_ss = $munged_ss->but(
    is_solution_state => 0,
    next_step => DX::Step::ConsiderProposition->new(
                   proposition => $new_prop
                 ),
  );

  my $sol_sp = $self->search_process
                    ->but(current_search_state => $new_ss)
                    ->find_solution;
  die "No solution\n" unless $sol_sp;
  $self->but(
    proposition_sequence => $new_prop_seq,
    search_process => $sol_sp,
  );
}

sub with_forced_backtrack {
  my ($self) = @_;
  my $next_ss = $self->search_process->find_next_solution;
  die "No next solution\n" unless $next_ss;
  $self->but(search_process => $next_ss);
}

1;