--- /dev/null
+package DX::ActionPolicy::Allow;
+
+use DX::Class;
+
+with 'DX::Role::ActionPolicy';
+
+sub allows { 1 }
+
+1;
--- /dev/null
+package DX::ActionPolicy::LockScope;
+
+use DX::Class;
+
+with 'DX::Role::ActionPolicy';
+
+has lock_to_depth => (is => 'ro', required => 1);
+
+has next_policy => (is => 'ro', required => 1);
+
+sub allows {
+ my ($self, $action) = @_;
+ my $first = $action->target_path->[0];
+ return 0 unless $first =~ /^(\d+)$/ and $first > $self->lock_to_depth;
+ return $self->next_policy->allows($action);
+}
+
+1;
sub import {
strictures->import::into(1); # should pass version
+ DX::Types->import::into(1, ':types', ':assert');
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.
package DX::DependencyMap;
use DX::Utils qw(CONTENTS_OF INDICES_OF);
-use Moo;
+use DX::Class;
# { x => [ { y => [ ...
# my $targ = $root; $targ = $targ->[0]{$_[0]} for @path
# my $deps = $targ->[$${$dep_type}];
-has deps => (is => 'ro', required => 1);
+has deps => (is => 'ro', isa => DependencyTree, required => 1);
has revdeps => (is => 'ro', required => 1);
my ($self, $deps, $mangler, @to_mangle) = @_;
my $root = [ $deps ];
foreach my $mangle_this (@to_mangle) {
+ assert_DependencySpec $mangle_this;
my ($type, @path) = @$mangle_this;
my $targ = $root;
foreach my $part (@path) {
sub _expand_deps {
my ($self, $deps) = @_;
my @exp;
+ assert_DependencyGroupList $deps;
DEP: foreach my $dep (map @{$_}[1..$#$_], @$deps) {
my ($type, @path) = @$dep;
push @exp, [
($self->without_entries_for(@expired), @expired);
}
+sub dependencies_for { $_[0]->revdeps->{$_[1]} }
+
1;
package DX::Hypothesis;
+use DX::ActionPolicy::LockScope;
+use Types::Standard qw(ArrayRef);
use DX::Class;
-has scope => (is => 'ro', required => 1);
+has scope => (is => 'ro', isa => Scope, required => 1);
-has resolved_propositions => (is => 'ro', required => 1);
+has resolved_propositions => (
+ is => 'ro', isa => ResolvedPropositionSet, required => 1
+);
-has outstanding_propositions => (is => 'ro', required => 1);
+has outstanding_propositions => (
+ is => 'ro', isa => ArrayRef[Proposition], required => 1
+);
-has actions => (is => 'ro', required => 1);
+has actions => (
+ is => 'ro', isa => ArrayRef[Action], required => 1
+);
+
+has action_policy => (is => 'ro', isa => ActionPolicy, required => 1);
sub head_proposition { shift->outstanding_propositions->[0] }
my ($self, @actions) = @_;
my $hyp = $self;
foreach my $act (@actions) {
+ return undef unless $self->action_policy->allows($act);
($hyp, my @events) = $act->dry_run($hyp);
return undef unless $hyp;
$hyp = $hyp->but_recheck_for(@events);
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;
+ return $self unless @recheck;
+
+ my $ap = DX::ActionPolicy::LockScope->new(
+ lock_to_depth => $self->scope->depth,
+ next_policy => $self->action_policy,
+ );
+
+ # we should probably be doing something about pruning the scope
+ # but that's completely pointless until we have rules
+
+ my $hyp = ref($self)->new(
+ scope => $self->scope,
+ resolved_propositions => DX::ResolvedPropositionSet->new_empty,
+ outstanding_propositions => \@recheck,
+ actions => [],
+ action_policy => $ap,
+ );
+
+ my $ss = DX::SearchState->new_for($hyp);
+
+ return undef unless my $sol_ss = $ss->find_solution;
+
+ my $sol_rps = $sol_ss->current_hypothesis->resolved_propositions;
+
+ my $rps = $still_resolved;
+
+ $rps = $rps->with_updated_dependencies_for(
+ $_, $sol_rps->dependencies_for($_)
+ ) for @recheck;
+
+ return $self->but(resolved_propositions => $rps);
}
sub resolve_head_dependent_on {
package DX::ResolvedPropositionSet;
use DX::DependencyMap;
-use Moo;
+use Types::Standard qw(ArrayRef);
+use DX::Class;
-has dependency_map => (is => 'ro', required => 1);
+has dependency_map => (is => 'ro', isa => DependencyMap, required => 1);
-has propositions => (is => 'ro', required => 1);
+has propositions => (is => 'ro', isa => ArrayRef[Proposition], required => 1);
has scope_depth => (is => 'ro', required => 1);
my ($self, $prop, $deps) = @_;
my @props = @{$self->propositions};
my ($id) = grep $props[$_] eq $prop, 0..$#props;
- die "WHUT" unless $id;
+ # 0 is valid, undef means the grep failed
+ die "Unable to find $prop in proplist" unless defined $id;
my $new_depmap = $self->dependency_map
->with_entry_for($id, $deps);
ref($self)->new(
->but_expire_dependents_of(@events);
# Didn't expire anything? Don't clone self
return $self if $depmap eq $self->dependency_map;
- die 'WHUT';
+ my $props = $self->propositions;
+ return (
+ $self->but(dependency_map => $depmap),
+ map $props->[$_], @expired_ids
+ );
}
+sub dependencies_for {
+ my ($self, $prop) = @_;
+ my @props = @{$self->propositions};
+ my ($id) = grep $props[$_] eq $prop, 0..$#props;
+ # 0 is valid, undef means the grep failed
+ die "Unable to find $prop in proplist" unless defined $id;
+ return $self->dependency_map->dependencies_for($id);
+}
1;
sub import {
strictures->import::into(1);
+ DX::Types->import::into(1, ':types', ':assert');
Moo::Role->import::into(1);
}
--- /dev/null
+package DX::Role::Action;
+
+use DX::Role;
+
+requires 'dry_run';
+
+requires 'run';
+
+1;
--- /dev/null
+package DX::Role::ActionPolicy;
+
+use DX::Role;
+
+requires 'allows';
+
+1;
package DX::Role::Predicate;
use List::Util qw(reduce);
-use DX::Utils qw(step);
+use DX::Utils qw(step CONTENTS_OF);
use DX::Role;
sub resolution_step_for {
if ($left->equals($right)) {
return step(
actions => [],
- depends_on => [ [ undef ,=> [ $left, $right ] ] ],
+ depends_on => [
+ [ undef ,=> [ CONTENTS_OF ,=> $left ], [ CONTENTS_OF ,=> $right ] ]
+ ],
);
}
return (
actions => [ $set ],
depends_on => [
[ $right =>
- [ $left ], [ $right ]
+ [ CONTENTS_OF ,=> $left ], [ CONTENTS_OF ,=> $right ]
]
]
)
actions => [ $set ],
depends_on => [
[ $left =>
- [ $left ], [ $right ]
+ [ CONTENTS_OF ,=> $left ], [ CONTENTS_OF ,=> $right ]
]
]
)
use DX::Role;
+with 'DX::Role::Action';
+
has target_path => (is => 'ro', required => 1);
has _updates => (is => 'lazy');
--- /dev/null
+package DX::Role::Step;
+
+use DX::Role;
+
+1;
package DX::Scope;
+use Types::Standard qw(HashRef ArrayRef);
use DX::Class;
-has predicates => (is => 'ro', required => 1);
+has predicates => (is => 'ro', isa => HashRef[Predicate], required => 1);
-has globals => (is => 'ro', required => 1);
+has globals => (is => 'ro', isa => DictValue, required => 1);
-has locals => (is => 'ro', required => 1);
+has locals => (is => 'ro', isa => ArrayRef[DictValue], required => 1);
#has known_facts => (is => 'ro', required => 1);
use DX::Class;
-has current_hypothesis => (is => 'ro', required => 1);
+has current_hypothesis => (is => 'ro', isa => Hypothesis, required => 1);
-has resume_step => (is => 'ro');
+has resume_step => (is => 'ro', isa => Step);
-has alternatives => (is => 'ro', required => 1);
+has alternatives => (is => 'ro', isa => AlternativeList, required => 1);
+
+sub new_for {
+ my ($class, $hyp) = @_;
+ $class->new(
+ current_hypothesis => $hyp,
+ alternatives => [],
+ );
+}
sub with_one_step {
my ($self) = @_;
package DX::Step::Normal;
+use Types::Standard qw(ArrayRef);
use DX::Class;
-has actions => (is => 'ro', required => 1);
+with 'DX::Role::Step';
-has depends_on => (is => 'ro', required => 1);
+has actions => (is => 'ro', isa => ArrayRef[Action], required => 1);
-has alternative_step => (is => 'ro');
+has depends_on => (is => 'ro', isa => DependencyGroupList, required => 1);
+
+has alternative_step => (is => 'ro', isa => Step);
sub but_with_dependencies_on {
my ($self, @deps) = @_;
sub apply_to {
my ($self, $old_hyp) = @_;
+#::Dwarn($self->depends_on);
return ($self->_apply_to_hyp($old_hyp), $self->alternative_step);
}
--- /dev/null
+package DX::Types;
+
+use strictures 2;
+use Type::Library
+ -base,
+ -declare => (
+ (our @CLASSES = qw(
+ Hypothesis Scope ResolvedPropositionSet Proposition DependencyMap
+ )),
+ (our @ROLES = qw(
+ Step Action ActionPolicy Predicate Value
+ )),
+ qw(
+ DependencyType _DependencyTree DependecySpec
+ One DependencyGroupEntry DependencyGroup
+ ),
+ )
+;
+use Type::Utils -all;
+use Types::Standard qw(
+ ArrayRef Tuple HashRef Dict Maybe Optional slurpy Str
+);
+use DX::Utils qw(:event_types :dep_types);
+
+foreach my $class (our @CLASSES) {
+ class_type $class => { class => 'DX::'.$class };
+}
+
+foreach my $role (our @ROLES) {
+ role_type $role => { role => 'DX::Role::'.$role };
+}
+
+class_type DictValue => { class => 'DX::Value::Dict' };
+
+declare AlternativeList => as ArrayRef[Tuple[Hypothesis, Step]];
+
+declare DependencyType => where {
+ foreach my $cand (EXISTENCE_OF, INDICES_OF, TYPE_OF, CONTENTS_OF) {
+ return 1 if $_ eq $cand;
+ }
+ return 0;
+};
+
+declare EventType => where {
+ foreach my $cand (VALUE_SET, VALUE_EXISTS) {
+ return 1 if $_ eq $cand;
+ }
+ return 0;
+};
+
+declare _DependencyTree => where { is_DependencyTree($_) };
+
+declare DependencySpec => as Tuple[DependencyType, slurpy ArrayRef[Str]];
+
+declare One => where { !ref($_) and $_ eq 1 };
+
+declare DependencyTree => # [ \%subtree, \%existence_of, ... ]
+ as HashRef[Tuple[
+ Maybe[_DependencyTree],
+ (Optional[Maybe[HashRef[One]]]) x 4
+ ]];
+
+declare DependencyGroupEntry =>
+ as Tuple[DependencyType, slurpy ArrayRef[Value|Str]];
+
+declare DependencyGroup =>
+ as Tuple[Maybe[Value], slurpy ArrayRef[DependencyGroupEntry]];
+
+declare DependencyGroupList => as ArrayRef[DependencyGroup];
+
+1;
our @VALUE_SET = (INDICES_OF(), TYPE_OF(), CONTENTS_OF());
sub step {
+ require DX::Step::Normal;
DX::Step::Normal->new(@_);
}
sub string {
+ require DX::Value::String;
DX::Value::String->new(string_value => $_[0])
}
sub number {
+ require DX::Value::Number;
DX::Value::Number->new(number_value => $_[0]);
}
sub dict {
+ require DX::Value::Dict;
DX::Value::Dict->new(
members => { @_ },
);
sub proposition {
my ($pred, @args) = @_;
+ require DX::Proposition;
DX::Proposition->new(
predicate => $pred,
args => \@args,
}
{
- require DX::Deparse;
- my $dp = DX::Deparse->new;
+ my $dp;
sub deparse {
+ $dp ||= do {
+ require DX::Deparse;
+ DX::Deparse->new;
+ };
my ($thing) = @_;
$dp->fmt($thing);
}
}
-# 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;
my $scope = use_module('DX::Scope')->new(
predicates => {
- '=' => use_module('DX::Predicate::Equals')->new,
+ 'eq' => use_module('DX::Predicate::Equals')->new,
member_at => use_module('DX::Predicate::MemberAt')->new,
is_dict => use_module('DX::Predicate::IsDict')->new,
},
outstanding_propositions => [
proposition(is_dict => 'X'),
proposition(member_at => 'X', string('a'), string('b')),
- proposition(member_at => 'X', string('a'), string('b')),
+ #proposition(member_at => 'X', string('a'), string('c')),
+ proposition(eq => 'X', dict(a => string('b'), c => string('d'))),
],
actions => [],
+ action_policy => use_module('DX::ActionPolicy::Allow')->new
);
my $ss = use_module('DX::SearchState')->new(
);
#::Dwarn($ss->with_one_step->with_one_step);
-warn deparse($ss->with_one_step->with_one_step->with_one_step);
+warn deparse(my $f = $ss->with_one_step->with_one_step->with_one_step);
+
+::Dwarn($f->current_hypothesis->resolved_propositions->dependency_map);
projects / scpubgit/DX.git / commitdiff