890556c30d
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@256 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
909 lines
21 KiB
Prolog
909 lines
21 KiB
Prolog
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
% Constraint Handling Rules version 2.2 %
|
|
% %
|
|
% (c) Copyright 1996-98 %
|
|
% LMU, Muenchen %
|
|
% %
|
|
% File: chr.pl %
|
|
% Author: Christian Holzbaur christian@ai.univie.ac.at %
|
|
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
|
|
|
|
%
|
|
% The CHR runtime system,
|
|
% the constraint store.
|
|
%
|
|
% Two functions: a) storage b) reactivation triggered by bindings
|
|
%
|
|
% Reactivation is symmetric: if two variables with suspensions
|
|
% are unified, both suspensions run. (Both variables got more
|
|
% constrained)
|
|
%
|
|
% *** Sequence of wakeups determines termination of handler leq ***
|
|
%
|
|
% Another sequence that could matter is the one
|
|
% generated by the iterators
|
|
%
|
|
% Layout:
|
|
%
|
|
% suspension(Id,State,Closure,Generation,PropagationHistory,F|Args)
|
|
%
|
|
% Id is 1st to allow for direct comparisons (sort) and avoids
|
|
% unifiability if the Id is nonvar.
|
|
% F is the constraint functor
|
|
%
|
|
%
|
|
|
|
:- module( chr,
|
|
[
|
|
find_constraint/2,
|
|
find_constraint/3,
|
|
findall_constraints/2,
|
|
findall_constraints/3,
|
|
remove_constraint/1,
|
|
current_handler/2,
|
|
current_constraint/2,
|
|
unconstrained/1,
|
|
notify_constrained/1,
|
|
|
|
chr_trace/0, chr_notrace/0,
|
|
chr_debug/0, chr_nodebug/0, chr_debugging/0,
|
|
chr_leash/1, chr_spy/1, chr_nospy/1
|
|
]).
|
|
|
|
:- use_module( library('chr/getval')).
|
|
|
|
:- use_module( library(lists),
|
|
[
|
|
append/3,
|
|
member/2,
|
|
is_list/1,
|
|
nth/3,
|
|
select/3
|
|
]).
|
|
|
|
:- use_module( library(terms),
|
|
[
|
|
term_variables/2,
|
|
subsumes_chk/2,
|
|
subsumes/2
|
|
]).
|
|
|
|
:- use_module( library(assoc), % propagation history
|
|
[
|
|
empty_assoc/1,
|
|
put_assoc/4,
|
|
get_assoc/3,
|
|
assoc_to_list/2
|
|
]).
|
|
|
|
:- use_module(library('chr/sbag')). % link to sbag_l.pl or sbag_a.pl
|
|
:- use_module(library('chr/chrcmp')).
|
|
:- use_module(library('chr/trace')).
|
|
|
|
:- use_module(library(atts)).
|
|
|
|
:- attribute locked/0, exposed/1, dbg_state/1.
|
|
|
|
%
|
|
% Problem with cyclic structures:
|
|
% error reporters seem to use write ...
|
|
%
|
|
:- multifile
|
|
user:portray/1,
|
|
user:portray_message/2,
|
|
user:goal_expansion/3.
|
|
|
|
:- dynamic
|
|
user:portray/1,
|
|
user:portray_message/2,
|
|
user:goal_expansion/3.
|
|
|
|
%
|
|
user:portray( Susp) :-
|
|
Susp =.. [suspension,Id,Mref,_,_,_,_|_],
|
|
nonvar( Mref),
|
|
!,
|
|
write('<c'), write(Id), write('>'). % (c)onstraint
|
|
%
|
|
user:portray( '$want_duplicates'(_,Term)) :- !, % cf. attribute_goal/2
|
|
prolog_flag( toplevel_print_options, Options),
|
|
write_term( Term, Options).
|
|
|
|
:- initialization
|
|
setval( id, 0). % counter for portray/debugger
|
|
|
|
%
|
|
user:portray_message( error, chr(multiple_handlers(Old,New,Module))) :- !,
|
|
format( user_error, '{CHR ERROR: registering ~p, module ~p already hosts ~p}~n',
|
|
[New,Module,Old]).
|
|
|
|
% -----------------------------------------------------------------
|
|
|
|
%
|
|
% *** MACROS ***
|
|
%
|
|
%
|
|
user:goal_expansion( lock_some(L), chr, Exp) :- is_list(L),
|
|
unravel( L, lock, Exp).
|
|
user:goal_expansion( unlock_some(L), chr, Exp) :- is_list(L),
|
|
unravel( L, unlock, Exp).
|
|
user:goal_expansion( via([],V), chr, global_term_ref_1(V)).
|
|
user:goal_expansion( via([X],V), chr, via_1(X,V)).
|
|
user:goal_expansion( via([X,Y],V), chr, via_2(X,Y,V)).
|
|
user:goal_expansion( via([X,Y,Z],V), chr, via_3(X,Y,Z,V)).
|
|
user:goal_expansion( load_args(S,State,Args), chr, Exp) :-
|
|
is_list( Args),
|
|
Susp =.. [suspension,_,Mref,_,_,_,_|Args],
|
|
Exp = ( S=Susp, get_mutable( State, Mref) ).
|
|
%
|
|
%
|
|
%
|
|
user:goal_expansion( nd_init_iteration(V,_,_,Att,S), _, Exp) :-
|
|
arg( 1, Att, Stack),
|
|
Exp = ( get_atts(V,Att), chr:sbag_member(S,Stack) ).
|
|
%
|
|
user:goal_expansion( init_iteration(V,_,_,Att,L), _, Exp) :-
|
|
arg( 1, Att, Stack),
|
|
Exp = ( get_atts(V,Att), chr:iter_init(Stack,L) ).
|
|
|
|
unravel( [], _, true).
|
|
unravel( [X|Xs], F, (G,Gs)) :-
|
|
G =.. [F,X],
|
|
unravel( Xs, F, Gs).
|
|
|
|
% ----------------------- runtime user predicates -----------------
|
|
|
|
remove_constraint( Susp) :-
|
|
nonvar( Susp),
|
|
functor( Susp, suspension, N),
|
|
N >= 6,
|
|
!,
|
|
debug_event( remove(Susp)),
|
|
remove_constraint_internal( Susp, Vars),
|
|
arg( 3, Susp, Module:_),
|
|
arg( 6, Susp, F),
|
|
A is N-6,
|
|
Module:detach( F/A, Susp, Vars).
|
|
remove_constraint( S) :-
|
|
raise_exception( type_error(remove_constraint(S),1,'a constraint object',S)).
|
|
|
|
find_constraint( Term, Susp) :-
|
|
global_term_ref_1( Global),
|
|
find_constraint( Global, Term, Susp).
|
|
|
|
find_constraint( V, Term, Susp) :- var( V), !,
|
|
find_constraint_internal( V, Term, Susp, active, _).
|
|
find_constraint( A, B, C) :-
|
|
raise_exception( instantiation_error( find_constraint(A,B,C), 1)).
|
|
|
|
find_constraint_internal( V, Term, Susp, State, Module) :-
|
|
constraint( Handler, F/A, Att),
|
|
functor( Term, F, A), % prune some
|
|
arg( 1, Att, Stack),
|
|
current_handler( Handler, Module),
|
|
Module:get_atts( V, Att),
|
|
length( Args, A),
|
|
Try =.. [F|Args],
|
|
sbag_member( Susp, Stack),
|
|
Susp =.. [suspension,_,Mref,_,_,_,_|Args],
|
|
get_mutable( State, Mref),
|
|
subsumes( Term, Try).
|
|
|
|
%
|
|
% Test for unconstrained var
|
|
% Used by some math solvers
|
|
%
|
|
unconstrained( X) :-
|
|
% var(X), prolog:'$get_cva'(X,[],_).
|
|
find_constraint( X, _, _), !, fail.
|
|
unconstrained( _).
|
|
|
|
findall_constraints( C, L) :-
|
|
global_term_ref_1( Global),
|
|
findall_constraints( Global, C, L).
|
|
|
|
findall_constraints( V, C, L) :- var( V), !,
|
|
findall( M:Att, (
|
|
constraint( H, F/A, Att),
|
|
functor( C, F, A),
|
|
current_handler( H, M)
|
|
),
|
|
Agenda),
|
|
findall_constraints( Agenda, C, V, L, []).
|
|
findall_constraints( V, C, L) :-
|
|
raise_exception( instantiation_error( findall_constraints(V,C,L), 1)).
|
|
|
|
findall_constraints( [], _, _) --> [].
|
|
findall_constraints( [Module:Att|Agenda], C, V) -->
|
|
( {
|
|
arg( 1, Att, Stack),
|
|
Module:get_atts( V, Att),
|
|
iter_init( Stack, State)
|
|
} ->
|
|
findall_constraints_( State, C, Module)
|
|
;
|
|
[]
|
|
),
|
|
findall_constraints( Agenda, C, V).
|
|
|
|
findall_constraints_( State, _, _) --> {iter_last(State)}.
|
|
findall_constraints_( State, General, Module) -->
|
|
{
|
|
iter_next( State, S, Next)
|
|
},
|
|
( {
|
|
S =.. [suspension,_,Mref,_,_,_,F|Args],
|
|
get_mutable( active, Mref),
|
|
Term =.. [F|Args],
|
|
subsumes_chk( General, Term)
|
|
} ->
|
|
[ Term#S ]
|
|
;
|
|
[]
|
|
),
|
|
findall_constraints_( Next, General, Module).
|
|
|
|
%
|
|
% Decorate a constraint Term from Module
|
|
% with a module prefix if needed.
|
|
%
|
|
module_wrap( Term, Module, Wrapped) :-
|
|
prolog_flag( typein_module, Typein),
|
|
( Module == Typein ->
|
|
Wrapped = Term
|
|
; predicate_property( Typein:Term, imported_from(_)) ->
|
|
Wrapped = Term
|
|
;
|
|
Wrapped = Module:Term
|
|
).
|
|
|
|
% -----------------------------------------------------------------
|
|
/*
|
|
|
|
Two namespaces handler/module actually only justified if there
|
|
can be more than one handler per module ...
|
|
|
|
*/
|
|
|
|
:- dynamic handler/2.
|
|
:- dynamic constraint/3.
|
|
|
|
current_handler( Handler, Module) :-
|
|
handler( Handler, Module).
|
|
|
|
current_constraint( Handler, C) :-
|
|
constraint( Handler, C, _).
|
|
|
|
register_handler( Handler, Cs, Slots) :-
|
|
prolog_load_context( module, Module),
|
|
( handler(Other,Module),
|
|
Other \== Handler ->
|
|
raise_exception( chr(multiple_handlers(Other,Handler,Module)))
|
|
; handler( Handler, Module) ->
|
|
true % simple reload
|
|
;
|
|
assert( handler(Handler,Module))
|
|
),
|
|
retractall( constraint(Handler,_,_)),
|
|
reg_handler( Cs, Slots, Handler).
|
|
|
|
reg_handler( [], [], _).
|
|
reg_handler( [C|Cs], [S|Ss], Handler) :-
|
|
assert( constraint(Handler,C,S)),
|
|
reg_handler( Cs, Ss, Handler).
|
|
|
|
% ----------------------------------------------------------------
|
|
|
|
notify_constrained( X) :- var( X),
|
|
findall( M, handler(_,M), Modules),
|
|
notify_constrained( Modules, X).
|
|
notify_constrained( X) :- nonvar( X),
|
|
raise_exception( instantitation_error( notify_constrained(X),1)).
|
|
|
|
notify_constrained( [], _).
|
|
notify_constrained( [M|Ms], X) :-
|
|
M:get_suspensions( X, S),
|
|
run_suspensions( S),
|
|
notify_constrained( Ms, X).
|
|
|
|
%
|
|
% support for verify_attributes/3, notify_constrained/1
|
|
%
|
|
% Approximation because debug state might change between calls ...
|
|
%
|
|
|
|
run_suspensions( Slots) :-
|
|
getval( debug, State),
|
|
( State == off ->
|
|
run_suspensions_loop( Slots)
|
|
;
|
|
run_suspensions_loop_d( Slots)
|
|
),
|
|
true.
|
|
|
|
run_suspensions_loop( []).
|
|
run_suspensions_loop( [A|As]) :-
|
|
arg( 1, A, Stack),
|
|
iter_init( Stack, State),
|
|
run_suspensions_( State),
|
|
run_suspensions_loop( As).
|
|
|
|
run_suspensions_loop_d( []).
|
|
run_suspensions_loop_d( [A|As]) :-
|
|
arg( 1, A, Stack),
|
|
iter_init( Stack, State),
|
|
run_suspensions_d( State),
|
|
run_suspensions_loop_d( As).
|
|
|
|
%
|
|
% Transition active->triggered->removed instead of
|
|
% active->removed is to avoid early gc of suspensions.
|
|
% The suspension's generation is incremented to signal
|
|
% to the revive scheme that the constraint has been
|
|
% processed already.
|
|
%
|
|
run_suspensions_( State) :- iter_last( State).
|
|
run_suspensions_( State) :-
|
|
iter_next( State, S, Next),
|
|
arg( 2, S, Mref),
|
|
get_mutable( Status, Mref),
|
|
( Status==active ->
|
|
update_mutable( triggered, Mref),
|
|
arg( 4, S, Gref),
|
|
get_mutable( Gen, Gref),
|
|
Generation is Gen+1,
|
|
update_mutable( Generation, Gref),
|
|
arg( 3, S, Goal),
|
|
call( Goal),
|
|
get_mutable( Post, Mref),
|
|
( Post==triggered ->
|
|
update_mutable( removed, Mref)
|
|
;
|
|
true
|
|
)
|
|
;
|
|
true
|
|
),
|
|
run_suspensions_( Next).
|
|
|
|
run_suspensions_d( State) :- iter_last( State).
|
|
run_suspensions_d( State) :-
|
|
iter_next( State, S, Next),
|
|
arg( 2, S, Mref),
|
|
get_mutable( Status, Mref),
|
|
( Status==active ->
|
|
update_mutable( triggered, Mref),
|
|
arg( 4, S, Gref),
|
|
get_mutable( Gen, Gref),
|
|
Generation is Gen+1,
|
|
update_mutable( Generation, Gref),
|
|
arg( 3, S, Goal),
|
|
byrd( S, Goal),
|
|
get_mutable( Post, Mref),
|
|
( Post==triggered ->
|
|
update_mutable( removed, Mref)
|
|
;
|
|
true
|
|
)
|
|
;
|
|
true
|
|
),
|
|
run_suspensions_d( Next).
|
|
|
|
byrd( Self, Goal) :-
|
|
( debug_event( wake(Self)), call( Goal)
|
|
; debug_event( fail(Self)), !, fail
|
|
),
|
|
( debug_event( exit(Self))
|
|
; debug_event( redo(Self)), fail
|
|
).
|
|
|
|
%
|
|
% Merge 2 sorted lists of Name/1 terms.
|
|
% The argument of each term is a sbag.
|
|
%
|
|
merge_attributes( [], Bs, Bs).
|
|
merge_attributes( [A|As], Bs, Cs) :-
|
|
merge_attributes( Bs, Cs, A, As).
|
|
|
|
merge_attributes( [], [A|As], A, As).
|
|
merge_attributes( [B|Bs], Cs, A, As) :-
|
|
functor( A, NameA, 1),
|
|
functor( B, NameB, 1),
|
|
compare( R, NameA, NameB),
|
|
( R == < -> Cs = [A|Css], merge_attributes( As, Css, B, Bs)
|
|
; R == > -> Cs = [B|Css], merge_attributes( Bs, Css, A, As)
|
|
;
|
|
Cs = [C|Css],
|
|
functor( C, NameA, 1),
|
|
arg( 1, A, StackA),
|
|
arg( 1, B, StackB),
|
|
arg( 1, C, StackC),
|
|
sbag_union( StackA, StackB, StackC),
|
|
merge_attributes( As, Bs, Css)
|
|
).
|
|
|
|
show_bag( Bag) :-
|
|
iter_init( Bag, State),
|
|
show_bag_( State),
|
|
nl.
|
|
|
|
show_bag_( State) :- iter_last( State).
|
|
show_bag_( State) :-
|
|
iter_next( State, S, Next),
|
|
arg( 2, S, Ref),
|
|
get_mutable( St, Ref),
|
|
format( ' ~p:~p', [S,St]),
|
|
show_bag_( Next).
|
|
|
|
%
|
|
% Support for attribute_goal/2.
|
|
%
|
|
% Complication: the Sicstus kernel removes duplicates
|
|
% via call_residue/2 - that includes the toplevel.
|
|
% We may want to see them ->
|
|
% tag Term with Suspension, 'untag' via portray/1
|
|
%
|
|
% Called with a list of slots once per module
|
|
%
|
|
attribute_goals( L, Goal, Module) :-
|
|
attribute_goal_loop( L, Module, GL, []),
|
|
l2c( GL, Goal).
|
|
|
|
attribute_goal_loop( [], _) --> [].
|
|
attribute_goal_loop( [A|As], Mod) -->
|
|
{
|
|
arg( 1, A, Stack),
|
|
iter_init( Stack, State)
|
|
},
|
|
attgs_( State, Mod),
|
|
attribute_goal_loop( As, Mod).
|
|
|
|
attgs_( State, _) --> {iter_last( State)}.
|
|
attgs_( State, Module) -->
|
|
{
|
|
iter_next( State, S, Next),
|
|
S =.. [suspension,_,Mref,_,_,_,F|Args]
|
|
},
|
|
( {get_mutable(active,Mref)} ->
|
|
{
|
|
Term =.. [F|Args],
|
|
module_wrap( Term, Module, Wrapped)
|
|
},
|
|
[ '$want_duplicates'(S,Wrapped) ]
|
|
;
|
|
[]
|
|
),
|
|
attgs_( Next, Module).
|
|
|
|
%
|
|
% fail for empty list
|
|
%
|
|
l2c( [C], C) :- !.
|
|
l2c( [C|Cs], (C,Cj)) :-
|
|
l2c( Cs, Cj).
|
|
|
|
%
|
|
% Unlink removed constraints cleanly from all chains
|
|
% Still need gc state because of wake,
|
|
% but re-insertion = insert because of complete removal.
|
|
%
|
|
chr_gc :-
|
|
global_term_ref_1( Global),
|
|
findall( M, handler(_,M), Modules),
|
|
chr_gcm( Modules, Global).
|
|
|
|
chr_gcm( [], _).
|
|
chr_gcm( [M|Ms], Global) :-
|
|
M:get_suspensions( Global, AllS),
|
|
term_variables( [Global|AllS], Vars), % AllS may be ground
|
|
chr_gcv( Vars, M),
|
|
chr_gcm( Ms, Global).
|
|
|
|
%
|
|
% Have compiler generated support?
|
|
%
|
|
chr_gcv( [], _).
|
|
chr_gcv( [V|Vs], M) :-
|
|
M:get_suspensions( V, Old),
|
|
chr_gcb( Old, New),
|
|
M:put_suspensions( V, New),
|
|
chr_gcv( Vs, M).
|
|
|
|
chr_gcb( [], []).
|
|
chr_gcb( [S|Ss], [Sgc|Ts]) :-
|
|
arg( 1, S, Bag),
|
|
iter_init( Bag, State),
|
|
functor( S, N, 1),
|
|
functor( T, N, 1),
|
|
gc_bag( State, Lgc),
|
|
( Lgc==[] ->
|
|
Sgc = -T
|
|
;
|
|
Sgc = T,
|
|
list_to_sbag( Lgc, BagGc),
|
|
arg( 1, T, BagGc)
|
|
),
|
|
chr_gcb( Ss, Ts).
|
|
|
|
gc_bag( State, []) :- iter_last( State).
|
|
gc_bag( State, L) :-
|
|
iter_next( State, Susp, Next),
|
|
arg( 2, Susp, Mref),
|
|
get_mutable( SuspState, Mref),
|
|
( SuspState==removed ->
|
|
L = Tail,
|
|
update_mutable( gc, Mref)
|
|
; SuspState==gc ->
|
|
L = Tail
|
|
;
|
|
L = [Susp|Tail]
|
|
),
|
|
gc_bag( Next, Tail).
|
|
|
|
% --------------------------------------------------------------------
|
|
%
|
|
% Incremental allocation & activation of constraints.
|
|
% Attachment code of closures to variables is generated
|
|
% by the compiler.
|
|
%
|
|
% States {passive(Term),inactive,triggered,active,removed,gc}
|
|
%
|
|
%
|
|
|
|
:- meta_predicate allocate_constraint(:,-,+,+).
|
|
%
|
|
allocate_constraint( Closure, Self, F, Args) :-
|
|
empty_history( History),
|
|
create_mutable( passive(Args), Mref),
|
|
create_mutable( 0, Gref),
|
|
create_mutable( History, Href),
|
|
gen_id( Id),
|
|
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
|
|
|
|
%
|
|
% activate_constraint( -, +, -).
|
|
%
|
|
% The transition gc->active should be rare
|
|
%
|
|
activate_constraint( Vars, Susp, Generation) :-
|
|
arg( 2, Susp, Mref),
|
|
get_mutable( State, Mref),
|
|
update_mutable( active, Mref),
|
|
( nonvar(Generation) -> % aih
|
|
true
|
|
;
|
|
arg( 4, Susp, Gref),
|
|
get_mutable( Gen, Gref),
|
|
Generation is Gen+1,
|
|
update_mutable( Generation, Gref)
|
|
),
|
|
( compound(State) -> % passive/1
|
|
term_variables( State, Vs),
|
|
none_locked( Vs),
|
|
global_term_ref_1( Global),
|
|
Vars = [Global|Vs]
|
|
; State==gc -> % removed from all chains
|
|
Susp =.. [_,_,_,_,_,_,_|Args],
|
|
term_variables( Args, Vs),
|
|
global_term_ref_1( Global),
|
|
Vars = [Global|Vs]
|
|
; State==removed -> % the price for eager removal ...
|
|
Susp =.. [_,_,_,_,_,_,_|Args],
|
|
term_variables( Args, Vs),
|
|
global_term_ref_1( Global),
|
|
Vars = [Global|Vs]
|
|
;
|
|
Vars = []
|
|
).
|
|
|
|
%
|
|
% Combination of the prev. two
|
|
%
|
|
:- meta_predicate insert_constraint_internal(-,-,:,+,+).
|
|
%
|
|
insert_constraint_internal( [Global|Vars], Self, Closure, F, Args) :-
|
|
term_variables( Args, Vars),
|
|
none_locked( Vars),
|
|
global_term_ref_1( Global),
|
|
empty_history( History),
|
|
create_mutable( active, Mref),
|
|
create_mutable( 0, Gref),
|
|
create_mutable( History, Href),
|
|
gen_id( Id),
|
|
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
|
|
|
|
:- meta_predicate insert_constraint_internal(-,-,?,:,+,+).
|
|
%
|
|
insert_constraint_internal( [Global|Vars], Self, Term, Closure, F, Args) :-
|
|
term_variables( Term, Vars),
|
|
none_locked( Vars),
|
|
global_term_ref_1( Global),
|
|
empty_history( History),
|
|
create_mutable( active, Mref),
|
|
create_mutable( 0, Gref),
|
|
create_mutable( History, Href),
|
|
gen_id( Id),
|
|
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
|
|
|
|
gen_id( Id) :-
|
|
incval( id, Id).
|
|
/* no undo/1 in sicstus3.7
|
|
( Id =:= 1 -> % first time called
|
|
undo( setval(id,0))
|
|
;
|
|
true
|
|
).
|
|
*/
|
|
|
|
%
|
|
% Eager removal from all chains.
|
|
%
|
|
remove_constraint_internal( Susp, Agenda) :-
|
|
arg( 2, Susp, Mref),
|
|
get_mutable( State, Mref),
|
|
update_mutable( removed, Mref), % mark in any case
|
|
( compound(State) -> % passive/1
|
|
Agenda = []
|
|
; State==removed ->
|
|
Agenda = []
|
|
; State==triggered ->
|
|
Agenda = []
|
|
;
|
|
Susp =.. [_,_,_,_,_,_,_|Args],
|
|
term_variables( Args, Vars),
|
|
global_term_ref_1( Global),
|
|
Agenda = [Global|Vars]
|
|
).
|
|
|
|
%
|
|
% Protect the goal against any binding
|
|
% or attachment of constraints. The latter is
|
|
% via the notify_constrained/1 convention.
|
|
%
|
|
lock( T) :- var(T), put_atts( T, locked).
|
|
lock( T) :- nonvar( T),
|
|
functor( T, _, N),
|
|
lock_arg( N, T).
|
|
|
|
lock_arg( 0, _) :- !.
|
|
lock_arg( 1, T) :- !, arg( 1, T, A), lock( A).
|
|
lock_arg( 2, T) :- !, arg( 1, T, A), lock( A), arg( 2, T, B), lock( B).
|
|
lock_arg( N, T) :-
|
|
arg( N, T, A),
|
|
lock( A),
|
|
M is N-1,
|
|
lock_arg( M, T).
|
|
|
|
unlock( T) :- var(T), put_atts( T, -locked).
|
|
unlock( T) :- nonvar( T),
|
|
functor( T, _, N),
|
|
unlock_arg( N, T).
|
|
|
|
unlock_arg( 0, _) :- !.
|
|
unlock_arg( 1, T) :- !, arg( 1, T, A), unlock( A).
|
|
unlock_arg( 2, T) :- !, arg( 1, T, A), unlock( A), arg( 2, T, B), unlock( B).
|
|
unlock_arg( N, T) :-
|
|
arg( N, T, A),
|
|
unlock( A),
|
|
M is N-1,
|
|
unlock_arg( M, T).
|
|
|
|
verify_attributes( X, Y, []) :-
|
|
get_atts( X, locked),
|
|
!,
|
|
var(Y),
|
|
get_atts( Y, -locked),
|
|
put_atts( Y, locked).
|
|
verify_attributes( _, _, []).
|
|
|
|
none_locked( []).
|
|
none_locked( [V|Vs]) :-
|
|
not_locked( V),
|
|
none_locked( Vs).
|
|
|
|
not_locked( V) :- var( V), get_atts( V, -locked).
|
|
not_locked( V) :- nonvar( V).
|
|
|
|
% -------------------------- access to constraints ------------------
|
|
|
|
%
|
|
% Try a list of candidates. V may be nonvar but
|
|
% bound to a term with variables in it.
|
|
%
|
|
via( L, V) :-
|
|
member( X, L),
|
|
var( X),
|
|
!,
|
|
V = X.
|
|
via( L, V) :-
|
|
compound( L),
|
|
nonground( L, V),
|
|
!.
|
|
via( _, V) :-
|
|
global_term_ref_1( V).
|
|
|
|
%
|
|
% specialization(s)
|
|
%
|
|
via_1( X, V) :- var(X), !, X=V.
|
|
via_1( T, V) :- compound(T), nonground( T, V), !.
|
|
via_1( _, V) :- global_term_ref_1( V).
|
|
|
|
via_2( X, _, V) :- var(X), !, X=V.
|
|
via_2( _, Y, V) :- var(Y), !, Y=V.
|
|
via_2( T, _, V) :- compound(T), nonground( T, V), !.
|
|
via_2( _, T, V) :- compound(T), nonground( T, V), !.
|
|
via_2( _, _, V) :- global_term_ref_1( V).
|
|
|
|
via_3( X, _, _, V) :- var(X), !, X=V.
|
|
via_3( _, Y, _, V) :- var(Y), !, Y=V.
|
|
via_3( _, _, Z, V) :- var(Z), !, Z=V.
|
|
via_3( T, _, _, V) :- compound(T), nonground( T, V), !.
|
|
via_3( _, T, _, V) :- compound(T), nonground( T, V), !.
|
|
via_3( _, _, T, V) :- compound(T), nonground( T, V), !.
|
|
via_3( _, _, _, V) :- global_term_ref_1( V).
|
|
|
|
|
|
%
|
|
% The second arg is a witness.
|
|
% The formulation with term_variables/2 is
|
|
% cycle safe, but it finds a list of all vars.
|
|
% We need only one, and no list in particular.
|
|
%
|
|
nonground( Term, V) :-
|
|
term_variables( Term, Vs),
|
|
Vs = [V|_].
|
|
|
|
/*
|
|
nonground( Term, V) :- var( Term), V=Term.
|
|
nonground( Term, V) :- compound( Term),
|
|
functor( Term, _, N),
|
|
nonground( N, Term, V).
|
|
|
|
%
|
|
% assert: N > 0
|
|
%
|
|
nonground( 1, Term, V) :- !,
|
|
arg( 1, Term, Arg),
|
|
nonground( Arg, V).
|
|
nonground( 2, Term, V) :- !,
|
|
arg( 2, Term, Arg2),
|
|
( nonground( Arg2, V) ->
|
|
true
|
|
;
|
|
arg( 1, Term, Arg1),
|
|
nonground( Arg1, V)
|
|
).
|
|
nonground( N, Term, V) :-
|
|
arg( N, Term, Arg),
|
|
( nonground( Arg, V) ->
|
|
true
|
|
;
|
|
M is N-1,
|
|
nonground( M, Term, V)
|
|
).
|
|
*/
|
|
|
|
constraint_generation( Susp, State, Generation) :-
|
|
arg( 2, Susp, Mref),
|
|
get_mutable( State, Mref),
|
|
arg( 4, Susp, Gref),
|
|
get_mutable( Generation, Gref). % not incremented meanwhile
|
|
|
|
change_state( Susp, State) :-
|
|
arg( 2, Susp, Mref),
|
|
update_mutable( State, Mref).
|
|
|
|
:- meta_predicate expose(-,+,+,+,:).
|
|
%
|
|
expose_active( Ref, Head, Tid, Heads, Continuation) :-
|
|
get_exposed( Ref),
|
|
get_mutable( Exposed, Ref),
|
|
update_mutable( [active(Head,Tid,Heads,Continuation)|Exposed], Ref).
|
|
|
|
expose_passive( Ref, Heads) :-
|
|
get_exposed( Ref),
|
|
get_mutable( Exposed, Ref),
|
|
update_mutable( [passive(Heads)|Exposed], Ref).
|
|
|
|
de_expose( Ref) :-
|
|
get_mutable( [_|Exposed], Ref),
|
|
update_mutable( Exposed, Ref).
|
|
|
|
%
|
|
% Prefer passive over active (cheaper to deal with).
|
|
%
|
|
is_exposed( Constraint, Suspension, Continuation) :-
|
|
get_exposed( Ref),
|
|
get_mutable( Exposed, Ref),
|
|
is_exposed( Exposed, Constraint, Suspension, Continuation).
|
|
|
|
is_exposed( [E|Es], Constraint, Suspension, Continuation) :-
|
|
is_exposed( E, Constraint, Suspension, Continuation, Es).
|
|
|
|
is_exposed( active(Head,Susp,Heads,Cont), Constraint, Suspension, Continuation, Es) :-
|
|
( member( C#Suspension, Heads),
|
|
Constraint == C ->
|
|
Continuation = true
|
|
; Constraint == Head ->
|
|
( is_exposed( Es, Constraint, Suspension, true) -> % prefer
|
|
Continuation = true
|
|
;
|
|
Continuation = Cont,
|
|
Suspension = Susp
|
|
)
|
|
;
|
|
is_exposed( Es, Constraint, Suspension, Continuation)
|
|
).
|
|
is_exposed( passive(Heads), Constraint, Suspension, Continuation, Es) :-
|
|
( member( C#Suspension, Heads),
|
|
Constraint == C ->
|
|
Continuation = true
|
|
;
|
|
is_exposed( Es, Constraint, Suspension, Continuation)
|
|
).
|
|
|
|
get_exposed( Ref) :-
|
|
global_term_ref_1( Global),
|
|
( get_atts( Global, exposed(Ref)) ->
|
|
true
|
|
;
|
|
create_mutable( [], Ref),
|
|
put_atts( Global, exposed(Ref))
|
|
).
|
|
|
|
get_dbg_state( Ref) :-
|
|
global_term_ref_1( Global),
|
|
( get_atts( Global, dbg_state(Ref)) ->
|
|
true
|
|
;
|
|
create_mutable( [], Ref),
|
|
put_atts( Global, dbg_state(Ref))
|
|
).
|
|
|
|
% ------------------- abstract data type for propagation rules -------------
|
|
|
|
empty_history( E) :- empty_assoc( E).
|
|
|
|
%
|
|
% assert: constraints/tuples are comparable directly
|
|
%
|
|
novel_production( Self, Tuple) :-
|
|
arg( 5, Self, Ref),
|
|
get_mutable( History, Ref),
|
|
( get_assoc( Tuple, History, _) ->
|
|
fail
|
|
;
|
|
true
|
|
).
|
|
|
|
%
|
|
% Not folded with novel_production/2 because guard checking
|
|
% goes in between the two calls.
|
|
%
|
|
extend_history( Self, Tuple) :-
|
|
arg( 5, Self, Ref),
|
|
get_mutable( History, Ref),
|
|
put_assoc( Tuple, History, x, NewHistory),
|
|
update_mutable( NewHistory, Ref).
|
|
|
|
% vsc
|
|
%
|
|
global_term_ref(I,X) :- array_element(global_term_ref, I, X).
|
|
global_term_ref_0(X) :- array_element(global_term_ref, 0, X).
|
|
global_term_ref_1(X) :- array_element(global_term_ref, 1, X).
|
|
|
|
:- yap_flag(toplevel_hook,chr:create_global_array).
|
|
|
|
create_global_array :- ( array(global_term_ref,2) -> true ; true).
|
|
|
|
|
|
%
|
|
% vsc
|
|
%
|
|
%:- load_foreign_resource(library(system(chr))).
|
|
|
|
end_of_file.
|
|
|