--- /dev/null
+package DX::Action::SetValue;
+
+use DX::Update::SetValue;
+use DX::Class;
+
+has target_path => (is => 'ro', required => 1);
+
+has new_value => (is => 'ro', required => 1);
+
+has _update => (is => 'lazy');
+
+sub dry_run {
+ my ($self, $hyp) = @_;
+ my ($scope, @events) = $self->_update->apply_to($hyp->scope);
+ return (
+ $hyp->but(
+ actions => [ @{$hyp->actions}, $self ],
+ scope => $scope
+ ),
+ @events,
+ );
+}
+
+sub _build__update {
+ my ($self) = @_;
+ DX::Update::SetValue->new(
+ target_path => $self->target_path,
+ new_value => $self->new_value,
+ );
+}
+
+1;
--- /dev/null
+package DX::ActionBuilder::Normal;
+
+use DX::Class;
+
+with 'DX::Role::ActionBuilder';
+
+has target_path => (is => 'ro', required => 1);
+
+sub action_for_set_value {
+ my ($self, $value) = @_;
+ DX::Action::SetValue->new(
+ target_path => $self->target_path,
+ new_value => $value->but_set_action_builder($self)
+ );
+}
+
+1;
--- /dev/null
+package DX::ActionBuilder::UnsetValue;
+
+use DX::Action::SetValue;
+use DX::ActionBuilder::Normal;
+use DX::Class;
+
+with 'DX::Role::ActionBuilder';
+
+has target_path => (is => 'ro', required => 1);
+
+sub action_for_set_value {
+ my ($self, $value) = @_;
+ if (0) { # value_path / identity_path test
+ # bind value
+ }
+ my $ab = DX::ActionBuilder::Normal->new(
+ target_path => $self->target_path,
+ );
+ DX::Action::SetValue->new(
+ target_path => $self->target_path,
+ new_value => $value->but_set_action_builder($ab),
+ );
+}
+
+1;
--- /dev/null
+package DX::DependencyMap;
+
+use DX::Utils qw(CONTENTS_OF INDICES_OF);
+use Moo;
+
+# { x => [ { y => [ ...
+# my $targ = $root; $targ = $targ->[0]{$_[0]} for @path
+# my $deps = $targ->[$${$dep_type}];
+
+has deps => (is => 'ro', required => 1);
+
+has revdeps => (is => 'ro', required => 1);
+
+sub new_empty {
+ my ($class) = @_;
+ $class->new(deps => {}, revdeps => {});
+}
+
+sub with_entry_for {
+ my ($self, $for_id, $deps_for) = @_;
+ my @expanded = $self->_expand_deps($deps_for);
+ my $new_revdeps = {
+ %{$self->revdeps},
+ $for_id => \@expanded,
+ };
+ my $new_deps = $self->_merge_deps_for($self->deps, $for_id, @expanded);
+ ref($self)->new(
+ deps => $new_deps,
+ revdeps => $new_revdeps
+ );
+}
+
+sub without_entries_for {
+ my ($self, @for_ids) = @_;
+ my %new_revdeps = %{$self->revdeps};
+ my $new_deps = $self->deps;
+ $new_deps = $self->_unmerge_deps_for(
+ $new_deps, $_, @{$new_revdeps{$_}}
+ ) for @for_ids;
+ delete @new_revdeps{@for_ids};
+ ref($self)->new(
+ deps => $new_deps,
+ revdeps => \%new_revdeps
+ );
+}
+
+sub _merge_deps_for {
+ my ($self, $deps, $for_id, @merge_these) = @_;
+ $self->_mangle_deps($deps, sub {
+ +{ %{$_[0]}, $for_id => 1 };
+ }, @merge_these);
+}
+
+sub _unmerge_deps_for {
+ my ($self, $deps, $for_id, @unmerge_these) = @_;
+ $self->_mangle_deps($deps, sub {
+ my %for_ids = %{$_[0]};
+ delete $for_ids{$for_id};
+ \%for_ids;
+ }, @unmerge_these);
+}
+
+sub _mangle_deps {
+ my ($self, $deps, $mangler, @to_mangle) = @_;
+ my $root = [ $deps ];
+ foreach my $mangle_this (@to_mangle) {
+ my ($type, @path) = @$mangle_this;
+ my $targ = $root;
+ foreach my $part (@path) {
+ my $sub = $targ->[0] = { %{$targ->[0]||{}} };
+ $targ = $sub->{$part} = [ @{$sub->{$part}||[]} ];
+ }
+ $targ->[$$$type] = $mangler->($targ->[$$$type]||{});
+ }
+ return $root->[0];
+}
+
+sub _expand_deps {
+ my ($self, $deps) = @_;
+ my @exp;
+ DEP: foreach my $dep (@$deps) {
+ my ($type, @path) = @$dep;
+ push @exp, [
+ $type,
+ map { ref() ? @{$_->identity_path or next DEP} : $_ } @path
+ ];
+ }
+ return @exp;
+}
+
+sub _dependents_of {
+ my ($self, $event) = @_;
+ my ($type, @path) = @$event;
+ my $root = [ $self->deps ];
+ my $targ = $root;
+ my $last = pop @path;
+ my @dep_sets;
+ foreach my $part (@path) {
+ $targ = $targ->[0]{$part};
+ # set/add/remove x.y or x.y.z affects contents of x
+ push @dep_sets, $targ->[$${+CONTENTS_OF}];
+ }
+ if ($$$type) {
+ # add/remove x.y affects indices of x
+ push @dep_sets, $targ->[$${+INDICES_OF}];
+ }
+ $targ = $targ->[0]{$last};
+ {
+ # add/remove x affects existence of x
+ # set/add/remove x affects everything else too
+ push @dep_sets, @{$targ}[map $$$_, @$$type];
+ }
+ # set/add/remove x affects all dependencies on x.y, x.y.z etc.
+ my @q = values %{$targ->[0]};
+ while (my $el = shift @q) {
+ my ($el_kids, @el_deps) = @$el;
+ push @dep_sets, @el_deps;
+ push @q, values %{$el_kids||{}};
+ }
+ return keys %{{
+ map +($_ => 1), map keys %$_, grep defined, @dep_sets
+ }};
+}
+
+sub but_expire_dependents_of {
+ my ($self, @events) = @_;
+ my @expired = keys %{{
+ map +($_ => 1), map $self->_dependents_of($_), @events
+ }};
+ # Didn't expire anything? Don't clone self
+ return $self unless @expired;
+ ($self->without_entries_for(@expired), @expired);
+}
+
+1;
has actions => (is => 'ro', required => 1);
+sub head_proposition { shift->outstanding_propositions->[0] }
+
sub with_actions {
my ($self, @actions) = @_;
my $hyp = $self;
foreach my $act (@actions) {
- ($hyp, my @events) = $act->dry_run_against($hyp);
+ ($hyp, my @events) = $act->dry_run($hyp);
return undef unless $hyp;
$hyp = $hyp->but_recheck_for(@events);
return undef unless $hyp;
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,
+ ->with_resolution_for(
+ $first,
+ $depends,
),
- outstanding_propositons => \@rest,
+ outstanding_propositions => \@rest,
);
}
--- /dev/null
+package DX::Predicate::IsDict;
+
+use DX::Utils qw(step dict TYPE_OF);
+use DX::Class;
+
+with 'DX::Role::Predicate';
+
+sub _possible_resolution_list {
+ my ($self, $arg) = @_;
+ if ($arg->is_set) {
+ die "is_dict called with non-dict"
+ unless $arg->isa('DX::Value::Dict');
+ return step(
+ actions => [],
+ depends_on => [ [ TYPE_OF ,=> $arg ] ]
+ );
+ }
+ my $set = $arg->action_for_set_value(dict());
+ return step(
+ actions => [ $set ],
+ depends_on => [ [ TYPE_OF ,=> $arg ] ]
+ );
+}
+
+1;
package DX::Predicate::MemberAt;
-use DX::Utils qw(step INDICES INDEX_EXISTS);
+use DX::Utils qw(step INDICES_OF EXISTENCE_OF);
use DX::Class;
with 'DX::Role::Predicate';
return (
($key->is_set
? map $_->but_with_dependencies_on(
- [ undef ,=> [ $coll, INDEX_EXISTS ,=> $key ], $key ]
+ [ undef ,=> [ $coll, EXISTENCE_OF ,=> $key ], $key ]
), do {
if (my $cur_val = $coll->get_member_at($key)) {
$self->_make_equal($cur_val, $value);
my $set_key = $key->action_for_set_value($_);
map $_->but_first($set_key)
->but_with_dependencies_on(
- [ undef ,=> [ $coll, INDEX_EXISTS ,=> $key ] ]
+ [ undef ,=> [ $coll, EXISTENCE_OF ,=> $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)) ],
+ [ [ $coll => ($key->can_set_value ? INDICES_OF : (EXISTENCE_OF ,=> $key)) ],
$key,
$value,
]
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;
- }
+ #if (my $step = $scope->known_facts->resolution_step_for($predicate, @args)) {
+ # return $step;
+ #}
return $predicate->resolution_step_for(@args);
}
--- /dev/null
+package DX::ResolvedPropositionSet;
+
+use DX::DependencyMap;
+use Moo;
+
+has dependency_map => (is => 'ro', required => 1);
+
+has propositions => (is => 'ro', required => 1);
+
+has scope_depth => (is => 'ro', required => 1);
+
+sub new_empty {
+ my ($class) = @_;
+ $class->new(
+ propositions => [],
+ dependency_map => DX::DependencyMap->new_empty,
+ scope_depth => 0,
+ );
+}
+
+sub with_resolution_for {
+ my ($self, $prop, $deps) = @_;
+ my $id = my @already = @{$self->propositions};
+ my $new_depmap = $self->dependency_map
+ ->with_entry_for($id, $deps);
+ ref($self)->new(
+ dependency_map => $new_depmap,
+ propositions => [ @already, $prop ],
+ scope_depth => $self->scope_depth,
+ );
+}
+
+sub with_updated_dependencies_for {
+ my ($self, $prop, $deps) = @_;
+ my @props = @{$self->propositions};
+ my ($id) = grep $props[$_] eq $prop, 0..$#props;
+ die "WHUT" unless $id;
+ my $new_depmap = $self->dependency_map
+ ->with_entry_for($id, $deps);
+ ref($self)->new(
+ dependency_map => $new_depmap,
+ propositions => \@props,
+ scope_depth => $self->scope_depth,
+ );
+}
+
+sub but_expire_for {
+ my ($self, @events) = @_;
+ my ($depmap, @expired_ids) = $self->dependency_map
+ ->but_expire_dependents_of(@events);
+ # Didn't expire anything? Don't clone self
+ return $self if $depmap eq $self->dependency_map;
+ die 'WHUT';
+}
+
+
+1;
sub _with_value_at_path {
my ($self, $scope, $final_value, @path) = @_;
+ return $final_value->($scope) unless @path;
my ($first, @rest) = @path;
- return $final_value->($scope) unless $first;
my $inner = $scope->get_member_at($first);
my $value = (
@rest
use DX::ActionBuilder::Null;
use DX::Role;
+has identity_path => (is => 'ro');
+
has action_builder => (
is => 'ro',
default => 'DX::ActionBuilder::Null',
sub is_set { 1 }
+sub but_set_action_builder {
+ my ($self, $ab) = @_;
+ $self->but(action_builder => $ab);
+}
+
1;
has locals => (is => 'ro', required => 1);
-has known_facts => (is => 'ro', required => 1);
+#has known_facts => (is => 'ro', required => 1);
sub lookup_predicate {
my ($self, $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";
+ return $lookup_in->get_member_at($name)
+ or die "No such name in scope: $name";
}
sub depth { $#{$_[0]->locals} }
my ($self, $at, $value) = @_;
if ($at =~ /^[0-9]+$/) {
my @locals = @{$self->locals};
- $locals[$at] = $at;
+ $locals[$at] = $value;
return $self->but(
locals => \@locals
);
STEP: while ($step) {
my ($new_hyp, $alt_step) = $step->apply_to($hyp);
if ($new_hyp) {
- return ref($self)->new(
+ return $self->but(
current_hypothesis => $new_hyp,
($alt_step
? (alternatives => [
package DX::Update::AddValue;
-use DX::Utils qw(INDICES INDEX_EXISTS);
+use DX::Utils qw(VALUE_EXISTS);
use DX::Class;
with 'DX::Role::Update';
sub apply_to {
my ($self, $scope) = @-;
- my @path = @{$self->target_path};
+ my @path = my @whole_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 ],
+ [ VALUE_EXISTS ,=> @whole_path ],
);
}
package DX::Update::RemoveValue;
-use DX::Utils qw(INDICES INDEX_EXISTS);
+use DX::Utils qw(VALUE_EXISTS);
use DX::Class;
with 'DX::Role::Update';
sub apply_to {
my ($self, $scope) = @_;
- my @path = @{$self->target_path};
+ my @path = my @whole_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 ]
+ [ VALUE_EXISTS ,=> @whole_path ],
);
}
package DX::Update::SetValue;
+use DX::Utils qw(VALUE_SET);
use DX::Class;
with 'DX::Role::Update';
my $new_value = $self->new_value;
return (
$self->_with_value_at_path($scope, sub { $new_value }, @path),
- \@path
+ [ VALUE_SET ,=> @path ],
);
}
use strictures 2;
use Exporter 'import';
-our @EXPORT_OK = qw(INDICES INDEX_EXISTS ROOT_ONLY step string number);
+my @const = (
+ my @dep_types = qw(EXISTENCE_OF INDICES_OF TYPE_OF CONTENTS_OF),
+ my @ev_types = qw(VALUE_SET VALUE_EXISTS),
+);
-use constant INDICES => \*INDICES;
-use constant INDEX_EXISTS => \*INDEX_EXISTS;
-use constant ROOT_ONLY => \*ROOT_ONLY;
+our @EXPORT_OK = (
+ @const,
+ my @builders = qw(step string number dict proposition)
+);
+
+our %EXPORT_TAGS = (
+ all => \@EXPORT_OK,
+ dep_types => \@dep_types,
+ event_types => \@ev_types,
+ builders => \@builders,
+);
+
+require constant;
+
+# use constant INDICES_OF => \*INDICES_OF;
+
+constant->import(+{
+ map {; no strict 'refs'; $_ => \*$_ } @const
+});
+
+# $INDICES_OF = 1, ...
+
+do { no strict 'refs'; ${$dep_types[$_-1]} = $_ } for 1..@dep_types;
+
+# VALUE_EXISTS needs to trigger indices checks on its parent
+
+our $VALUE_EXISTS = 1;
+
+# VALUE_EXISTS triggers all types, VALUE_SET all but EXISTENCE_OF
+
+our @VALUE_EXISTS = (EXISTENCE_OF(), INDICES_OF(), TYPE_OF(), CONTENTS_OF());
+our @VALUE_SET = (INDICES_OF(), TYPE_OF(), CONTENTS_OF());
sub step {
DX::Step::Normal->new(@_);
DX::Value::Number->new(number_value => $_[0]);
}
+sub dict {
+ DX::Value::Dict->new(
+ members => { @_ },
+ );
+}
+
+sub proposition {
+ my ($pred, @args) = @_;
+ DX::Proposition->new(
+ predicate => $pred,
+ args => \@args,
+ );
+}
+
# Here so that circular require doesn't stab us in the face
require DX::Step::Normal;
require DX::Value::String;
require DX::Value::Number;
+require DX::Value::Dict;
+require DX::Proposition;
1;
sub get_member_at {
my ($self, $at) = @_;
- $self->members->{$at->string_value};
+ $self->members->{ref($at) ? $at->string_value : $at};
}
sub with_member_at {
my ($self, $at, $value) = @_;
$self->but(
- members => { %{$self->members}, $at->string_value => $value }
+ members => {
+ %{$self->members},
+ (ref($at) ? $at->string_value : $at) => $value
+ }
);
}
-Action::SetValue
- AddValue
+Action::AddValue
RemoveValue
BindValue
SetBoundValue
AddBoundValue
RemoveBoundValue
-ActionBuilder::Simple
- ::BoundValue
- ::UnsetValue
-KnownFactSet
-ResolvedPropositionSet
+ActionBuilder::BoundValue
+? KnownFactSet
+? KnownResolutionSet
Predicate::Foreach
Predicate::Findall
Predicate::Forall
--- /dev/null
+use strictures 1;
+use Test::More;
+use Module::Runtime qw(use_module);
+use DX::Utils qw(:builders);
+
+my $ab = use_module('DX::ActionBuilder::UnsetValue')->new(
+ target_path => [ 0, 'X' ]
+);
+
+my $scope = use_module('DX::Scope')->new(
+ predicates => {
+ '=' => use_module('DX::Predicate::Equals')->new,
+ member_at => use_module('DX::Predicate::MemberAt')->new,
+ is_dict => use_module('DX::Predicate::IsDict')->new,
+ },
+ globals => dict(),
+ locals => [
+ dict(
+ X => use_module('DX::Value::Unset')->new(
+ identity_path => [ 0, 'X' ],
+ action_builder => $ab,
+ ),
+ ),
+ ],
+);
+
+my $hyp = use_module('DX::Hypothesis')->new(
+ scope => $scope,
+ resolved_propositions => use_module('DX::ResolvedPropositionSet')->new_empty,
+ outstanding_propositions => [
+ proposition(is_dict => 'X'),
+ ],
+ actions => [],
+);
+
+my $ss = use_module('DX::SearchState')->new(
+ current_hypothesis => $hyp,
+ alternatives => [],
+);
+
+::Dwarn($ss->with_one_step);
--- /dev/null
+use strictures 2;
+use DX::Utils qw(:all);
+use DX::DependencyMap;
+use List::Util qw(reduce);
+use Test::More;
+
+my $start = DX::DependencyMap->new(deps => {}, revdeps => {});
+
+{
+
+ my @xyz = qw(x x.y x.z);
+
+ my $content = reduce {
+ $a->with_entry_for($b, [ [ CONTENTS_OF ,=> split(/\./,$b) ] ])
+ } $start, @xyz;
+
+ is(
+ (join ' ', sort $content->_dependents_of([ VALUE_SET ,=> qw(x y) ])),
+ 'x x.y',
+ 'x.y set clears contents_of x',
+ );
+ is(
+ (join ' ', sort $content->_dependents_of([ VALUE_SET ,=> qw(x) ])),
+ 'x x.y x.z',
+ 'x set clears contents_of all x.*',
+ );
+}
+
+done_testing;
projects / scpubgit/DX.git / commitdiff