pervasive type constraints

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

diff --git a/lib/DX/QueryState.pm b/lib/DX/QueryState.pm
index 857745d..b378783 100644 (file)
--- a/lib/DX/QueryState.pm
+++ b/lib/DX/QueryState.pm
@@ -1,6 +1,13 @@
 package DX::QueryState;
 
-use Types::Standard qw(HashRef);
+use DX::Scope;
+use DX::Hypothesis;
+use DX::SearchProcess;
+use DX::ResolvedPropositionSet;
+use DX::Value::Unset;
+use DX::ActionBuilder::UnsetValue;
+use DX::ActionPolicy::Allow;
+use DX::Utils qw(:builders);
 use DX::Class;
 
 has predicates => (is => 'ro', isa => HashRef[Predicate], required => 1);
@@ -11,4 +18,61 @@ has proposition_sequence => (
   is => 'ro', isa => PropositionSequence, required => 1
 );
 
+has search_state => (
+  is => 'lazy', builder => sub {
+    $_[0]->new_search_state_for($_[0]->proposition_sequence)
+  },
+);
+
+sub new_search_state_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(
+        map +($_ => DX::Value::Unset->new(
+                      action_builder => DX::ActionBuilder::UnsetValue->new(
+                        target_path => [ 0, $_ ],
+                      )
+                    )
+        ), @local_names
+      )
+    ],
+    lex_map => {
+      map +($_ => [ 0, $_ ]), @local_names
+    }
+  );
+  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, $prop) = @_;
+  my $prop_seq = $self->proposition_sequence
+                      ->with_additional_proposition($prop);
+  my $sol_ss = $self->new_search_state_for($prop_seq)
+                    ->find_solution;
+  die "No solution\n" unless $sol_ss;
+  $self->but(
+    proposition_sequence => $prop_seq,
+    search_state => $sol_ss,
+  );
+}
+
+sub with_forced_backtrack {
+  my ($self) = @_;
+  my $next_ss = $self->search_state->find_next_solution;
+  die "No next solution\n" unless $next_ss;
+  $self->but(search_state => $next_ss);
+}
+
 1;