diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
b9b1e9bb96
yap-6.3/LGPL/chr/chr_translate_bootstrap1.chr
vsc 4d94446c25 port of LGPLed CHR 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1416 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
2005-10-28 17:41:30 +00:00

2817 lines
83 KiB
Plaintext
Raw Blame History

/* $Id: chr_translate_bootstrap1.chr,v 1.1 2005-10-28 17:41:30 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% ____ _ _ ____ ____ _ _
%% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
%% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
%% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
%% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
%% |_|
%%
%% hProlog CHR compiler:
%%
%% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.ac.be
%%
%% * based on the SICStus CHR compilation by Christian Holzbaur
%%
%% First working version: 6 June 2003
%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% To Do
%%
%% * SICStus compatibility
%% - rules/1 declaration
%% - options
%% - pragmas
%% - tell guard
%%
%%
%% * do not suspend on variables that don't matter
%% * make difference between cheap guards for reordering
%% and non-binding guards for lock removal
%%
%% * unqiue -> once/[] transformation for propagation
%%
%% * cheap guards interleaved with head retrieval + faster
%% via-retrieval + non-empty checking for propagation rules
%% redo for simpagation_head2 prelude
%%
%% * intelligent backtracking for simplification/simpagation rule
%% generator_1(X),'_$savecp'(CP_1),
%% ...
%% if( (
%% generator_n(Y),
%% test(X,Y)
%% ),
%% true,
%% ('_$cutto'(CP_1), fail)
%% ),
%% ...
%%
%% or recently developped cascading-supported approach
%%
%% * intelligent backtracking for propagation rule
%% use additional boolean argument for each possible smart backtracking
%% when boolean at end of list true -> no smart backtracking
%% false -> smart backtracking
%% only works for rules with at least 3 constraints in the head
%%
%% * mutually exclusive rules
%%
%% * (set semantics + functional dependency) declaration + resolution
%%
%% * type and instantiation declarations + optimisations
%% + better indexes
%%
%% * disable global store option
%%
%% Done
%%
%% * debugging events
%% * constraints that can never be attached / always simplified away
%% -> need not be considered in diverse operations
%% * clean up generated code
%% * input verification: pragmas
%% * SICStus compatibility: handler/1, constraints/1
%% * optimise variable passing for propagation rule
%% * reordering of head constraints for passive head search
%% * unique inference for simpagation rules
%% * unique optimisation for simpagation and simplification rules
%% * cheap guards interleaved with head retrieval + faster
%% via-retrieval + non-empty checking for simplification / simpagation rules
%% * transform
%% C1 \ C2 <=> true | Body.
%% into
%% C1 # ID \ C2 <=> true | Body pragma passive(ID).
%% where C1 and C2 are indentical under functional dependency information
%% * valid to disregard body in uniqueness inference?
%% * unique inference for simplification rules
%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(chr_translate_bootstrap1,
[ chr_translate/2 % +Decls, -TranslatedDecls
]).
:- use_module(library(lists)).
:- use_module(hprolog).
:- use_module(library(assoc)).
:- use_module(pairlist).
:- use_module(library(ordsets)).
:- include(chr_op2).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- constraints
constraint/2,
constraint_count/1,
constraint_index/2,
get_constraint_index/2,
max_constraint_index/1,
get_max_constraint_index/1,
target_module/1,
get_target_module/1,
attached/2,
is_attached/1,
chr_clear/0.
constraint(FA,Number) \ constraint(FA,Query)
<=> Query = Number.
constraint(FA,Index) # ID \ constraint(Query,Index)
<=> Query = FA pragma passive(ID).
constraint_count(Index) # ID \ constraint_count(Query)
<=> Query = Index pragma passive(ID).
target_module(Mod) # ID \ get_target_module(Query)
<=> Query = Mod
pragma passive(ID).
get_target_module(Query)
<=> Query = user.
constraint_index(C,Index) # ID \ get_constraint_index(C,Query)
<=> Query = Index
pragma passive(ID).
get_constraint_index(C,Query)
<=> fail.
max_constraint_index(Index) # ID \ get_max_constraint_index(Query)
<=> Query = Index
pragma passive(ID).
get_max_constraint_index(Query)
<=> fail.
attached(Constr,yes) \ attached(Constr,_) <=> true.
attached(Constr,no) \ attached(Constr,_) <=> true.
attached(Constr,maybe) \ attached(Constr,maybe) <=> true.
attached(Constr,Type) # ID \ is_attached(Constr)
<=> true |
( Type == no ->
fail
;
true
)
pragma passive(ID).
is_attached(C) <=> true.
chr_clear \ constraint(_,_) # ID
<=> true pragma passive(ID).
chr_clear \ constraint_count(_) # ID
<=> true pragma passive(ID).
chr_clear \ constraint_index(_,_) # ID
<=> true pragma passive(ID).
chr_clear \ max_constraint_index(_) # ID
<=> true pragma passive(ID).
chr_clear \ target_module(_) # ID
<=> true pragma passive(ID).
chr_clear \ attached(_,_) # ID
<=> true pragma passive(ID).
chr_clear
<=> true.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% Translation
chr_translate(Declarations,NewDeclarations) :-
init_chr_pp_flags,
partition_clauses(Declarations,Decls,Rules,OtherClauses),
( Decls == [] ->
NewDeclarations = OtherClauses
;
check_rules(Rules,Decls),
unique_analyse_optimise(Rules,NRules),
check_attachments(NRules),
set_constraint_indices(Decls,1),
store_management_preds(Decls,StoreClauses),
constraints_code(Decls,NRules,ConstraintClauses),
append_lists([OtherClauses,
StoreClauses,
ConstraintClauses
],
NewDeclarations)
),
chr_clear.
store_management_preds(Constraints,Clauses) :-
generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
generate_attach_increment(AttachIncrementClauses),
generate_attr_unify_hook(AttrUnifyHookClauses),
append_lists([AttachAConstraintClauses
,AttachIncrementClauses
,AttrUnifyHookClauses]
,Clauses).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% Partitioning of clauses into constraint declarations, chr rules and other
%% clauses
partition_clauses([],[],[],[]).
partition_clauses([C|Cs],Ds,Rs,OCs) :-
( rule(C,R) ->
Ds = RDs,
Rs = [R | RRs],
OCs = ROCs
; is_declaration(C,D) ->
append(D,RDs,Ds),
Rs = RRs,
OCs = ROCs
; is_module_declaration(C,Mod) ->
target_module(Mod),
Ds = RDs,
Rs = RRs,
OCs = [C|ROCs]
; C = (handler _) ->
format('CHR compiler WARNING: ~w.\n',[C]),
format(' `--> SICStus compatibility: ignoring handler/1 declaration.\n',[]),
Ds = RDs,
Rs = RRs,
OCs = ROCs
; C = (rules _) ->
format('CHR compiler WARNING: ~w.\n',[C]),
format(' `--> SICStus compatibility: ignoring rules/1 declaration.\n',[]),
Ds = RDs,
Rs = RRs,
OCs = ROCs
; C = option(OptionName,OptionValue) ->
handle_option(OptionName,OptionValue),
Ds = RDs,
Rs = RRs,
OCs = ROCs
; Ds = RDs,
Rs = RRs,
OCs = [C|ROCs]
),
partition_clauses(Cs,RDs,RRs,ROCs).
is_declaration(D, Constraints) :- %% constraint declaration
( D = (:- Decl) ->
true
;
D = Decl
),
Decl =.. [constraints,Cs],
conj2list(Cs,Constraints).
%% Data Declaration
%%
%% pragma_rule
%% -> pragma(
%% rule,
%% ids,
%% list(pragma),
%% yesno(string)
%% )
%%
%% ids -> ids(
%% list(int),
%% list(int)
%% )
%%
%% rule -> rule(
%% list(constraint), :: constraints to be removed
%% list(constraint), :: surviving constraints
%% goal, :: guard
%% goal :: body
%% )
rule(RI,R) :- %% name @ rule
RI = (Name @ RI2), !,
rule(RI2,yes(Name),R).
rule(RI,R) :-
rule(RI,no,R).
rule(RI,Name,R) :-
RI = (RI2 pragma P), !, %% pragmas
is_rule(RI2,R1,IDs),
conj2list(P,Ps),
R = pragma(R1,IDs,Ps,Name).
rule(RI,Name,R) :-
is_rule(RI,R1,IDs),
R = pragma(R1,IDs,[],Name).
is_rule(RI,R,IDs) :- %% propagation rule
RI = (H ==> B), !,
conj2list(H,Head2i),
get_ids(Head2i,IDs2,Head2),
IDs = ids([],IDs2),
( B = (G | RB) ->
R = rule([],Head2,G,RB)
;
R = rule([],Head2,true,B)
).
is_rule(RI,R,IDs) :- %% simplification/simpagation rule
RI = (H <=> B), !,
( B = (G | RB) ->
Guard = G,
Body = RB
; Guard = true,
Body = B
),
( H = (H1 \ H2) ->
conj2list(H1,Head2i),
conj2list(H2,Head1i),
get_ids(Head2i,IDs2,Head2,0,N),
get_ids(Head1i,IDs1,Head1,N,_),
IDs = ids(IDs1,IDs2)
; conj2list(H,Head1i),
Head2 = [],
get_ids(Head1i,IDs1,Head1),
IDs = ids(IDs1,[])
),
R = rule(Head1,Head2,Guard,Body).
get_ids(Cs,IDs,NCs) :-
get_ids(Cs,IDs,NCs,0,_).
get_ids([],[],[],N,N).
get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN) :-
( C = (NC # N) ->
true
;
NC = C
),
M is N + 1,
get_ids(Cs,IDs,NCs, M,NN).
is_module_declaration((:- module(Mod)),Mod).
is_module_declaration((:- module(Mod,_)),Mod).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Some input verification:
%% - all constraints in heads are declared constraints
check_rules(Rules,Decls) :-
check_rules(Rules,Decls,1).
check_rules([],_,_).
check_rules([PragmaRule|Rest],Decls,N) :-
check_rule(PragmaRule,Decls,N),
N1 is N + 1,
check_rules(Rest,Decls,N1).
check_rule(PragmaRule,Decls,N) :-
PragmaRule = pragma(Rule,_IDs,Pragmas,_Name),
Rule = rule(H1,H2,_,_),
append(H1,H2,HeadConstraints),
check_head_constraints(HeadConstraints,Decls,PragmaRule,N),
check_pragmas(Pragmas,PragmaRule,N).
check_head_constraints([],_,_,_).
check_head_constraints([Constr|Rest],Decls,PragmaRule,N) :-
functor(Constr,F,A),
( member(F/A,Decls) ->
check_head_constraints(Rest,Decls,PragmaRule,N)
;
format('CHR compiler ERROR: Undeclared constraint ~w in head of ~@.\n',
[F/A,format_rule(PragmaRule,N)]),
format(' `--> Constraint should be on of ~w.\n',[Decls]),
fail
).
check_pragmas([],_,_).
check_pragmas([Pragma|Pragmas],PragmaRule,N) :-
check_pragma(Pragma,PragmaRule,N),
check_pragmas(Pragmas,PragmaRule,N).
check_pragma(Pragma,PragmaRule,N) :-
var(Pragma), !,
format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',
[Pragma,format_rule(PragmaRule,N)]),
format(' `--> Pragma should not be a variable!\n',[]),
fail.
check_pragma(passive(ID), PragmaRule, N) :-
!,
PragmaRule = pragma(_,ids(IDs1,IDs2),_,_),
( memberchk_eq(ID,IDs1) ->
true
; memberchk_eq(ID,IDs2) ->
true
;
format('CHR compiler ERROR: invalid identifier ~w in pragma passive in ~@.\n',
[ID,format_rule(PragmaRule,N)]),
fail
).
check_pragma(Pragma, PragmaRule, N) :-
Pragma = unique(_,_),
!,
format('CHR compiler WARNING: undocument pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
format(' `--> Only use this pragma if you know what you are doing.\n',[]).
check_pragma(Pragma, PragmaRule, N) :-
Pragma = already_in_heads,
!,
format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
check_pragma(Pragma, PragmaRule, N) :-
Pragma = already_in_head(_),
!,
format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
check_pragma(Pragma,PragmaRule,N) :-
format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
format(' `--> Pragma should be one of passive/1!\n',[]),
fail.
format_rule(PragmaRule,N) :-
PragmaRule = pragma(_,_,_,MaybeName),
( MaybeName = yes(Name) ->
write('rule '), write(Name)
;
write('rule number '), write(N)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Global Options
%
handle_option(Var,Value) :-
var(Var), !,
format('CHR compiler ERROR: ~w.\n',[option(Var,Value)]),
format(' `--> First argument should be an atom, not a variable.\n',[]),
fail.
handle_option(Name,Value) :-
var(Value), !,
format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
format(' `--> Second argument should be a nonvariable.\n',[]),
fail.
handle_option(Name,Value) :-
option_definition(Name,Value,Flags),
!,
set_chr_pp_flags(Flags).
handle_option(Name,Value) :-
\+ option_definition(Name,_,_), !.
handle_option(Name,Value) :-
findall(V,option_definition(Name,V,_),Vs),
format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
format(' `--> Invalid value ~w: should be one of ~w.\n',[Value,Vs]),
fail.
option_definition(optimize,experimental,Flags) :-
Flags = [ unique_analyse_optimise - on,
check_unnecessary_active - full,
reorder_heads - on,
set_semantics_rule - on,
check_attachments - on,
guard_via_reschedule - on
].
option_definition(optimize,full,Flags) :-
Flags = [ unique_analyse_optimise - on,
check_unnecessary_active - full,
reorder_heads - on,
set_semantics_rule - on,
check_attachments - on,
guard_via_reschedule - on
].
option_definition(optimize,sicstus,Flags) :-
Flags = [ unique_analyse_optimise - off,
check_unnecessary_active - simplification,
reorder_heads - off,
set_semantics_rule - off,
check_attachments - off,
guard_via_reschedule - off
].
option_definition(optimize,off,Flags) :-
Flags = [ unique_analyse_optimise - off,
check_unnecessary_active - off,
reorder_heads - off,
set_semantics_rule - off,
check_attachments - off,
guard_via_reschedule - off
].
option_definition(debug,off,Flags) :-
Flags = [ debugable - off ].
option_definition(debug,on,Flags) :-
Flags = [ debugable - on ].
option_definition(check_guard_bindings,on,Flags) :-
Flags = [ guard_locks - on ].
option_definition(check_guard_bindings,off,Flags) :-
Flags = [ guard_locks - off ].
init_chr_pp_flags :-
chr_pp_flag_definition(Name,[DefaultValue|_]),
set_chr_pp_flag(Name,DefaultValue),
fail.
init_chr_pp_flags.
set_chr_pp_flags([]).
set_chr_pp_flags([Name-Value|Flags]) :-
set_chr_pp_flag(Name,Value),
set_chr_pp_flags(Flags).
set_chr_pp_flag(Name,Value) :-
atom_concat('$chr_pp_',Name,GlobalVar),
nb_setval(GlobalVar,Value).
chr_pp_flag_definition(unique_analyse_optimise,[on,off]).
chr_pp_flag_definition(check_unnecessary_active,[full,simplification,off]).
chr_pp_flag_definition(reorder_heads,[on,off]).
chr_pp_flag_definition(set_semantics_rule,[on,off]).
chr_pp_flag_definition(guard_via_reschedule,[on,off]).
chr_pp_flag_definition(guard_locks,[on,off]).
chr_pp_flag_definition(check_attachments,[on,off]).
chr_pp_flag_definition(debugable,[off,on]).
chr_pp_flag(Name,Value) :-
atom_concat('$chr_pp_',Name,GlobalVar),
nb_getval(GlobalVar,V),
( V == [] ->
chr_pp_flag_definition(Name,[Value|_])
;
V = Value
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% Generated predicates
%% attach_$CONSTRAINT
%% attach_increment
%% detach_$CONSTRAINT
%% attr_unify_hook
%% attach_$CONSTRAINT
generate_attach_detach_a_constraint_all([],[]).
generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
( is_attached(Constraint) ->
generate_attach_a_constraint(Constraint,Clauses1),
generate_detach_a_constraint(Constraint,Clauses2)
;
Clauses1 = [],
Clauses2 = []
),
generate_attach_detach_a_constraint_all(Constraints,Clauses3),
append_lists([Clauses1,Clauses2,Clauses3],Clauses).
generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
generate_attach_a_constraint_empty_list(Constraint,Clause1),
get_max_constraint_index(N),
( N == 1 ->
generate_attach_a_constraint_1_1(Constraint,Clause2)
;
generate_attach_a_constraint_t_p(Constraint,Clause2)
).
generate_attach_a_constraint_empty_list(CFct / CAty,Clause) :-
atom_concat_list(['attach_',CFct, (/) ,CAty],Fct),
Args = [[],_],
Head =.. [Fct | Args],
Clause = ( Head :- true).
generate_attach_a_constraint_1_1(CFct / CAty,Clause) :-
atom_concat_list(['attach_',CFct, (/) ,CAty],Fct),
Args = [[Var|Vars],Susp],
Head =.. [Fct | Args],
RecursiveCall =.. [Fct,Vars,Susp],
get_target_module(Mod),
Body =
(
( get_attr(Var, Mod, Susps) ->
NewSusps=[Susp|Susps],
put_attr(Var, Mod, NewSusps)
;
put_attr(Var, Mod, [Susp])
),
RecursiveCall
),
Clause = (Head :- Body).
generate_attach_a_constraint_t_p(CFct / CAty,Clause) :-
atom_concat_list(['attach_',CFct, (/) ,CAty],Fct),
Args = [[Var|Vars],Susp],
Head =.. [Fct | Args],
RecursiveCall =.. [Fct,Vars,Susp],
get_constraint_index(CFct/CAty,Position),
or_pattern(Position,Pattern),
get_max_constraint_index(Total),
make_attr(Total,Mask,SuspsList,Attr),
nth(Position,SuspsList,Susps),
substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
make_attr(Total,Mask,SuspsList1,NewAttr1),
substitute(Susps,SuspsList,[Susp],SuspsList2),
make_attr(Total,NewMask,SuspsList2,NewAttr2),
copy_term(SuspsList,SuspsList3),
nth(Position,SuspsList3,[Susp]),
chr_delete(SuspsList3,[Susp],RestSuspsList),
set_elems(RestSuspsList,[]),
make_attr(Total,Pattern,SuspsList3,NewAttr3),
get_target_module(Mod),
Body =
(
( get_attr(Var,Mod,TAttr) ->
TAttr = Attr,
( Mask /\ Pattern =:= Pattern ->
put_attr(Var, Mod, NewAttr1)
;
NewMask is Mask \/ Pattern,
put_attr(Var, Mod, NewAttr2)
)
;
put_attr(Var,Mod,NewAttr3)
),
RecursiveCall
),
Clause = (Head :- Body).
%% detach_$CONSTRAINT
generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
generate_detach_a_constraint_empty_list(Constraint,Clause1),
get_max_constraint_index(N),
( N == 1 ->
generate_detach_a_constraint_1_1(Constraint,Clause2)
;
generate_detach_a_constraint_t_p(Constraint,Clause2)
).
generate_detach_a_constraint_empty_list(CFct / CAty,Clause) :-
atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
Args = [[],_],
Head =.. [Fct | Args],
Clause = ( Head :- true).
generate_detach_a_constraint_1_1(CFct / CAty,Clause) :-
atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
Args = [[Var|Vars],Susp],
Head =.. [Fct | Args],
RecursiveCall =.. [Fct,Vars,Susp],
get_target_module(Mod),
Body =
(
( get_attr(Var,Mod,Susps) ->
'chr sbag_del_element'(Susps,Susp,NewSusps),
( NewSusps == [] ->
del_attr(Var,Mod)
;
put_attr(Var,Mod,NewSusps)
)
;
true
),
RecursiveCall
),
Clause = (Head :- Body).
generate_detach_a_constraint_t_p(CFct / CAty,Clause) :-
atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
Args = [[Var|Vars],Susp],
Head =.. [Fct | Args],
RecursiveCall =.. [Fct,Vars,Susp],
get_constraint_index(CFct/CAty,Position),
or_pattern(Position,Pattern),
and_pattern(Position,DelPattern),
get_max_constraint_index(Total),
make_attr(Total,Mask,SuspsList,Attr),
nth(Position,SuspsList,Susps),
substitute(Susps,SuspsList,[],SuspsList1),
make_attr(Total,NewMask,SuspsList1,Attr1),
substitute(Susps,SuspsList,NewSusps,SuspsList2),
make_attr(Total,Mask,SuspsList2,Attr2),
get_target_module(Mod),
Body =
(
( get_attr(Var,Mod,TAttr) ->
TAttr = Attr,
( Mask /\ Pattern =:= Pattern ->
'chr sbag_del_element'(Susps,Susp,NewSusps),
( NewSusps == [] ->
NewMask is Mask /\ DelPattern,
( NewMask == 0 ->
del_attr(Var,Mod)
;
put_attr(Var,Mod,Attr1)
)
;
put_attr(Var,Mod,Attr2)
)
;
true
)
;
true
),
RecursiveCall
),
Clause = (Head :- Body).
%% detach_$CONSTRAINT
generate_attach_increment([Clause1,Clause2]) :-
generate_attach_increment_empty(Clause1),
get_max_constraint_index(N),
( N == 1 ->
generate_attach_increment_one(Clause2)
;
generate_attach_increment_many(N,Clause2)
).
generate_attach_increment_empty((attach_increment([],_) :- true)).
generate_attach_increment_one(Clause) :-
Head = attach_increment([Var|Vars],Susps),
get_target_module(Mod),
Body =
(
'chr not_locked'(Var),
( get_attr(Var,Mod,VarSusps) ->
sort(VarSusps,SortedVarSusps),
merge(Susps,SortedVarSusps,MergedSusps),
put_attr(Var,Mod,MergedSusps)
;
put_attr(Var,Mod,Susps)
),
attach_increment(Vars,Susps)
),
Clause = (Head :- Body).
generate_attach_increment_many(N,Clause) :-
make_attr(N,Mask,SuspsList,Attr),
make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
Head = attach_increment([Var|Vars],Attr),
bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
list2conj(Gs,SortGoals),
bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
make_attr(N,MergedMask,MergedSuspsList,NewAttr),
get_target_module(Mod),
Body =
(
'chr not_locked'(Var),
( get_attr(Var,Mod,TOtherAttr) ->
TOtherAttr = OtherAttr,
SortGoals,
MergedMask is Mask \/ OtherMask,
put_attr(Var,Mod,NewAttr)
;
put_attr(Var,Mod,Attr)
),
attach_increment(Vars,Attr)
),
Clause = (Head :- Body).
%% attr_unify_hook
generate_attr_unify_hook([Clause]) :-
get_max_constraint_index(N),
( N == 1 ->
generate_attr_unify_hook_one(Clause)
;
generate_attr_unify_hook_many(N,Clause)
).
generate_attr_unify_hook_one(Clause) :-
Head = Mod:attr_unify_hook(Susps,Other),
get_target_module(Mod),
make_run_suspensions(NewSusps,WakeNewSusps),
make_run_suspensions(Susps,WakeSusps),
Body =
(
sort(Susps, SortedSusps),
( var(Other) ->
( get_attr(Other,Mod,OtherSusps) ->
true
;
OtherSusps = []
),
sort(OtherSusps,SortedOtherSusps),
'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
put_attr(Other,Mod,NewSusps),
WakeNewSusps
;
( compound(Other) ->
term_variables(Other,OtherVars),
attach_increment(OtherVars, SortedSusps)
;
true
),
WakeSusps
)
),
Clause = (Head :- Body).
generate_attr_unify_hook_many(N,Clause) :-
make_attr(N,Mask,SuspsList,Attr),
make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
list2conj(SortGoalList,SortGoals),
bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
C = (sort(E,F),
'chr merge_attributes'(D,F,G)) ),
SortMergeGoalList),
bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
list2conj(SortMergeGoalList,SortMergeGoals),
make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
make_attr(N,Mask,SortedSuspsList,SortedAttr),
Head = Mod:attr_unify_hook(Attr,Other),
get_target_module(Mod),
make_run_suspensions_loop(MergedSuspsList,WakeMergedSusps),
make_run_suspensions_loop(SortedSuspsList,WakeSortedSusps),
Body =
(
SortGoals,
( var(Other) ->
( get_attr(Other,Mod,TOtherAttr) ->
TOtherAttr = OtherAttr,
SortMergeGoals,
MergedMask is Mask \/ OtherMask,
put_attr(Other,Mod,MergedAttr),
WakeMergedSusps
;
put_attr(Other,Mod,SortedAttr),
WakeSortedSusps
)
;
( compound(Other) ->
term_variables(Other,OtherVars),
attach_increment(OtherVars,SortedAttr)
;
true
),
WakeSortedSusps
)
),
Clause = (Head :- Body).
make_run_suspensions(Susps,Goal) :-
( chr_pp_flag(debugable,on) ->
Goal = 'chr run_suspensions_d'(Susps)
;
Goal = 'chr run_suspensions'(Susps)
).
make_run_suspensions_loop(SuspsList,Goal) :-
( chr_pp_flag(debugable,on) ->
Goal = 'chr run_suspensions_loop_d'(SuspsList)
;
Goal = 'chr run_suspensions_loop'(SuspsList)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
check_attachments(Rules) :-
( chr_pp_flag(check_attachments,on) ->
check_attachments_(Rules)
;
true
).
check_attachments_([]).
check_attachments_([R|Rs]) :-
check_attachment(R),
check_attachments_(Rs).
check_attachment(R) :-
R = pragma(Rule,_,_,_),
Rule = rule(H1,H2,G,B),
check_attachment_heads1(H1,H1,H2,G),
check_attachment_heads2(H2,H1,B).
check_attachment_heads1([],_,_,_).
check_attachment_heads1([C|Cs],H1,H2,G) :-
functor(C,F,A),
( H1 == [C],
H2 == [],
G == true,
C =.. [_|L],
no_matching(L,[]) ->
attached(F/A,no)
;
attached(F/A,maybe)
),
check_attachment_heads1(Cs,H1,H2,G).
no_matching([],_).
no_matching([X|Xs],Prev) :-
var(X),
\+ memberchk_eq(X,Prev),
no_matching(Xs,[X|Prev]).
check_attachment_heads2([],_,_).
check_attachment_heads2([C|Cs],H1,B) :-
functor(C,F,A),
( H1 \== [],
B == true ->
attached(F/A,maybe)
;
attached(F/A,yes)
),
check_attachment_heads2(Cs,H1,B).
all_attached([]).
all_attached([C|Cs]) :-
functor(C,F,A),
is_attached(F/A),
all_attached(Cs).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
set_constraint_indices([],M) :-
N is M - 1,
max_constraint_index(N).
set_constraint_indices([C|Cs],N) :-
( is_attached(C) ->
constraint_index(C,N),
M is N + 1,
set_constraint_indices(Cs,M)
;
set_constraint_indices(Cs,N)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ____ _ ____ _ _ _ _
%% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
%% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
%% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
%% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
%% |_|
constraints_code(Constraints,Rules,Clauses) :-
post_constraints(Constraints,1),
constraints_code1(1,Rules,L,[]),
clean_clauses(L,Clauses).
%% Add global data
post_constraints([],MaxIndex1) :-
MaxIndex is MaxIndex1 - 1,
constraint_count(MaxIndex).
post_constraints([F/A|Cs],N) :-
constraint(F/A,N),
M is N + 1,
post_constraints(Cs,M).
constraints_code1(I,Rules,L,T) :-
constraint_count(N),
( I > N ->
T = L
;
constraint_code(I,Rules,L,T1),
J is I + 1,
constraints_code1(J,Rules,T1,T)
).
%% Generate code for a single CHR constraint
constraint_code(I, Rules, L, T) :-
constraint(Constraint,I),
constraint_prelude(Constraint,Clause),
L = [Clause | L1],
Id1 = [0],
rules_code(Rules,1,I,Id1,Id2,L1,L2),
gen_cond_attach_clause(Constraint,Id2,L2,T).
%% Generate prelude predicate for a constraint.
%% f(...) :- f/a_0(...,Susp).
constraint_prelude(F/A, Clause) :-
vars_susp(A,Vars,Susp,VarsSusp),
Head =.. [ F | Vars],
build_head(F,A,[0],VarsSusp,Delegate),
get_target_module(Mod),
( chr_pp_flag(debugable,on) ->
Clause =
( Head :-
'chr allocate_constraint'(Mod : Delegate, Susp, F, Vars),
(
'chr debug_event'(call(Susp)),
Delegate
;
'chr debug_event'(fail(Susp)), !,
fail
),
(
'chr debug_event'(exit(Susp))
;
'chr debug_event'(redo(Susp)),
fail
)
)
;
Clause = ( Head :- Delegate )
).
gen_cond_attach_clause(F/A,Id,L,T) :-
( is_attached(F/A) ->
( Id == [0] ->
gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
; vars_susp(A,Args,Susp,AllArgs),
gen_uncond_attach_goal(F/A,Susp,Body,_)
),
( chr_pp_flag(debugable,on) ->
Constraint =.. [F|Args],
DebugEvent = 'chr debug_event'(insert(Constraint#Susp))
;
DebugEvent = true
),
build_head(F,A,Id,AllArgs,Head),
Clause = ( Head :- DebugEvent,Body ),
L = [Clause | T]
;
L = T
).
gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
vars_susp(A,Args,Susp,AllArgs),
build_head(F,A,[0],AllArgs,Closure),
atom_concat_list(['attach_',F, (/) ,A],AttachF),
Attach =.. [AttachF,Vars,Susp],
get_target_module(Mod),
Goal =
(
( var(Susp) ->
'chr insert_constraint_internal'(Vars,Susp,Mod:Closure,F,Args)
;
'chr activate_constraint'(Vars,Susp,_)
),
Attach
).
gen_uncond_attach_goal(F/A,Susp,AttachGoal,Generation) :-
atom_concat_list(['attach_',F, (/) ,A],AttachF),
Attach =.. [AttachF,Vars,Susp],
AttachGoal =
(
'chr activate_constraint'(Vars, Susp, Generation),
Attach
).
%% Generate all the code for a constraint based on all CHR rules
rules_code([],_,_,Id,Id,L,L).
rules_code([R |Rs],RuleNb,I,Id1,Id3,L,T) :-
rule_code(R,RuleNb,I,Id1,Id2,L,T1),
NextRuleNb is RuleNb + 1,
rules_code(Rs,NextRuleNb,I,Id2,Id3,T1,T).
%% Generate code for a constraint based on a single CHR rule
rule_code(PragmaRule,RuleNb,I,Id1,Id2,L,T) :-
PragmaRule = pragma(Rule,HeadIDs,_Pragmas,_Name),
HeadIDs = ids(Head1IDs,Head2IDs),
Rule = rule(Head1,Head2,_,_),
heads1_code(Head1,[],Head1IDs,[],PragmaRule,I,Id1,L,L1),
heads2_code(Head2,[],Head2IDs,[],PragmaRule,RuleNb,I,Id1,Id2,L1,T).
%% Generate code based on all the removed heads of a CHR rule
heads1_code([],_,_,_,_,_,_,L,L).
heads1_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id,L,T) :-
PragmaRule = pragma(Rule,_,Pragmas,_Name),
constraint(F/A,I),
( functor(Head,F,A),
\+ check_unnecessary_active(Head,RestHeads,Rule),
\+ memberchk_eq(passive(HeadID),Pragmas),
all_attached(Heads),
all_attached(RestHeads),
Rule = rule(_,Heads2,_,_),
all_attached(Heads2) ->
append(Heads,RestHeads,OtherHeads),
append(HeadIDs,RestIDs,OtherIDs),
head1_code(Head,OtherHeads,OtherIDs,PragmaRule,F/A,I,Id,L,L1)
;
L = L1
),
heads1_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id,L1,T).
%% Generate code based on one removed head of a CHR rule
head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,Id,L,T) :-
PragmaRule = pragma(Rule,_,_,_Name),
Rule = rule(_,Head2,_,_),
( Head2 == [] ->
reorder_heads(Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,Id,L,T)
;
simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
).
%% Generate code based on all the persistent heads of a CHR rule
heads2_code([],_,_,_,_,_,_,Id,Id,L,L).
heads2_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,RuleNb,I,Id1,Id3,L,T) :-
PragmaRule = pragma(Rule,_,Pragmas,_Name),
constraint(F/A,I),
( functor(Head,F,A),
\+ check_unnecessary_active(Head,RestHeads,Rule),
\+ memberchk_eq(passive(HeadID),Pragmas),
\+ set_semantics_rule(PragmaRule),
all_attached(Heads),
all_attached(RestHeads),
Rule = rule(Heads1,_,_,_),
all_attached(Heads1) ->
append(Heads,RestHeads,OtherHeads),
append(HeadIDs,RestIDs,OtherIDs),
length(Heads,RestHeadNb),
head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RuleNb,RestHeadNb,F/A,Id1,L,L0),
inc_id(Id1,Id2),
gen_alloc_inc_clause(F/A,Id1,L0,L1)
;
L = L1,
Id2 = Id1
),
heads2_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,RuleNb,I,Id2,Id3,L1,T).
%% Generate code based on one persistent head of a CHR rule
head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RuleNb,RestHeadNb,FA,Id,L,T) :-
PragmaRule = pragma(Rule,_,_,_Name),
Rule = rule(Head1,_,_,_),
( Head1 == [] ->
reorder_heads(Head,OtherHeads,NOtherHeads),
propagation_code(Head,NOtherHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
;
simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
).
gen_alloc_inc_clause(F/A,Id,L,T) :-
vars_susp(A,Vars,Susp,VarsSusp),
build_head(F,A,Id,VarsSusp,Head),
inc_id(Id,IncId),
build_head(F,A,IncId,VarsSusp,CallHead),
( Id == [0] ->
gen_cond_allocation(Vars,Susp,F/A,VarsSusp,ConditionalAlloc)
;
ConditionalAlloc = true
),
Clause =
(
Head :-
ConditionalAlloc,
CallHead
),
L = [Clause|T].
gen_cond_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal) :-
build_head(F,A,[0],VarsSusp,Term),
get_target_module(Mod),
ConstraintAllocationGoal =
( var(Susp) ->
'chr allocate_constraint'(Mod : Term, Susp, F, Vars)
;
true
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :-
( chr_pp_flag(guard_via_reschedule,on) ->
guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal)
;
append(Retrievals,GuardList,GoalList),
list2conj(GoalList,Goal)
).
guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :-
initialize_unit_dictionary(Prelude,Dict),
build_units(Retrievals,GuardList,Dict,Units),
dependency_reorder(Units,NUnits),
units2goal(NUnits,Goal).
units2goal([],true).
units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :-
units2goal(Units,Goals).
dependency_reorder(Units,NUnits) :-
dependency_reorder(Units,[],NUnits).
dependency_reorder([],Acc,Result) :-
reverse(Acc,Result).
dependency_reorder([Unit|Units],Acc,Result) :-
Unit = unit(_GID,_Goal,Type,GIDs),
( Type == fixed ->
NAcc = [Unit|Acc]
;
dependency_insert(Acc,Unit,GIDs,NAcc)
),
dependency_reorder(Units,NAcc,Result).
dependency_insert([],Unit,_,[Unit]).
dependency_insert([X|Xs],Unit,GIDs,L) :-
X = unit(GID,_,_,_),
( memberchk(GID,GIDs) ->
L = [Unit,X|Xs]
;
L = [X | T],
dependency_insert(Xs,Unit,GIDs,T)
).
build_units(Retrievals,Guard,InitialDict,Units) :-
build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
build_guard_units(Guard,N,Dict,Tail).
build_retrieval_units([],N,N,Dict,Dict,L,L).
build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
term_variables(U,Vs),
update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
L = [unit(N,U,movable,GIDs)|L1],
N1 is N + 1,
build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T).
build_retrieval_units2([],N,N,Dict,Dict,L,L).
build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :-
term_variables(U,Vs),
update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
L = [unit(N,U,fixed,GIDs)|L1],
N1 is N + 1,
build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
initialize_unit_dictionary(Term,Dict) :-
term_variables(Term,Vars),
pair_all_with(Vars,0,Dict).
update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
( lookup_eq(Dict,V,GID) ->
( (GID == This ; memberchk(GID,GIDs) ) ->
GIDs1 = GIDs
;
GIDs1 = [GID|GIDs]
),
Dict1 = Dict
;
Dict1 = [V - This|Dict],
GIDs1 = GIDs
),
update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
build_guard_units(Guard,N,Dict,Units) :-
( Guard = [Goal] ->
Units = [unit(N,Goal,fixed,[])]
; Guard = [Goal|Goals] ->
term_variables(Goal,Vs),
update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
Units = [unit(N,Goal,movable,GIDs)|RUnits],
N1 is N + 1,
build_guard_units(Goals,N1,NDict,RUnits)
).
update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
( lookup_eq(Dict,V,GID) ->
( (GID == This ; memberchk(GID,GIDs) ) ->
GIDs1 = GIDs
;
GIDs1 = [GID|GIDs]
),
Dict1 = [V - This|Dict]
;
Dict1 = [V - This|Dict],
GIDs1 = GIDs
),
update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ____ _ ____ _ _
%% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
%% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
%% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
%% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
%%
%% _ _ _ ___ __
%% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
%% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
%% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
%% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
%% |_|
unique_analyse_optimise(Rules,NRules) :-
( chr_pp_flag(unique_analyse_optimise,on) ->
unique_analyse_optimise_main(Rules,1,[],NRules)
;
NRules = Rules
).
unique_analyse_optimise_main([],_,_,[]).
unique_analyse_optimise_main([PRule|PRules],N,PatternList,[NPRule|NPRules]) :-
( discover_unique_pattern(PRule,N,Pattern) ->
NPatternList = [Pattern|PatternList]
;
NPatternList = PatternList
),
PRule = pragma(Rule,Ids,Pragmas,Name),
Rule = rule(H1,H2,_,_),
Ids = ids(Ids1,Ids2),
apply_unique_patterns_to_constraints(H1,Ids1,NPatternList,MorePragmas1),
apply_unique_patterns_to_constraints(H2,Ids2,NPatternList,MorePragmas2),
append_lists([MorePragmas1,MorePragmas2,Pragmas],NPragmas),
NPRule = pragma(Rule,Ids,NPragmas,Name),
N1 is N + 1,
unique_analyse_optimise_main(PRules,N1,NPatternList,NPRules).
apply_unique_patterns_to_constraints([],_,_,[]).
apply_unique_patterns_to_constraints([C|Cs],[Id|Ids],Patterns,Pragmas) :-
( member(Pattern,Patterns),
apply_unique_pattern(C,Id,Pattern,Pragma) ->
Pragmas = [Pragma | RPragmas]
;
Pragmas = RPragmas
),
apply_unique_patterns_to_constraints(Cs,Ids,Patterns,RPragmas).
apply_unique_pattern(Constraint,Id,Pattern,Pragma) :-
Pattern = unique(PatternConstraint,PatternKey),
subsumes(Constraint,PatternConstraint,Unifier),
( setof( V,
T^Term^Vs^(
member(T,PatternKey),
lookup_eq(Unifier,T,Term),
term_variables(Term,Vs),
member(V,Vs)
),
Vars) ->
true
;
Vars = []
),
Pragma = unique(Id,Vars).
% subsumes(+Term1, +Term2, -Unifier)
%
% If Term1 is a more general term than Term2 (e.g. has a larger
% part instantiated), unify Unifier with a list Var-Value of
% variables from Term2 and their corresponding values in Term1.
subsumes(Term1,Term2,Unifier) :-
empty_assoc(S0),
subsumes_aux(Term1,Term2,S0,S),
assoc_to_list(S,L),
build_unifier(L,Unifier).
subsumes_aux(Term1, Term2, S0, S) :-
( compound(Term2),
functor(Term2, F, N)
-> compound(Term1), functor(Term1, F, N),
subsumes_aux(N, Term1, Term2, S0, S)
; Term1 == Term2
-> S = S0
; var(Term2),
get_assoc(Term1,S0,V)
-> V == Term2, S = S0
; var(Term2),
put_assoc(Term1, S0, Term2, S)
).
subsumes_aux(0, _, _, S, S) :- ! .
subsumes_aux(N, T1, T2, S0, S) :-
arg(N, T1, T1x),
arg(N, T2, T2x),
subsumes_aux(T1x, T2x, S0, S1),
M is N-1,
subsumes_aux(M, T1, T2, S1, S).
build_unifier([],[]).
build_unifier([X-V|R],[V - X | T]) :-
build_unifier(R,T).
discover_unique_pattern(PragmaRule,RuleNb,Pattern) :-
PragmaRule = pragma(Rule,_,Pragmas,Name),
( Rule = rule([C1],[C2],Guard,Body) ->
true
;
Rule = rule([C1,C2],[],Guard,Body)
),
check_unique_constraints(C1,C2,Guard,Body,Pragmas,List),
term_variables(C1,Vs),
select_pragma_unique_variables(List,Vs,Key),
Pattern0 = unique(C1,Key),
copy_term(Pattern0,Pattern),
( prolog_flag(verbose,V), V == yes ->
format('Found unique pattern ~w in rule ~d~@\n',
[Pattern,RuleNb,(Name=yes(N) -> write(": "),write(N) ; true)])
;
true
).
select_pragma_unique_variables([],_,[]).
select_pragma_unique_variables([X-Y|R],Vs,L) :-
( X == Y ->
L = [X|T]
;
once((
\+ memberchk_eq(X,Vs)
;
\+ memberchk_eq(Y,Vs)
)),
L = T
),
select_pragma_unique_variables(R,Vs,T).
check_unique_constraints(C1,C2,G,_Body,Pragmas,List) :-
\+ member(passive(_),Pragmas),
variable_replacement(C1-C2,C2-C1,List),
copy_with_variable_replacement(G,OtherG,List),
negate(G,NotG),
once(entails(NotG,OtherG)).
negate(true,fail).
negate(fail,true).
negate(X =< Y, Y < X).
negate(X > Y, Y >= X).
negate(X >= Y, Y > X).
negate(X < Y, Y =< X).
negate(var(X),nonvar(X)).
negate(nonvar(X),var(X)).
entails(X,X1) :- X1 == X.
entails(fail,_).
entails(X > Y, X1 >= Y1) :- X1 == X, Y1 == Y.
entails(X < Y, X1 =< Y1) :- X1 == X, Y1 == Y.
entails(ground(X),nonvar(X1)) :- X1 == X.
entails(compound(X),nonvar(X1)) :- X1 == X.
entails(atomic(X),nonvar(X1)) :- X1 == X.
entails(number(X),nonvar(X1)) :- X1 == X.
entails(atom(X),nonvar(X1)) :- X1 == X.
check_unnecessary_active(Constraint,Previous,Rule) :-
( chr_pp_flag(check_unnecessary_active,full) ->
check_unnecessary_active_main(Constraint,Previous,Rule)
; chr_pp_flag(check_unnecessary_active,simplification),
Rule = rule(_,[],_,_) ->
check_unnecessary_active_main(Constraint,Previous,Rule)
;
fail
).
check_unnecessary_active_main(Constraint,Previous,Rule) :-
member(Other,Previous),
variable_replacement(Other,Constraint,List),
copy_with_variable_replacement(Rule,Rule2,List),
identical_rules(Rule,Rule2), ! .
set_semantics_rule(PragmaRule) :-
( chr_pp_flag(set_semantics_rule,on) ->
set_semantics_rule_main(PragmaRule)
;
fail
).
set_semantics_rule_main(PragmaRule) :-
PragmaRule = pragma(Rule,IDs,Pragmas,_),
Rule = rule([C1],[C2],true,_),
IDs = ids([ID1],[ID2]),
once(member(unique(ID1,L1),Pragmas)),
once(member(unique(ID2,L2),Pragmas)),
L1 == L2,
\+ memberchk_eq(passive(ID1),Pragmas).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ____ _ _____ _ _
%% | _ \ _ _| | ___ | ____|__ _ _ _(_)_ ____ _| | ___ _ __ ___ ___
%% | |_) | | | | |/ _ \ | _| / _` | | | | \ \ / / _` | |/ _ \ '_ \ / __/ _ \
%% | _ <| |_| | | __/ | |__| (_| | |_| | |\ V / (_| | | __/ | | | (_| __/
%% |_| \_\\__,_|_|\___| |_____\__, |\__,_|_| \_/ \__,_|_|\___|_| |_|\___\___|
%% |_|
% have to check for no duplicates in value list
% check wether two rules are identical
identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :-
G1 == G2,
identical_bodies(B1,B2),
permutation(H11,P1),
P1 == H12,
permutation(H21,P2),
P2 == H22.
identical_bodies(B1,B2) :-
( B1 = (X1 = Y1),
B2 = (X2 = Y2) ->
( X1 == X2,
Y1 == Y2
; X1 == Y2,
X2 == Y1
),
!
; B1 == B2
).
% replace variables in list
copy_with_variable_replacement(X,Y,L) :-
( var(X) ->
( lookup_eq(L,X,Y) ->
true
; X = Y
)
; functor(X,F,A),
functor(Y,F,A),
X =.. [_|XArgs],
Y =.. [_|YArgs],
copy_with_variable_replacement_l(XArgs,YArgs,L)
).
copy_with_variable_replacement_l([],[],_).
copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :-
copy_with_variable_replacement(X,Y,L),
copy_with_variable_replacement_l(Xs,Ys,L).
%% build variable replacement list
variable_replacement(X,Y,L) :-
variable_replacement(X,Y,[],L).
variable_replacement(X,Y,L1,L2) :-
( var(X) ->
var(Y),
( lookup_eq(L1,X,Z) ->
Z == Y,
L2 = L1
; L2 = [X-Y|L1]
)
; X =.. [F|XArgs],
nonvar(Y),
Y =.. [F|YArgs],
variable_replacement_l(XArgs,YArgs,L1,L2)
).
variable_replacement_l([],[],L,L).
variable_replacement_l([X|Xs],[Y|Ys],L1,L3) :-
variable_replacement(X,Y,L1,L2),
variable_replacement_l(Xs,Ys,L2,L3).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ____ _ _ _ __ _ _ _
%% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
%% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
%% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
%% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
%% |_|
simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,Id,L,T) :-
PragmaRule = pragma(Rule,_,Pragmas,_),
head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
build_head(F,A,Id,HeadVars,ClauseHead),
head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
( RestHeads == [] ->
Susps = [],
VarDict = VarDict1,
GetRestHeads = []
;
rest_heads_retrieval_and_matching(RestHeads,RestIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict)
),
guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
gen_cond_susp_detachment(Susp,F/A,SuspDetachment),
( chr_pp_flag(debugable,on) ->
Rule = rule(_,_,Guard,Body),
my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
DebugTry = 'chr debug_event'( try([Susp|RestSusps],[],DebugGuard,DebugBody)),
DebugApply = 'chr debug_event'(apply([Susp|RestSusps],[],DebugGuard,DebugBody))
;
DebugTry = true,
DebugApply = true
),
Clause = ( ClauseHead :-
FirstMatching,
RescheduledTest,
DebugTry,
!,
DebugApply,
SuspsDetachments,
SuspDetachment,
BodyCopy
),
L = [Clause | T].
head_arg_matches(Pairs,VarDict,Goal,NVarDict) :-
head_arg_matches_(Pairs,VarDict,GoalList,NVarDict),
list2conj(GoalList,Goal).
head_arg_matches_([],VarDict,[],VarDict).
head_arg_matches_([Arg-Var| Rest],VarDict,GoalList,NVarDict) :-
( var(Arg) ->
( lookup_eq(VarDict,Arg,OtherVar) ->
GoalList = [Var == OtherVar | RestGoalList],
VarDict1 = VarDict
; VarDict1 = [Arg-Var | VarDict],
GoalList = RestGoalList
),
Pairs = Rest
; atomic(Arg) ->
GoalList = [ Var == Arg | RestGoalList],
VarDict = VarDict1,
Pairs = Rest
; Arg =.. [_|Args],
functor(Arg,Fct,N),
functor(Term,Fct,N),
Term =.. [_|Vars],
GoalList =[ nonvar(Var), Var = Term | RestGoalList ],
pairup(Args,Vars,NewPairs),
append(NewPairs,Rest,Pairs),
VarDict1 = VarDict
),
head_arg_matches_(Pairs,VarDict1,RestGoalList,NVarDict).
rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict):-
rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,[],[],[]).
rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
( Heads = [_|_] ->
rest_heads_retrieval_and_matching_n(Heads,IDs,Pragmas,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict)
;
GoalList = [],
Susps = [],
VarDict = NVarDict
).
rest_heads_retrieval_and_matching_n([],_,_,_,_,_,[],[],VarDict,VarDict,AttrDict) :-
instantiate_pattern_goals(AttrDict).
rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,ActiveHead,[ViaGoal,Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict) :-
passive_head_via(H,[ActiveHead|PrevHs],AttrDict,VarDict,ViaGoal,Attr,NewAttrDict),
functor(H,Fct,Aty),
head_info(H,Aty,Vars,_,_,Pairs),
head_arg_matches(Pairs,VarDict,MatchingGoal,VarDict1),
Suspension =.. [suspension,_,State,_,_,_,_|Vars],
get_max_constraint_index(N),
( N == 1 ->
VarSusps = Attr
;
get_constraint_index(Fct/Aty,Pos),
make_attr(N,_Mask,SuspsList,Attr),
nth(Pos,SuspsList,VarSusps)
),
different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
create_get_mutable(active,State,GetMutable),
Goal1 =
(
'chr sbag_member'(Susp,VarSusps),
Susp = Suspension,
GetMutable,
DiffSuspGoals,
MatchingGoal
),
( member(unique(ID,UniqueKeus),Pragmas),
check_unique_keys(UniqueKeus,VarDict) ->
Goal = (Goal1 -> true)
;
Goal = Goal1
),
rest_heads_retrieval_and_matching_n(Hs,IDs,Pragmas,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,NewAttrDict).
instantiate_pattern_goals([]).
instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest]) :-
get_max_constraint_index(N),
( N == 1 ->
Goal = true
;
make_attr(N,Mask,_,Attr),
or_list(Bits,Pattern), !,
Goal = (Mask /\ Pattern =:= Pattern)
),
instantiate_pattern_goals(Rest).
check_unique_keys([],_).
check_unique_keys([V|Vs],Dict) :-
lookup_eq(Dict,V,_),
check_unique_keys(Vs,Dict).
% Generates tests to ensure the found constraint differs from previously found constraints
different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
( bagof(DiffSuspGoal, Pos ^ ( nth(Pos,Heads,PreHead), \+ Head \= PreHead, nth(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
list2conj(DiffSuspGoalList,DiffSuspGoals)
;
DiffSuspGoals = true
).
passive_head_via(Head,PrevHeads,AttrDict,VarDict,Goal,Attr,NewAttrDict) :-
functor(Head,F,A),
get_constraint_index(F/A,Pos),
common_variables(Head,PrevHeads,CommonVars),
translate(CommonVars,VarDict,Vars),
or_pattern(Pos,Bit),
( permutation(Vars,PermutedVars),
lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) ->
member(Bit,Positions), !,
NewAttrDict = AttrDict,
Goal = true
;
Goal = (Goal1, PatternGoal),
gen_get_mod_constraints(Vars,Goal1,Attr),
NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict]
).
common_variables(T,Ts,Vs) :-
term_variables(T,V1),
term_variables(Ts,V2),
intersect_eq(V1,V2,Vs).
gen_get_mod_constraints(L,Goal,Susps) :-
get_target_module(Mod),
( L == [] ->
Goal =
( 'chr global_term_ref_1'(Global),
get_attr(Global,Mod,TSusps),
TSusps = Susps
)
;
( L = [A] ->
VIA = 'chr via_1'(A,V)
; ( L = [A,B] ->
VIA = 'chr via_2'(A,B,V)
; VIA = 'chr via'(L,V)
)
),
Goal =
( VIA,
get_attr(V,Mod,TSusps),
TSusps = Susps
)
).
guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
list2conj(GuardCopyList,GuardCopy).
guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
Rule = rule(_,_,Guard,Body),
conj2list(Guard,GuardList),
split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
term_variables(RestGuardList,GuardVars),
term_variables(RestGuardListCopyCore,GuardCopyVars),
( chr_pp_flag(guard_locks,on),
bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
X ^ (member(X,GuardVars), % X is a variable appearing in the original guard
lookup_eq(VarDict,X,Y), % translate X into new variable
memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
),
LocksUnlocks) ->
once(pairup(Locks,Unlocks,LocksUnlocks))
;
Locks = [],
Unlocks = []
),
list2conj(Locks,LockPhase),
list2conj(Unlocks,UnlockPhase),
list2conj(RestGuardListCopyCore,RestGuardCopyCore),
RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
my_term_copy(Body,VarDict2,BodyCopy).
split_off_simple_guard([],_,[],[]).
split_off_simple_guard([G|Gs],VarDict,S,C) :-
( simple_guard(G,VarDict) ->
S = [G|Ss],
split_off_simple_guard(Gs,VarDict,Ss,C)
;
S = [],
C = [G|Gs]
).
% simple guard: cheap and benign (does not bind variables)
simple_guard(var(_), _).
simple_guard(nonvar(_), _).
simple_guard(ground(_), _).
simple_guard(number(_), _).
simple_guard(atom(_), _).
simple_guard(integer(_), _).
simple_guard(float(_), _).
simple_guard(_ > _ , _).
simple_guard(_ < _ , _).
simple_guard(_ =< _, _).
simple_guard(_ >= _, _).
simple_guard(_ =:= _, _).
simple_guard(_ == _, _).
simple_guard(X is _, VarDict) :-
\+ lookup_eq(VarDict,X,_).
simple_guard((G1,G2),VarDict) :-
simple_guard(G1,VarDict),
simple_guard(G2,VarDict).
simple_guard(\+ G, VarDict) :-
simple_guard(G, VarDict).
my_term_copy(X,Dict,Y) :-
my_term_copy(X,Dict,_,Y).
my_term_copy(X,Dict1,Dict2,Y) :-
( var(X) ->
( lookup_eq(Dict1,X,Y) ->
Dict2 = Dict1
; Dict2 = [X-Y|Dict1]
)
; functor(X,XF,XA),
functor(Y,XF,XA),
X =.. [_|XArgs],
Y =.. [_|YArgs],
my_term_copy_list(XArgs,Dict1,Dict2,YArgs)
).
my_term_copy_list([],Dict,Dict,[]).
my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :-
my_term_copy(X,Dict1,Dict2,Y),
my_term_copy_list(Xs,Dict2,Dict3,Ys).
gen_cond_susp_detachment(Susp,FA,SuspDetachment) :-
( is_attached(FA) ->
gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
SuspDetachment =
( var(Susp) ->
true
; UnCondSuspDetachment
)
;
SuspDetachment = true
).
gen_uncond_susp_detachment(Susp,CFct/CAty,SuspDetachment) :-
( is_attached(CFct/CAty) ->
atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
Detach =.. [Fct,Vars,Susp],
( chr_pp_flag(debugable,on) ->
DebugEvent = 'chr debug_event'(remove(Susp))
;
DebugEvent = true
),
SuspDetachment =
(
DebugEvent,
'chr remove_constraint_internal'(Susp, Vars),
Detach
)
;
SuspDetachment = true
).
gen_uncond_susps_detachments([],[],true).
gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
functor(Term,F,A),
gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ____ _ _ _ _
%% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
%% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
%% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
%% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
%% |_| |___/
simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name),
Rule = rule(_Heads,Heads2,Guard,Body),
head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
build_head(F,A,Id,HeadVars,ClauseHead),
append(RestHeads,Heads2,Heads),
append(OtherIDs,Heads2IDs,IDs),
reorder_heads(Head,Heads,IDs,NHeads,NIDs),
rest_heads_retrieval_and_matching(NHeads,NIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict),
split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps2),
guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments),
gen_cond_susp_detachment(Susp,F/A,SuspDetachment),
( chr_pp_flag(debugable,on) ->
my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
DebugTry = 'chr debug_event'( try([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
DebugApply = 'chr debug_event'(apply([Susp|Susps1],Susps2,DebugGuard,DebugBody))
;
DebugTry = true,
DebugApply = true
),
Clause = ( ClauseHead :-
FirstMatching,
RescheduledTest,
DebugTry,
!,
DebugApply,
SuspsDetachments,
SuspDetachment,
BodyCopy
),
L = [Clause | T].
split_by_ids([],[],_,[],[]).
split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
( memberchk_eq(I,I1s) ->
S1s = [S | R1s],
S2s = R2s
;
S1s = R1s,
S2s = [S | R2s]
),
split_by_ids(Is,Ss,I1s,R1s,R2s).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ____ _ _ _ ____
%% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
%% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
%% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
%% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
%% |_| |___/
%% Genereate prelude + worker predicate
%% prelude calls worker
%% worker iterates over one type of removed constraints
simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,Id,L,T) :-
PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_Name),
Rule = rule(Heads1,_,Guard,Body),
reorder_heads(Head2,Heads1,IDs1,[Head1|RestHeads1],[ID1|RestIDs1]), % Heads1 = [Head1|RestHeads1],
% IDs1 = [ID1|RestIDs1],
simpagation_head2_prelude(Head2,Head1,[RestHeads2,Heads1,Guard,Body],FA,Id,L,L1),
extend_id(Id,Id2),
simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,RestIDs1,RestHeads2,RestIDs,Rule,Pragmas,FA,Id2,L1,T).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
simpagation_head2_prelude(Head,Head1,Rest,F/A,Id1,L,T) :-
head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
build_head(F,A,Id1,VarsSusp,ClauseHead),
head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
passive_head_via(Head1,[Head],[],VarDict,ModConstraintsGoal,Attr,AttrDict),
instantiate_pattern_goals(AttrDict),
get_max_constraint_index(N),
( N == 1 ->
AllSusps = Attr
;
functor(Head1,F1,A1),
get_constraint_index(F1/A1,Pos),
make_attr(N,_,SuspsList,Attr),
nth(Pos,SuspsList,AllSusps)
),
( Id1 == [0] -> % create suspension
gen_cond_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal)
; ConstraintAllocationGoal = true
),
extend_id(Id1,DelegateId),
extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
build_head(F,A,DelegateId,DelegateCallVars,Delegate),
PreludeClause =
( ClauseHead :-
FirstMatching,
ModConstraintsGoal,
!,
ConstraintAllocationGoal,
Delegate
),
L = [PreludeClause|T].
extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
Term =.. [_|Args],
delegate_variables(Term,Terms,VarDict,Args,Vars).
passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
term_variables(PrevTerms,PrevVars),
delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
term_variables(Term,V1),
term_variables(Terms,V2),
intersect_eq(V1,V2,V3),
list_difference_eq(V3,PrevVars,V4),
translate(V4,VarDict,Vars).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,FA,Id,L,T) :-
Rule = rule(_,_,Guard,Body),
simpagation_head2_worker_end(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],FA,Id,L,L1),
simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,FA,Id,L1,T).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,F/A,Id,L,T) :-
gen_var(OtherSusp),
gen_var(OtherSusps),
head_info(Head2,A,_Vars,Susp,VarsSusp,Head2Pairs),
head_arg_matches(Head2Pairs,[],_,VarDict1),
Rule = rule(_,_,Guard,Body),
extra_active_delegate_variables(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],VarDict1,ExtraVars),
append([[OtherSusp|OtherSusps]|VarsSusp],ExtraVars,HeadVars),
build_head(F,A,Id,HeadVars,ClauseHead),
functor(Head1,_OtherF,OtherA),
head_info(Head1,OtherA,OtherVars,_,_,Head1Pairs),
head_arg_matches(Head1Pairs,VarDict1,FirstMatching,VarDict2),
OtherSuspension =.. [suspension,_,OtherState,_,_,_,_|OtherVars],
create_get_mutable(active,OtherState,GetMutable),
IteratorSuspTest =
( OtherSusp = OtherSuspension,
GetMutable
),
( (RestHeads1 \== [] ; RestHeads2 \== []) ->
append(RestHeads1,RestHeads2,RestHeads),
append(IDs1,IDs2,IDs),
reorder_heads(Head1-Head2,RestHeads,IDs,NRestHeads,NIDs),
rest_heads_retrieval_and_matching(NRestHeads,NIDs,Pragmas,[Head1,Head2],RestSuspsRetrieval,Susps,VarDict2,VarDict,[Head1],[OtherSusp],[]),
split_by_ids(NIDs,Susps,IDs1,Susps1,Susps2)
; RestSuspsRetrieval = [],
Susps1 = [],
Susps2 = [],
VarDict = VarDict2
),
gen_uncond_susps_detachments([OtherSusp | Susps1],[Head1|RestHeads1],Susps1Detachments),
append([OtherSusps|VarsSusp],ExtraVars,RecursiveVars),
build_head(F,A,Id,RecursiveVars,RecursiveCall),
append([[]|VarsSusp],ExtraVars,RecursiveVars2),
build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,IteratorSuspTest,FirstMatching),RescheduledTest),
( BodyCopy \== true ->
gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
; Attachment = true,
ConditionalRecursiveCall = RecursiveCall,
ConditionalRecursiveCall2 = RecursiveCall2
),
( chr_pp_flag(debugable,on) ->
my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
;
DebugTry = true,
DebugApply = true
),
( member(unique(ID1,UniqueKeys), Pragmas),
check_unique_keys(UniqueKeys,VarDict1) ->
Clause =
( ClauseHead :-
( IteratorSuspTest,
FirstMatching ->
( RescheduledTest,
DebugTry ->
DebugApply,
Susps1Detachments,
Attachment,
BodyCopy,
ConditionalRecursiveCall2
;
RecursiveCall2
)
;
RecursiveCall
)
)
;
Clause =
( ClauseHead :-
( IteratorSuspTest,
FirstMatching,
RescheduledTest,
DebugTry ->
DebugApply,
Susps1Detachments,
Attachment,
BodyCopy,
ConditionalRecursiveCall
;
RecursiveCall
)
)
),
L = [Clause | T].
gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
length(Args,N),
Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
create_get_mutable(active,State,GetState),
create_get_mutable(Generation,NewGeneration,GetGeneration),
ConditionalCall =
( Susp = Suspension,
GetState,
GetGeneration ->
'chr update_mutable'(inactive,State),
Call
; true
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
simpagation_head2_worker_end(Head,Rest,F/A,Id,L,T) :-
head_info(Head,A,_Vars,_Susp,VarsSusp,Pairs),
head_arg_matches(Pairs,[],_,VarDict),
extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
append([[]|VarsSusp],ExtraVars,HeadVars),
build_head(F,A,Id,HeadVars,ClauseHead),
next_id(Id,ContinuationId),
build_head(F,A,ContinuationId,VarsSusp,ContinuationHead),
Clause = ( ClauseHead :- ContinuationHead ),
L = [Clause | T].
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ____ _ _
%% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
%% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
%% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
%% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
%% |_| |___/
propagation_code(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
( RestHeads == [] ->
propagation_single_headed(Head,Rule,RuleNb,FA,Id,L,T)
;
propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% Single headed propagation
%% everything in a single clause
propagation_single_headed(Head,Rule,RuleNb,F/A,Id,L,T) :-
head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
build_head(F,A,Id,VarsSusp,ClauseHead),
inc_id(Id,NextId),
build_head(F,A,NextId,VarsSusp,NextHead),
NextCall = NextHead,
head_arg_matches(HeadPairs,[],HeadMatching,VarDict),
guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
( Id == [0] ->
gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Allocation),
Allocation1 = Allocation
;
Allocation1 = true
),
gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
gen_state_cond_call(Susp,A,NextCall,Generation,ConditionalNextCall),
( chr_pp_flag(debugable,on) ->
Rule = rule(_,_,Guard,Body),
my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody))
;
DebugTry = true,
DebugApply = true
),
Clause = (
ClauseHead :-
HeadMatching,
Allocation1,
'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
GuardCopy,
DebugTry,
!,
DebugApply,
'chr extend_history'(Susp,RuleNb),
Attachment,
BodyCopy,
ConditionalNextCall
),
L = [Clause | T].
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% multi headed propagation
%% prelude + predicates to accumulate the necessary combinations of suspended
%% constraints + predicate to execute the body
propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
RestHeads = [First|Rest],
propagation_prelude(Head,RestHeads,Rule,FA,Id,L,L1),
extend_id(Id,ExtendedId),
propagation_nested_code(Rest,[First,Head],Rule,RuleNb,RestHeadNb,FA,ExtendedId,L1,T).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
propagation_prelude(Head,[First|Rest],Rule,F/A,Id,L,T) :-
head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
build_head(F,A,Id,VarsSusp,PreludeHead),
head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
Rule = rule(_,_,Guard,Body),
extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
passive_head_via(First,[Head],[],VarDict,FirstSuspGoal,Attr,AttrDict),
instantiate_pattern_goals(AttrDict),
get_max_constraint_index(N),
( N == 1 ->
Susps = Attr
;
functor(First,FirstFct,FirstAty),
make_attr(N,_Mask,SuspsList,Attr),
get_constraint_index(FirstFct/FirstAty,Pos),
nth(Pos,SuspsList,Susps)
),
( Id == [0] ->
gen_cond_allocation(Vars,Susp,F/A,VarsSusp,CondAllocation)
; CondAllocation = true
),
extend_id(Id,NestedId),
append([Susps|VarsSusp],ExtraVars,NestedVars),
build_head(F,A,NestedId,NestedVars,NestedHead),
NestedCall = NestedHead,
Prelude = (
PreludeHead :-
FirstMatching,
FirstSuspGoal,
!,
CondAllocation,
NestedCall
),
L = [Prelude|T].
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
propagation_nested_code([],[CurrentHead|PreHeads],Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
propagation_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L1,T).
propagation_nested_code([Head|RestHeads],PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
propagation_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
propagation_accumulator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
inc_id(Id,IncId),
propagation_nested_code(RestHeads,[Head|PreHeads],Rule,RuleNb,RestHeadNb,FA,IncId,L2,T).
propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,F/A,Id,L,T) :-
Rule = rule(_,_,Guard,Body),
get_prop_inner_loop_vars(PreHeads,[CurrentHead,Guard,Body],PreVarsAndSusps,VarDict1,Susp,RestSusps),
gen_var(OtherSusp),
gen_var(OtherSusps),
functor(CurrentHead,_OtherF,OtherA),
gen_vars(OtherA,OtherVars),
Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
create_get_mutable(active,State,GetMutable),
CurrentSuspTest = (
OtherSusp = Suspension,
GetMutable
),
ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
build_head(F,A,Id,ClauseVars,ClauseHead),
RecursiveVars = [OtherSusps|PreVarsAndSusps],
build_head(F,A,Id,RecursiveVars,RecursiveHead),
RecursiveCall = RecursiveHead,
CurrentHead =.. [_|OtherArgs],
pairup(OtherArgs,OtherVars,OtherPairs),
head_arg_matches(OtherPairs,VarDict1,Matching,VarDict),
different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
gen_uncond_attach_goal(F/A,Susp,Attach,Generation),
gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
history_susps(RestHeadNb,[OtherSusp|RestSusps],Susp,[],HistorySusps),
bagof('chr novel_production'(X,Y),( member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList),
list2conj(NovelProductionsList,NovelProductions),
Tuple =.. [t,RuleNb|HistorySusps],
( chr_pp_flag(debugable,on) ->
Rule = rule(_,_,Guard,Body),
my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
DebugTry = 'chr debug_event'( try([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody)),
DebugApply = 'chr debug_event'(apply([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody))
;
DebugTry = true,
DebugApply = true
),
Clause = (
ClauseHead :-
( CurrentSuspTest,
DiffSuspGoals,
Matching,
TupleVar = Tuple,
NovelProductions,
GuardCopy,
DebugTry ->
DebugApply,
'chr extend_history'(Susp,TupleVar),
Attach,
BodyCopy,
ConditionalRecursiveCall
; RecursiveCall
)
),
L = [Clause|T].
history_susps(Count,OtherSusps,Susp,Acc,HistorySusps) :-
( Count == 0 ->
reverse(OtherSusps,ReversedSusps),
append(ReversedSusps,[Susp|Acc],HistorySusps)
;
OtherSusps = [OtherSusp|RestOtherSusps],
NCount is Count - 1,
history_susps(NCount,RestOtherSusps,Susp,[OtherSusp|Acc],HistorySusps)
).
get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :-
!,
functor(Head,_F,A),
head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),
head_arg_matches(Pairs,[],_,VarDict),
extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
append(VarsSusp,ExtraVars,HeadVars).
get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :-
get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps),
functor(Head,_F,A),
gen_var(Susps),
head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
head_arg_matches(Pairs,VarDict,_,NVarDict),
passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
propagation_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
Rule = rule(_,_,Guard,Body),
gen_var_susp_list_for(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSusps,AllButFirst,FirstSusp),
Vars = [ [] | VarsAndSusps],
build_head(F,A,Id,Vars,Head),
( Id = [0|_] ->
next_id(Id,PrevId),
PrevVarsAndSusps = AllButFirst
;
dec_id(Id,PrevId),
PrevVarsAndSusps = [FirstSusp|AllButFirst]
),
build_head(F,A,PrevId,PrevVarsAndSusps,PrevHead),
PredecessorCall = PrevHead,
Clause = (
Head :-
PredecessorCall
),
L = [Clause | T].
gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
!,
functor(Head,_F,A),
head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
head_arg_matches(HeadPairs,[],_,VarDict),
extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
append(VarsSusp,ExtraVars,HeadVars).
gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
functor(Head,_F,A),
gen_var(Susps),
head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
head_arg_matches(HeadPairs,VarDict,_,NVarDict),
passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
append(HeadVars,[Susp,Susps|Rest],VarsSusps).
propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
Rule = rule(_,_,Guard,Body),
pre_vars_and_susps(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],PreVarsAndSusps,VarDict,PreSusps),
gen_var(OtherSusps),
functor(CurrentHead,_OtherF,OtherA),
gen_vars(OtherA,OtherVars),
head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
head_arg_matches(HeadPairs,VarDict,FirstMatching,VarDict1),
OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
create_get_mutable(active,State,GetMutable),
CurrentSuspTest = (
OtherSusp = OtherSuspension,
GetMutable,
DiffSuspGoals,
FirstMatching
),
functor(NextHead,NextF,NextA),
passive_head_via(NextHead,[CurrentHead|PreHeads],[],VarDict1,NextSuspGoal,Attr,AttrDict),
instantiate_pattern_goals(AttrDict),
get_max_constraint_index(N),
( N == 1 ->
NextSusps = Attr
;
get_constraint_index(NextF/NextA,Position),
make_attr(N,_Mask,SuspsList,Attr),
nth(Position,SuspsList,NextSusps)
),
inc_id(Id,NestedId),
ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
build_head(F,A,Id,ClauseVars,ClauseHead),
passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
build_head(F,A,NestedId,NestedVars,NestedHead),
RecursiveVars = [OtherSusps|PreVarsAndSusps],
build_head(F,A,Id,RecursiveVars,RecursiveHead),
Clause = (
ClauseHead :-
( CurrentSuspTest,
NextSuspGoal
->
NestedHead
; RecursiveHead
)
),
L = [Clause|T].
pre_vars_and_susps([Head],Terms,HeadVars,VarDict,[]) :-
!,
functor(Head,_F,A),
head_info(Head,A,_Vars,_Susp,VarsSusp,HeadPairs),
head_arg_matches(HeadPairs,[],_,VarDict),
extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
append(VarsSusp,ExtraVars,HeadVars).
pre_vars_and_susps([Head|Heads],Terms,NVSs,NVarDict,[Susp|Susps]) :-
pre_vars_and_susps(Heads,[Head|Terms],VSs,VarDict,Susps),
functor(Head,_F,A),
gen_var(NextSusps),
head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
head_arg_matches(HeadPairs,VarDict,_,NVarDict),
passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
append(HeadVars,[Susp,NextSusps|VSs],NVSs).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ____ _ _ _ _
%% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
%% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
%% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
%% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
%%
%% ____ _ _ _
%% | _ \ ___| |_ _ __(_) _____ ____ _| |
%% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
%% | _ < __/ |_| | | | __/\ V / (_| | |
%% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
%%
%% ____ _ _
%% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
%% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
%% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
%% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
%% |___/
reorder_heads(Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
( chr_pp_flag(reorder_heads,on) ->
reorder_heads_main(Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
;
NRestHeads = RestHeads,
NRestIDs = RestIDs
).
reorder_heads_main(Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
term_variables(Head,KnownVars),
reorder_heads1(RestHeads,RestIDs,KnownVars,NRestHeads,NRestIDs).
reorder_heads1(Heads,IDs,KnownVars,NHeads,NIDs) :-
( Heads == [] ->
NHeads = [],
NIDs = []
;
NHeads = [BestHead|BestTail],
NIDs = [BestID | BestIDs],
select_best_head(Heads,IDs,KnownVars,BestHead,BestID,RestHeads,RestIDs,NKnownVars),
reorder_heads1(RestHeads,RestIDs,NKnownVars,BestTail,BestIDs)
).
select_best_head(Heads,IDs,KnownVars,BestHead,BestID,RestHeads,RestIDs,NKnownVars) :-
( bagof(tuple(Score,Head,ID,Rest,RIDs), (
select2(Head,ID, Heads,IDs,Rest,RIDs) ,
order_score(Head,KnownVars,Rest,Score)
),
Scores) -> true ; Scores = []),
max_go_list(Scores,tuple(_,BestHead,BestID,RestHeads,RestIDs)),
term_variables(BestHead,BestHeadVars),
( setof(V, (
member(V,BestHeadVars),
\+ memberchk_eq(V,KnownVars)
),
NewVars) -> true ; NewVars = []),
append(NewVars,KnownVars,NKnownVars).
reorder_heads(Head,RestHeads,NRestHeads) :-
term_variables(Head,KnownVars),
reorder_heads1(RestHeads,KnownVars,NRestHeads).
reorder_heads1(Heads,KnownVars,NHeads) :-
( Heads == [] ->
NHeads = []
;
NHeads = [BestHead|BestTail],
select_best_head(Heads,KnownVars,BestHead,RestHeads,NKnownVars),
reorder_heads1(RestHeads,NKnownVars,BestTail)
).
select_best_head(Heads,KnownVars,BestHead,RestHeads,NKnownVars) :-
( bagof(tuple(Score,Head,Rest), (
select(Head,Heads,Rest) ,
order_score(Head,KnownVars,Rest,Score)
),
Scores) -> true ; Scores = []),
max_go_list(Scores,tuple(_,BestHead,RestHeads)),
term_variables(BestHead,BestHeadVars),
( setof(V, (
member(V,BestHeadVars),
\+ memberchk_eq(V,KnownVars)
),
NewVars) -> true ; NewVars = []),
append(NewVars,KnownVars,NKnownVars).
order_score(Head,KnownVars,Rest,Score) :-
term_variables(Head,HeadVars),
term_variables(Rest,RestVars),
order_score_vars(HeadVars,KnownVars,RestVars,0,Score).
order_score_vars([],_,_,Score,NScore) :-
( Score == 0 ->
NScore = 99999
;
NScore = Score
).
order_score_vars([V|Vs],KnownVars,RestVars,Score,NScore) :-
( memberchk_eq(V,KnownVars) ->
TScore is Score + 1
; memberchk_eq(V,RestVars) ->
TScore is Score + 1
;
TScore = Score
),
order_score_vars(Vs,KnownVars,RestVars,TScore,NScore).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ___ _ _ _
%% |_ _|_ __ | (_)_ __ (_)_ __ __ _
%% | || '_ \| | | '_ \| | '_ \ / _` |
%% | || | | | | | | | | | | | | (_| |
%% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
%% |___/
create_get_mutable(V,M,GM) :-
GM = (M = mutable(V)).
% GM = 'chr get_mutable'(V,M)
%( ground(V) ->
% GM = (M == mutable(V))
%;
% GM = (M = mutable(V))
%).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ____ _ ____ _ _
%% / ___|___ __| | ___ / ___| | ___ __ _ _ __ (_)_ __ __ _
%% | | / _ \ / _` |/ _ \ | | | |/ _ \/ _` | '_ \| | '_ \ / _` |
%% | |__| (_) | (_| | __/ | |___| | __/ (_| | | | | | | | | (_| |
%% \____\___/ \__,_|\___| \____|_|\___|\__,_|_| |_|_|_| |_|\__, |
%% |___/
%%
%% removes redundant 'true's and other trivial but potentially non-free constructs
clean_clauses([],[]).
clean_clauses([C|Cs],[NC|NCs]) :-
clean_clause(C,NC),
clean_clauses(Cs,NCs).
clean_clause(Clause,NClause) :-
( Clause = (Head :- Body) ->
clean_goal(Body,NBody),
( NBody == true ->
NClause = Head
;
NClause = (Head :- NBody)
)
;
NClause = Clause
).
clean_goal(Goal,NGoal) :-
var(Goal), !,
NGoal = Goal.
clean_goal((G1,G2),NGoal) :-
!,
clean_goal(G1,NG1),
clean_goal(G2,NG2),
( NG1 == true ->
NGoal = NG2
; NG2 == true ->
NGoal = NG1
;
NGoal = (NG1,NG2)
).
clean_goal((If -> Then ; Else),NGoal) :-
!,
clean_goal(If,NIf),
( NIf == true ->
clean_goal(Then,NThen),
NGoal = NThen
; NIf == fail ->
clean_goal(Else,NElse),
NGoal = NElse
;
clean_goal(Then,NThen),
clean_goal(Else,NElse),
NGoal = (NIf -> NThen; NElse)
).
clean_goal((G1 ; G2),NGoal) :-
!,
clean_goal(G1,NG1),
clean_goal(G2,NG2),
( NG1 == fail ->
NGoal = NG2
; NG2 == fail ->
NGoal = NG1
;
NGoal = (NG1 ; NG2)
).
clean_goal(once(G),NGoal) :-
!,
clean_goal(G,NG),
( NG == true ->
NGoal = true
; NG == fail ->
NGoal = fail
;
NGoal = once(NG)
).
clean_goal((G1 -> G2),NGoal) :-
!,
clean_goal(G1,NG1),
( NG1 == true ->
clean_goal(G2,NGoal)
; NG1 == fail ->
NGoal = fail
;
clean_goal(G2,NG2),
NGoal = (NG1 -> NG2)
).
clean_goal(Goal,Goal).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% _ _ _ _ _ _ _
%% | | | | |_(_) (_) |_ _ _
%% | | | | __| | | | __| | | |
%% | |_| | |_| | | | |_| |_| |
%% \___/ \__|_|_|_|\__|\__, |
%% |___/
gen_var(_).
gen_vars(N,Xs) :-
length(Xs,N).
head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
vars_susp(A,Vars,Susp,VarsSusp),
Head =.. [_|Args],
pairup(Args,Vars,HeadPairs).
inc_id([N|Ns],[O|Ns]) :-
O is N + 1.
dec_id([N|Ns],[M|Ns]) :-
M is N - 1.
extend_id(Id,[0|Id]).
next_id([_,N|Ns],[O|Ns]) :-
O is N + 1.
build_head(F,A,Id,Args,Head) :-
buildName(F,A,Id,Name),
Head =.. [Name|Args].
buildName(Fct,Aty,List,Result) :-
atom_concat(Fct, (/) ,FctSlash),
atom_concat(FctSlash,Aty,FctSlashAty),
buildName_(List,FctSlashAty,Result).
buildName_([],Name,Name).
buildName_([N|Ns],Name,Result) :-
buildName_(Ns,Name,Name1),
atom_concat(Name1,'__',NameDash), % '_' is a char :-(
atom_concat(NameDash,N,Result).
vars_susp(A,Vars,Susp,VarsSusp) :-
length(Vars,A),
append(Vars,[Susp],VarsSusp).
make_attr(N,Mask,SuspsList,Attr) :-
length(SuspsList,N),
Attr =.. [v,Mask|SuspsList].
or_pattern(Pos,Pat) :-
Pow is Pos - 1,
Pat is 1 << Pow. % was 2 ** X
and_pattern(Pos,Pat) :-
X is Pos - 1,
Y is 1 << X, % was 2 ** X
Pat is (-1)*(Y + 1). % because fx (-) is redefined
conj2list(Conj,L) :- %% transform conjunctions to list
conj2list(Conj,L,[]).
conj2list(Conj,L,T) :-
Conj = (G1,G2), !,
conj2list(G1,L,T1),
conj2list(G2,T1,T).
conj2list(G,[G | T],T).
list2conj([],true).
list2conj([G],X) :- !, X = G.
list2conj([G|Gs],C) :-
( G == true -> %% remove some redundant trues
list2conj(Gs,C)
;
C = (G,R),
list2conj(Gs,R)
).
atom_concat_list([X],X) :- ! .
atom_concat_list([X|Xs],A) :-
atom_concat_list(Xs,B),
atom_concat(X,B,A).
set_elems([],_).
set_elems([X|Xs],X) :-
set_elems(Xs,X).
member2([X|_],[Y|_],X-Y).
member2([_|Xs],[_|Ys],P) :-
member2(Xs,Ys,P).
select2(X, Y, [X|Xs], [Y|Ys], Xs, Ys).
select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :-
select2(X, Y, Xs, Ys, NXs, NYs).
pair_all_with([],_,[]).
pair_all_with([X|Xs],Y,[X-Y|Rest]) :-
pair_all_with(Xs,Y,Rest).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Reference in New Issue View Git Blame Copy Permalink