--- /dev/null
+package DX::ActionBuilder::Null;
+
+use DX::Class;
+
+with 'DX::Role::ActionBuilder';
+
+sub can_set_value { 0 }
+
+sub action_for_set_value { undef }
+
+sub action_for_add_member { undef }
+
+sub action_for_set_member { undef }
+
+sub action_for_remove_member { undef }
+
+sub specialize_for_member { $_[0] }
+
+1;
--- /dev/null
+package DX::Class;
+
+use Import::Into;
+
+sub import {
+ strictures->import::into(1); # should pass version
+ Moo->import::into(1);
+ # This would not be safe with method modifiers, but since the role
+ # provides only a single method it works out fine.
+ caller()->can('with')->('DX::Role::But');
+}
+
+1;
--- /dev/null
+package DX::Hypothesis;
+
+use DX::Class;
+
+has scope => (is => 'ro', required => 1);
+
+has resolved_propositions => (is => 'ro', required => 1);
+
+has outstanding_propositions => (is => 'ro', required => 1);
+
+has actions => (is => 'ro', required => 1);
+
+sub with_actions {
+ my ($self, @actions) = @_;
+ my $hyp = $self;
+ foreach my $act (@actions) {
+ ($hyp, my @events) = $act->dry_run_against($hyp);
+ return undef unless $hyp;
+ $hyp = $hyp->but_recheck_for(@events);
+ return undef unless $hyp;
+ }
+ return $hyp;
+}
+
+sub but_recheck_for {
+ my ($self, @events) = @_;
+ my ($still_resolved, @recheck) = $self->resolved_propositions
+ ->but_expire_for(@events);
+ my $hyp = $self->but(resolved_propositions => $still_resolved);
+ $hyp = $_->but_recheck_against($hyp) or return undef for @recheck;
+ return $hyp;
+}
+
+sub resolve_head_dependent_on {
+ my ($self, $depends) = @_;
+ my ($first, @rest) = @{$self->outstanding_propositions};
+ $self->but(
+ resolved_propositions => $self->resolved_propositions
+ ->but_with_resolution(
+ proposition => $first,
+ depends_on => $depends,
+ at_depth => $self->scope->depth,
+ ),
+ outstanding_propositons => \@rest,
+ );
+}
+
+1;
--- /dev/null
+package DX::Predicate::Equals;
+
+use DX::Class;
+
+with 'DX::Role::Predicate';
+
+sub _possible_resolution_list {
+ shift->_make_equal(@_)
+}
+
+1;
--- /dev/null
+package DX::Predicate::MemberAt;
+
+use DX::Utils qw(step INDICES INDEX_EXISTS);
+use DX::Class;
+
+with 'DX::Role::Predicate';
+
+# Thing I've ignored for the moment: set key, unset value
+# which for an add should result in an _make_equal style
+# bind-with-add-action I suspect, but I don't have a current use
+# case so punting while I get everything-the-fuck-else done
+
+sub _possible_resolution_list {
+ my ($self, $coll, $key, $value) = @_;
+ die "First argument to member_at must be a structured value"
+ unless $coll->does('DX::Role::StructuredValue');
+ return (
+ ($key->is_set
+ ? map $_->but_with_dependencies_on(
+ [ undef ,=> [ $coll, INDEX_EXISTS ,=> $key ], $key ]
+ ), do {
+ if (my $cur_val = $coll->get_member_at($key)) {
+ $self->_make_equal($cur_val, $value);
+ } elsif (
+ $value->is_set
+ and my $add = $coll->action_for_add_value($key, $value)
+ ) {
+ step(
+ actions => [ $add ],
+ depends_on => [
+ [ $coll => [ $coll, $key ], $value ]
+ ],
+ );
+ } else {
+ ()
+ }
+ }
+ : ()
+ ),
+ ($key->can_set_value
+ ? map {
+ my $set_key = $key->action_for_set_value($_);
+ map $_->but_first($set_key)
+ ->but_with_dependencies_on(
+ [ undef ,=> [ $coll, INDEX_EXISTS ,=> $key ] ]
+ ),
+ $self->_make_equal($coll->get_member_at($_), $value);
+ } $coll->index_list
+ : ()
+ ),
+ );
+}
+
+sub selection_depends_on {
+ my ($self, $coll, $key, $value) = @_;
+ [ [ $coll => ($key->can_set_value ? INDICES : (INDEX_EXISTS ,=> $key)) ],
+ $key,
+ $value,
+ ]
+}
+
+1;
--- /dev/null
+package DX::Proposition;
+
+use DX::Class;
+
+has predicate => (is => 'ro', required => 1);
+
+has args => (is => 'ro', required => 1);
+
+sub resolve_for {
+ my ($self, $scope) = @_;
+ my $predicate = $scope->lookup_predicate($self->predicate);
+ my @args = map { ref($_) ? $_ : $scope->lookup($_) } @{$self->args};
+ if (my $step = $scope->known_facts->resolution_step_for($predicate, @args)) {
+ return $step;
+ }
+ return $predicate->resolution_step_for(@args);
+}
+
+1;
--- /dev/null
+package DX::Resolution;
+
+use DX::Class;
+
+has proposition => (is => 'ro', required => 1);
+
+has dependencies => (is => 'ro', required => 1);
+
+has scope_depth => (is => 'ro', required => 1);
+
+sub but_recheck_against {
+ my ($self, $hyp) = @_;
+ my $scope_hyp = $hyp->but(
+ scope => $hyp->scope->prune_to($self->scope_depth)
+ );
+}
+
+1;
--- /dev/null
+package DX::Role;
+
+use Import::Into;
+
+sub import {
+ strictures->import::into(1);
+ Moo::Role->import::into(1);
+}
+
+1;
--- /dev/null
+package DX::Role::ActionBuilder;
+
+use DX::Role;
+
+sub can_set_value { 1 }
+
+requires 'action_for_set_value';
+
+1;
--- /dev/null
+package DX::Role::BooleanValue;
+
+use DX::Role;
+
+with 'DX::Role::Value';
+
+requires 'is_true';
+
+1;
--- /dev/null
+package DX::Role::But;
+
+use DX::Role;
+
+sub but {
+ my ($self, %but) = @_;
+ ref($self)->new(%$self, %but);
+}
+
+1;
--- /dev/null
+package DX::Role::Predicate;
+
+use List::Util qw(reduce);
+use DX::Utils qw(step);
+use DX::Role;
+
+sub resolution_step_for {
+ my ($self, @args) = @_;
+ my ($last, @rest) = reverse $self->_possible_resolution_list(@args);
+ return undef unless $last;
+ my $targ = $last;
+ $targ = $_->but_with_alternative_step($targ) for @rest;
+ return $targ;
+}
+
+sub _make_equal {
+ my ($self, $left, $right) = @_;
+ if ($left->equals($right)) {
+ return step(
+ actions => [],
+ depends_on => [ $left, $right ],
+ );
+ }
+ return (
+ do {
+ if ($left->is_set and my $set = $right->action_for_set_value($left)) {
+ step(
+ actions => [ $set ],
+ depends_on => [ [ $right => [ $left, $right ] ] ],
+ )
+ } else {
+ ()
+ }
+ },
+ do {
+ if ($right->is_set and my $set = $left->action_for_set_value($right)) {
+ step(
+ actions => [ $set ],
+ depends_on => [ [ $left => [ $left, $right ] ] ],
+ )
+ } else {
+ ()
+ }
+ },
+ );
+}
+
+sub selection_depends_on {
+ my ($self, @args) = @_;
+ \@args;
+}
+
+1;
--- /dev/null
+package DX::Role::SimpleAction;
+
+use DX::Role;
+
+has updates => (is => 'lazy');
+
+requires '_build_updates';
+
+sub dry_run_against {
+ my ($self, $hyp) = @_;
+ my ($scope, @events) = $hyp->scope->apply_updates($self->updates);
+ return (
+ $hyp->but(
+ scope => $scope,
+ actions => [ @{$hyp->actions}, $self ],
+ ),
+ @events
+ );
+}
+
+sub run { shift->updates }
+
+1;
--- /dev/null
+package DX::Role::StructuredValue;
+
+use DX::Role;
+
+with 'DX::Role::Value';
+
+1;
--- /dev/null
+package DX::Role::Update;
+
+use DX::Role;
+
+has target_path => (is => 'ro', required => 1);
+
+sub _with_value_at_path {
+ my ($self, $scope, $final_value, @path) = @_;
+ my ($first, @rest) = @path;
+ return $final_value->($scope) unless $first;
+ my $inner = $scope->get_member_at($first);
+ my $value = (
+ @rest
+ ? $self->_with_value_at_path($inner, $final_value, @rest)
+ : $final_value->($inner)
+ );
+ $scope->with_member_at($first, $value);
+}
+
+1;
--- /dev/null
+package DX::Role::Value;
+
+use DX::ActionBuilder::Null;
+use DX::Role;
+
+has action_builder => (
+ is => 'ro',
+ default => 'DX::ActionBuilder::Null',
+ handles => [ qw(can_set_value action_for_set_value) ],
+);
+
+sub is_set { 1 }
+
+1;
--- /dev/null
+package DX::Scope;
+
+use DX::Class;
+
+has predicates => (is => 'ro', required => 1);
+
+has globals => (is => 'ro', required => 1);
+
+has locals => (is => 'ro', required => 1);
+
+has known_facts => (is => 'ro', required => 1);
+
+sub lookup_predicate {
+ my ($self, $predicate) = @_;
+ return $self->predicates->{$predicate} || die "No such predicate: $predicate";
+}
+
+sub lookup {
+ my ($self, $name) = @_;
+ my $lookup_in = ($name =~ /^[_A-Z]/ ? $self->locals->[-1] : $self->globals);
+ return $lookup_in->get_member_at($name) || die "No such name in scope: $name";
+}
+
+sub depth { $#{$_[0]->locals} }
+
+sub prune_to {
+ my ($self, $to) = @_;
+ $self->but(locals => [ @{$self->locals}[0..$to] ]);
+}
+
+sub get_member_at {
+ my ($self, $at) = @_;
+ if ($at =~ /^[0-9]+$/) {
+ return $self->locals->[$at];
+ }
+ return $self->globals->get_member_at($at);
+}
+
+sub with_member_at {
+ my ($self, $at, $value) = @_;
+ if ($at =~ /^[0-9]+$/) {
+ my @locals = @{$self->locals};
+ $locals[$at] = $at;
+ return $self->but(
+ locals => \@locals
+ );
+ }
+ return $self->but(
+ globals => $self->globals->with_member_at($at, $value)
+ );
+}
+
+1;
--- /dev/null
+package DX::SearchState;
+
+use DX::Class;
+
+has current_hypothesis => (is => 'ro', required => 1);
+
+has resume_step => (is => 'ro');
+
+has alternatives => (is => 'ro', required => 1);
+
+sub with_one_step {
+ my ($self) = @_;
+ my $hyp = $self->current_hypothesis;
+ my $step = $self->resume_step
+ || $hyp->head_proposition->resolve_for($hyp->scope);
+ my @alt = @{$self->alternatives};
+ HYP: while ($hyp) {
+ STEP: while ($step) {
+ my ($new_hyp, $alt_step) = $step->apply_to($hyp);
+ if ($new_hyp) {
+ return ref($self)->new(
+ current_hypothesis => $new_hyp,
+ ($alt_step
+ ? (alternatives => [
+ [ $hyp, $alt_step ],
+ @alt
+ ])
+ : ())
+ );
+ }
+ $step = $alt_step;
+ }
+ ($hyp, $step) = @{shift(@alt)||[]};
+ }
+ return undef;
+}
+
+sub find_solution {
+ my $state = $_[0];
+ while ($state and @{$state->current_hypothesis->outstanding_propositions}) {
+ $state = $state->with_one_step;
+ }
+ return $state;
+}
+
+sub force_backtrack {
+ my ($self) = @_;
+ my ($first_alt, @rest_alt) = $self->alternatives;
+ return ref($self)->new(
+ current_hypothesis => $first_alt->[0],
+ resume_step => $first_alt->[1],
+ alternatives => \@rest_alt
+ );
+}
+
+sub find_next_solution {
+ my ($self) = @_;
+ return undef unless my $bt = $self->force_backtrack;
+ return $bt->find_solution;
+}
+
+1;
--- /dev/null
+package DX::Step::Normal;
+
+use DX::Class;
+
+has actions => (is => 'ro', required => 1);
+
+has depends_on => (is => 'ro', required => 1);
+
+has alternative_step => (is => 'ro');
+
+sub but_with_alternative_step {
+ my ($self, $step) = @_;
+ bless { %$self, alternative_step => $step }, ref($self);
+}
+
+sub apply_to {
+ my ($self, $old_hyp) = @_;
+ return ($self->_apply_to_hyp($old_hyp), $self->alternative_step);
+}
+
+sub _apply_to_hyp {
+ my ($self, $old_hyp) = @_;
+ return undef unless my $hyp = $old_hyp->with_actions(@{$self->actions});
+ return $hyp->resolve_head_dependent_on($self->depends_on);
+}
+
+1;
--- /dev/null
+package DX::Update::AddValue;
+
+use DX::Utils qw(INDICES INDEX_EXISTS);
+use DX::Class;
+
+with 'DX::Role::Update';
+
+has new_value => (is => 'ro', required => 1);
+
+sub apply_to {
+ my ($self, $scope) = @-;
+ my @path = @{$self->target_path};
+ my $target = pop @path;
+ my $new_value = $self->new_value;
+ return (
+ $self->_with_value_at_path(
+ $scope, sub { $_[0]->with_member_at($target, $new_value) }, @path
+ ),
+ [ @path, INDICES ],
+ [ @path, INDEX_EXISTS ,=> $target ],
+ );
+}
+
+1;
--- /dev/null
+package DX::Update::RemoveValue;
+
+use DX::Utils qw(INDICES INDEX_EXISTS);
+use DX::Class;
+
+with 'DX::Role::Update';
+
+sub apply_to {
+ my ($self, $scope) = @_;
+ my @path = @{$self->target_path};
+ my $target = pop @path;
+ return (
+ $self->_with_value_at_path(
+ $scope, sub { $_[0]->without_member_at($target) }, @path
+ ),
+ [ @path, $target ],
+ [ @path, INDICES ],
+ [ @path, INDEX_EXISTS ,=> $target ]
+ );
+}
+
+1;
--- /dev/null
+package DX::Update::SetValue;
+
+use DX::Class;
+
+with 'DX::Role::Update';
+
+has new_value => (is => 'ro', required => 1);
+
+sub apply_to {
+ my ($self, $scope) = @_;
+ my @path = @{$self->target_path};
+ my $new_value = $self->new_value;
+ return (
+ $self->_with_value_at_path($scope, sub { $new_value }, @path),
+ \@path
+ );
+}
+
+1;
--- /dev/null
+package DX::Utils;
+
+use strictures 2;
+use Exporter 'import';
+
+our @EXPORT_OK = qw(INDICES INDEX_EXISTS ROOT_ONLY step string number);
+
+use constant INDICES => \*INDICES;
+use constant INDEX_EXISTS => \*INDEX_EXISTS;
+use constant ROOT_ONLY => \*ROOT_ONLY;
+
+sub step {
+ DX::Step::Normal->new(@_);
+}
+
+sub string {
+ DX::Value::String->new(string_value => $_[0])
+}
+
+sub number {
+ DX::Value::Number->new(number_value => $_[0]);
+}
+
+# Here so that circular require doesn't stab us in the face
+
+require DX::Step::Normal;
+require DX::Value::String;
+require DX::Value::Number;
+
+1;
--- /dev/null
+package DX::Value::Dict;
+
+use DX::Utils qw(string);
+use DX::Class;
+
+with 'DX::Role::StructuredValue';
+
+has '+action_builder' => (
+ handles => [ qw(
+ can_set_value action_for_set_value
+ action_for_add_member action_for_set_member action_for_remove_member
+ ) ]
+);
+
+has members => (is => 'ro', required => 1);
+
+sub get_member_at {
+ my ($self, $at) = @_;
+ $self->members->{$at->string_value};
+}
+
+sub with_member_at {
+ my ($self, $at, $value) = @_;
+ $self->but(
+ members => { %{$self->members}, $at->string_value => $value }
+ );
+}
+
+sub without_member_at {
+ my ($self, $at) = @_;
+ my %members = %{$self->members};
+ delete $members{$at};
+ $self->but(members => \%members);
+}
+
+1;
--- /dev/null
+package DX::Value::False;
+
+use DX::Class;
+
+with 'DX::Role::BooleanValue';
+
+sub is_true { 0 }
+
+1;
--- /dev/null
+package DX::Value::Number;
+
+use DX::Class;
+
+with 'DX::Role::Value';
+
+has number_value => (is => 'ro', required => 1);
+
+1;
--- /dev/null
+package DX::Value::String;
+
+use DX::Class;
+
+with 'DX::Role::Value';
+
+has string_value => (is => 'ro', required => 1);
+
+1;
--- /dev/null
+package DX::Value::True;
+
+use DX::Class;
+
+with 'DX::Role::BooleanValue';
+
+sub is_true { 1 }
+
+1;
--- /dev/null
+package DX::Value::Unset;
+
+use DX::Class;
+
+with 'DX::Role::Value';
+
+sub is_set { 0 }
+
+1;
--- /dev/null
+Action::SetValue
+ AddValue
+ RemoveValue
+ BindValue
+ SetBoundValue
+ AddBoundValue
+ RemoveBoundValue
+ActionBuilder::Simple
+ ::BoundValue
+ ::UnsetValue
+KnownFactSet
+ResolvedPropositionSet
+Predicate::Foreach
+Predicate::Findall
+Predicate::Forall
+Predicate::Rule
+Predicate::Not
+Step::SubSolve
+Solution
+Endjinn
--- /dev/null
+use strictures 1;
+use Test::More;
+use IO::All;
+
+foreach my $file (io('lib')->all_files(0)) {
+ (my $name = $file->name) =~ s/^lib\///;
+ ok(eval { require $name; 1 }, "${file} loaded ok");
+ warn $@ if $@;
+}
+
+done_testing;
projects / scpubgit/DX.git / commitdiff