From: Matt S Trout Date: Sun, 30 Aug 2015 21:18:23 +0000 (+0000) Subject: initial partial sketch X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9d759b646ac5953926ce9414388c1691b8a4278b;p=scpubgit%2FDX.git initial partial sketch --- diff --git a/lib/DX/ActionBuilder/Null.pm b/lib/DX/ActionBuilder/Null.pm new file mode 100644 index 0000000..c39cb46 --- /dev/null +++ b/lib/DX/ActionBuilder/Null.pm @@ -0,0 +1,19 @@ +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; diff --git a/lib/DX/Class.pm b/lib/DX/Class.pm new file mode 100644 index 0000000..730069a --- /dev/null +++ b/lib/DX/Class.pm @@ -0,0 +1,13 @@ +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; diff --git a/lib/DX/Hypothesis.pm b/lib/DX/Hypothesis.pm new file mode 100644 index 0000000..4c8c382 --- /dev/null +++ b/lib/DX/Hypothesis.pm @@ -0,0 +1,48 @@ +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; diff --git a/lib/DX/Predicate/Equals.pm b/lib/DX/Predicate/Equals.pm new file mode 100644 index 0000000..7aecff7 --- /dev/null +++ b/lib/DX/Predicate/Equals.pm @@ -0,0 +1,11 @@ +package DX::Predicate::Equals; + +use DX::Class; + +with 'DX::Role::Predicate'; + +sub _possible_resolution_list { + shift->_make_equal(@_) +} + +1; diff --git a/lib/DX/Predicate/MemberAt.pm b/lib/DX/Predicate/MemberAt.pm new file mode 100644 index 0000000..d000e01 --- /dev/null +++ b/lib/DX/Predicate/MemberAt.pm @@ -0,0 +1,62 @@ +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; diff --git a/lib/DX/Proposition.pm b/lib/DX/Proposition.pm new file mode 100644 index 0000000..8e1e538 --- /dev/null +++ b/lib/DX/Proposition.pm @@ -0,0 +1,19 @@ +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; diff --git a/lib/DX/Resolution.pm b/lib/DX/Resolution.pm new file mode 100644 index 0000000..f786f39 --- /dev/null +++ b/lib/DX/Resolution.pm @@ -0,0 +1,18 @@ +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; diff --git a/lib/DX/Role.pm b/lib/DX/Role.pm new file mode 100644 index 0000000..f662316 --- /dev/null +++ b/lib/DX/Role.pm @@ -0,0 +1,10 @@ +package DX::Role; + +use Import::Into; + +sub import { + strictures->import::into(1); + Moo::Role->import::into(1); +} + +1; diff --git a/lib/DX/Role/ActionBuilder.pm b/lib/DX/Role/ActionBuilder.pm new file mode 100644 index 0000000..0e0c531 --- /dev/null +++ b/lib/DX/Role/ActionBuilder.pm @@ -0,0 +1,9 @@ +package DX::Role::ActionBuilder; + +use DX::Role; + +sub can_set_value { 1 } + +requires 'action_for_set_value'; + +1; diff --git a/lib/DX/Role/BooleanValue.pm b/lib/DX/Role/BooleanValue.pm new file mode 100644 index 0000000..336e545 --- /dev/null +++ b/lib/DX/Role/BooleanValue.pm @@ -0,0 +1,9 @@ +package DX::Role::BooleanValue; + +use DX::Role; + +with 'DX::Role::Value'; + +requires 'is_true'; + +1; diff --git a/lib/DX/Role/But.pm b/lib/DX/Role/But.pm new file mode 100644 index 0000000..68a0e12 --- /dev/null +++ b/lib/DX/Role/But.pm @@ -0,0 +1,10 @@ +package DX::Role::But; + +use DX::Role; + +sub but { + my ($self, %but) = @_; + ref($self)->new(%$self, %but); +} + +1; diff --git a/lib/DX/Role/Predicate.pm b/lib/DX/Role/Predicate.pm new file mode 100644 index 0000000..ffd903a --- /dev/null +++ b/lib/DX/Role/Predicate.pm @@ -0,0 +1,53 @@ +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; diff --git a/lib/DX/Role/SimpleAction.pm b/lib/DX/Role/SimpleAction.pm new file mode 100644 index 0000000..dd76714 --- /dev/null +++ b/lib/DX/Role/SimpleAction.pm @@ -0,0 +1,23 @@ +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; diff --git a/lib/DX/Role/StructuredValue.pm b/lib/DX/Role/StructuredValue.pm new file mode 100644 index 0000000..60cdbac --- /dev/null +++ b/lib/DX/Role/StructuredValue.pm @@ -0,0 +1,7 @@ +package DX::Role::StructuredValue; + +use DX::Role; + +with 'DX::Role::Value'; + +1; diff --git a/lib/DX/Role/Update.pm b/lib/DX/Role/Update.pm new file mode 100644 index 0000000..a3eace0 --- /dev/null +++ b/lib/DX/Role/Update.pm @@ -0,0 +1,20 @@ +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; diff --git a/lib/DX/Role/Value.pm b/lib/DX/Role/Value.pm new file mode 100644 index 0000000..da75e82 --- /dev/null +++ b/lib/DX/Role/Value.pm @@ -0,0 +1,14 @@ +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; diff --git a/lib/DX/Scope.pm b/lib/DX/Scope.pm new file mode 100644 index 0000000..979efb8 --- /dev/null +++ b/lib/DX/Scope.pm @@ -0,0 +1,53 @@ +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; diff --git a/lib/DX/SearchState.pm b/lib/DX/SearchState.pm new file mode 100644 index 0000000..d97ab9b --- /dev/null +++ b/lib/DX/SearchState.pm @@ -0,0 +1,62 @@ +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; diff --git a/lib/DX/Step/Normal.pm b/lib/DX/Step/Normal.pm new file mode 100644 index 0000000..c7cfbeb --- /dev/null +++ b/lib/DX/Step/Normal.pm @@ -0,0 +1,27 @@ +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; diff --git a/lib/DX/Update/AddValue.pm b/lib/DX/Update/AddValue.pm new file mode 100644 index 0000000..81db27c --- /dev/null +++ b/lib/DX/Update/AddValue.pm @@ -0,0 +1,24 @@ +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; diff --git a/lib/DX/Update/RemoveValue.pm b/lib/DX/Update/RemoveValue.pm new file mode 100644 index 0000000..9aff310 --- /dev/null +++ b/lib/DX/Update/RemoveValue.pm @@ -0,0 +1,22 @@ +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; diff --git a/lib/DX/Update/SetValue.pm b/lib/DX/Update/SetValue.pm new file mode 100644 index 0000000..ff1e991 --- /dev/null +++ b/lib/DX/Update/SetValue.pm @@ -0,0 +1,19 @@ +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; diff --git a/lib/DX/Utils.pm b/lib/DX/Utils.pm new file mode 100644 index 0000000..ce166e3 --- /dev/null +++ b/lib/DX/Utils.pm @@ -0,0 +1,30 @@ +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; diff --git a/lib/DX/Value/Dict.pm b/lib/DX/Value/Dict.pm new file mode 100644 index 0000000..6d52aeb --- /dev/null +++ b/lib/DX/Value/Dict.pm @@ -0,0 +1,36 @@ +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; diff --git a/lib/DX/Value/False.pm b/lib/DX/Value/False.pm new file mode 100644 index 0000000..0412671 --- /dev/null +++ b/lib/DX/Value/False.pm @@ -0,0 +1,9 @@ +package DX::Value::False; + +use DX::Class; + +with 'DX::Role::BooleanValue'; + +sub is_true { 0 } + +1; diff --git a/lib/DX/Value/Number.pm b/lib/DX/Value/Number.pm new file mode 100644 index 0000000..6564205 --- /dev/null +++ b/lib/DX/Value/Number.pm @@ -0,0 +1,9 @@ +package DX::Value::Number; + +use DX::Class; + +with 'DX::Role::Value'; + +has number_value => (is => 'ro', required => 1); + +1; diff --git a/lib/DX/Value/String.pm b/lib/DX/Value/String.pm new file mode 100644 index 0000000..78c5f43 --- /dev/null +++ b/lib/DX/Value/String.pm @@ -0,0 +1,9 @@ +package DX::Value::String; + +use DX::Class; + +with 'DX::Role::Value'; + +has string_value => (is => 'ro', required => 1); + +1; diff --git a/lib/DX/Value/True.pm b/lib/DX/Value/True.pm new file mode 100644 index 0000000..df3f842 --- /dev/null +++ b/lib/DX/Value/True.pm @@ -0,0 +1,9 @@ +package DX::Value::True; + +use DX::Class; + +with 'DX::Role::BooleanValue'; + +sub is_true { 1 } + +1; diff --git a/lib/DX/Value/Unset.pm b/lib/DX/Value/Unset.pm new file mode 100644 index 0000000..a78f556 --- /dev/null +++ b/lib/DX/Value/Unset.pm @@ -0,0 +1,9 @@ +package DX::Value::Unset; + +use DX::Class; + +with 'DX::Role::Value'; + +sub is_set { 0 } + +1; diff --git a/need b/need new file mode 100644 index 0000000..e8fa218 --- /dev/null +++ b/need @@ -0,0 +1,20 @@ +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 diff --git a/t/00load_all.t b/t/00load_all.t new file mode 100644 index 0000000..8e76c2d --- /dev/null +++ b/t/00load_all.t @@ -0,0 +1,11 @@ +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;