/* $Id: chr_translate.chr,v 1.2 2007-10-16 23:17:03 vsc Exp $ Part of CHR (Constraint Handling Rules) Author: Tom Schrijvers E-mail: Tom.Schrijvers@cs.kuleuven.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.be %% %% * based on the SICStus CHR compilation by Christian Holzbaur %% %% First working version: 6 June 2003 %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% OPEN BUGS %% %% URGENTLY TODO %% %% * add mode checking to debug mode %% * add groundness info to a.i.-based observation analysis %% * proper fd/index analysis %% * re-add generation checking %% * untangle CHR-level and target source-level generation & optimization %% %% AGGRESSIVE OPTIMISATION IDEAS %% %% * success continuation optimization %% * analyze history usage to determine whether/when %% cheaper suspension is possible: %% don't use history when all partners are passive and self never triggers %% * store constraint unconditionally for unconditional propagation rule, %% if first, i.e. without checking history and set trigger cont to next occ %% * get rid of suspension passing for never triggered constraints, %% up to allocation occurrence %% * get rid of call indirection for never triggered constraints %% up to first allocation occurrence. %% * get rid of unnecessary indirection if last active occurrence %% before unconditional removal is head2, e.g. %% a \ b <=> true. %% a <=> true. %% * Eliminate last clause of never stored constraint, if its body %% is fail, e.g. %% a ... %% a <=> fail. %% * Specialize lookup operations and indexes for functional dependencies. %% %% MORE TODO %% %% * generate code to empty all constraint stores of a module (Bart Demoen) %% * map A \ B <=> true | true rules %% onto efficient code that empties the constraint stores of B %% in O(1) time for ground constraints where A and B do not share %% any variables %% * ground matching seems to be not optimized for compound terms %% in case of simpagation_head2 and propagation occurrences %% * analysis for storage delaying (see primes for case) %% * internal constraints declaration + analyses? %% * Do not store in global variable store if not necessary %% NOTE: affects show_store/1 %% * var_assoc multi-level store: variable - ground %% * Do not maintain/check unnecessary propagation history %% for reasons of anti-monotony %% * Strengthen storage analysis for propagation rules %% reason about bodies of rules only containing constraints %% -> fixpoint with observation analysis %% * instantiation declarations %% COMPOUND (bound to nonvar) %% avoid nonvar tests %% %% * make difference between cheap guards for reordering %% and non-binding guards for lock removal %% * fd -> 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 %% * (set semantics + functional dependency) declaration + resolution %% * identify cases where prefixes of partner lookups for subsequent occurrences can be %% merged %% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- module(chr_translate, [ chr_translate/2 % +Decls, -TranslatedDecls , chr_translate_line_info/3 % +DeclsWithLines, -TranslatedDecls ]). %% SWI begin :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]). :- use_module(library(ordsets)). %% SWI end :- use_module(hprolog). :- use_module(pairlist). :- use_module(a_star). :- use_module(listmap). :- use_module(clean_code). :- use_module(builtins). :- use_module(find). :- use_module(binomialheap). :- use_module(guard_entailment). :- use_module(chr_compiler_options). :- use_module(chr_compiler_utility). :- use_module(chr_compiler_errors). :- include(chr_op). :- op(1150, fx, chr_type). :- op(1130, xfx, --->). :- op(980, fx, (+)). :- op(980, fx, (-)). :- op(980, fx, (?)). :- op(1150, fx, constraints). :- op(1150, fx, chr_constraint). :- chr_option(debug,off). :- chr_option(optimize,full). :- chr_option(check_guard_bindings,off). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_type list(T) ---> [] ; [T|list(T)]. :- chr_type list == list(any). :- chr_type maybe(T) ---> yes(T) ; no. :- chr_type constraint ---> any / any. :- chr_type module_name == any. :- chr_type pragma_rule ---> pragma(rule,idspair,list(pragma_type),maybe(rule_name),rule_nb). :- chr_type rule ---> rule(list(any),list(any),goal,goal). :- chr_type idspair ---> ids(list(id),list(id)). :- chr_type pragma_type ---> passive(id) ; mpassive(list(id)) ; already_in_heads ; already_in_heads(id) ; no_history ; history(history_name,list(id)). :- chr_type history_name== any. :- chr_type rule_name == any. :- chr_type rule_nb == natural. :- chr_type id == natural. :- chr_type goal == any. :- chr_type store_type ---> default ; multi_store(list(store_type)) ; multi_hash(list(list(int))) ; multi_inthash(list(list(int))) ; global_singleton ; global_ground % EXPERIMENTAL STORES ; var_assoc_store(int,list(int)) ; identifier_store(int) ; type_indexed_identifier_store(int,any). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %------------------------------------------------------------------------------% :- chr_constraint chr_source_file/1. :- chr_option(mode,chr_source_file(+)). :- chr_option(type_declaration,chr_source_file(module_name)). %------------------------------------------------------------------------------% chr_source_file(_) \ chr_source_file(_) <=> true. %------------------------------------------------------------------------------% :- chr_constraint get_chr_source_file/1. :- chr_option(mode,get_chr_source_file(-)). :- chr_option(type_declaration,get_chr_source_file(module_name)). %------------------------------------------------------------------------------% chr_source_file(Mod) \ get_chr_source_file(Query) <=> Query = Mod . get_chr_source_file(Query) <=> Query = user. %------------------------------------------------------------------------------% :- chr_constraint target_module/1. :- chr_option(mode,target_module(+)). :- chr_option(type_declaration,target_module(module_name)). %------------------------------------------------------------------------------% target_module(_) \ target_module(_) <=> true. %------------------------------------------------------------------------------% :- chr_constraint get_target_module/1. :- chr_option(mode,get_target_module(-)). :- chr_option(type_declaration,get_target_module(module_name)). %------------------------------------------------------------------------------% target_module(Mod) \ get_target_module(Query) <=> Query = Mod . get_target_module(Query) <=> Query = user. %------------------------------------------------------------------------------% :- chr_constraint line_number/2. :- chr_option(mode,line_number(+,+)). %------------------------------------------------------------------------------% line_number(RuleNb,LineNb) \ line_number(RuleNb,LineNumber) <=> true. %------------------------------------------------------------------------------% :- chr_constraint get_line_number/2. :- chr_option(mode,get_line_number(+,-)). %------------------------------------------------------------------------------% line_number(RuleNb,LineNb) \ get_line_number(RuleNb,Q) <=> Q = LineNb. get_line_number(RuleNb,Q) <=> Q = 0. % no line number available :- chr_constraint indexed_argument/2. % argument instantiation may enable applicability of rule :- chr_option(mode,indexed_argument(+,+)). :- chr_option(type_declaration,indexed_argument(constraint,int)). :- chr_constraint is_indexed_argument/2. :- chr_option(mode,is_indexed_argument(+,+)). :- chr_option(type_declaration,is_indexed_argument(constraint,int)). :- chr_constraint constraint_mode/2. :- chr_option(mode,constraint_mode(+,+)). :- chr_option(type_declaration,constraint_mode(constraint,list)). :- chr_constraint get_constraint_mode/2. :- chr_option(mode,get_constraint_mode(+,-)). :- chr_option(type_declaration,get_constraint_mode(constraint,list)). :- chr_constraint may_trigger/1. :- chr_option(mode,may_trigger(+)). :- chr_option(type_declaration,may_trigger(constraint)). :- chr_constraint only_ground_indexed_arguments/1. :- chr_option(mode,only_ground_indexed_arguments(+)). :- chr_option(type_declaration,only_ground_indexed_arguments(constraint)). :- chr_constraint none_suspended_on_variables/0. :- chr_constraint are_none_suspended_on_variables/0. :- chr_constraint store_type/2. :- chr_option(mode,store_type(+,+)). :- chr_option(type_declaration,store_type(constraint,store_type)). :- chr_constraint get_store_type/2. :- chr_option(mode,get_store_type(+,?)). :- chr_option(type_declaration,get_store_type(constraint,store_type)). :- chr_constraint update_store_type/2. :- chr_option(mode,update_store_type(+,+)). :- chr_option(type_declaration,update_store_type(constraint,store_type)). :- chr_constraint actual_store_types/2. :- chr_option(mode,actual_store_types(+,+)). :- chr_option(type_declaration,actual_store_types(constraint,list(store_type))). :- chr_constraint assumed_store_type/2. :- chr_option(mode,assumed_store_type(+,+)). :- chr_option(type_declaration,assumed_store_type(constraint,store_type)). :- chr_constraint validate_store_type_assumption/1. :- chr_option(mode,validate_store_type_assumption(+)). :- chr_option(type_declaration,validate_store_type_assumption(constraint)). :- chr_constraint rule_count/1. :- chr_option(mode,rule_count(+)). :- chr_option(type_declaration,rule_count(natural)). :- chr_constraint inc_rule_count/1. :- chr_option(mode,inc_rule_count(-)). :- chr_option(type_declaration,inc_rule_count(natural)). rule_count(_) \ rule_count(_) <=> true. rule_count(C), inc_rule_count(NC) <=> NC is C + 1, rule_count(NC). inc_rule_count(NC) <=> NC = 1, rule_count(NC). :- chr_constraint passive/2. :- chr_option(mode,passive(+,+)). :- chr_constraint is_passive/2. :- chr_option(mode,is_passive(+,+)). :- chr_constraint any_passive_head/1. :- chr_option(mode,any_passive_head(+)). :- chr_constraint new_occurrence/4. :- chr_option(mode,new_occurrence(+,+,+,+)). :- chr_constraint occurrence/5. :- chr_option(mode,occurrence(+,+,+,+,+)). :- chr_type occurrence_type ---> simplification ; propagation. :- chr_option(type_declaration,occurrence(any,any,any,any,occurrence_type)). :- chr_constraint get_occurrence/4. :- chr_option(mode,get_occurrence(+,+,-,-)). :- chr_constraint get_occurrence_from_id/4. :- chr_option(mode,get_occurrence_from_id(+,-,+,+)). :- chr_constraint max_occurrence/2. :- chr_option(mode,max_occurrence(+,+)). :- chr_constraint get_max_occurrence/2. :- chr_option(mode,get_max_occurrence(+,-)). :- chr_constraint allocation_occurrence/2. :- chr_option(mode,allocation_occurrence(+,+)). :- chr_constraint get_allocation_occurrence/2. :- chr_option(mode,get_allocation_occurrence(+,-)). :- chr_constraint rule/2. :- chr_option(mode,rule(+,+)). :- chr_option(type_declaration,rule(rule_nb,pragma_rule)). :- chr_constraint get_rule/2. :- chr_option(mode,get_rule(+,-)). :- chr_option(type_declaration,get_rule(int,pragma_rule)). :- chr_constraint least_occurrence/2. :- chr_option(mode,least_occurrence(+,+)). :- chr_option(type_declaration,least_occurrence(any,list)). :- chr_constraint is_least_occurrence/1. :- chr_option(mode,is_least_occurrence(+)). indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true. indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true. is_indexed_argument(_,_) <=> fail. %%% C O N S T R A I N T M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true. constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=> Q = Mode. get_constraint_mode(FA,Q) <=> FA = _ / N, replicate(N,(?),Q). %%% M A Y T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail. constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=> nth1(I,Mode,M), M \== (+) | is_stored(FA). may_trigger(FA) <=> chr_pp_flag(debugable,on). % in debug mode, we assume everything can be triggered constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA) <=> nth1(I,Mode,M), M \== (+) | fail. only_ground_indexed_arguments(_) <=> true. none_suspended_on_variables \ none_suspended_on_variables <=> true. none_suspended_on_variables \ are_none_suspended_on_variables <=> true. are_none_suspended_on_variables <=> fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% store_type(FA,Store) \ get_store_type(FA,Query) <=> Query = Store. assumed_store_type(FA,Store) \ get_store_type(FA,Query) <=> Query = Store. get_store_type(_,Query) <=> Query = default. actual_store_types(C,STs) \ update_store_type(C,ST) <=> member(ST,STs) | true. update_store_type(C,ST), actual_store_types(C,STs) <=> actual_store_types(C,[ST|STs]). update_store_type(C,ST) <=> actual_store_types(C,[ST]). % refine store type assumption validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_) % automatic assumption <=> store_type(C,multi_store(STs)). validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_) % user assumption <=> store_type(C,multi_store(STs)). validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint in debug mode <=> chr_pp_flag(debugable,on) | store_type(C,default). validate_store_type_assumption(C), assumed_store_type(C,_) % no lookups on constraint <=> store_type(C,global_ground). validate_store_type_assumption(C) <=> true. %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% passive(R,ID) \ passive(R,ID) <=> true. passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true. is_passive(_,_) <=> fail. passive(RuleNb,_) \ any_passive_head(RuleNb) <=> true. any_passive_head(_) <=> fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% max_occurrence(C,N) \ max_occurrence(C,M) <=> N >= M | true. max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=> NO is MO + 1, occurrence(C,NO,RuleNb,ID,Type), max_occurrence(C,NO). new_occurrence(C,RuleNb,ID,_) <=> chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]). max_occurrence(C,MON) \ get_max_occurrence(C,Q) <=> Q = MON. get_max_occurrence(C,Q) <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]). occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID) <=> Rule = QRule, ID = QID. get_occurrence(C,O,_,_) <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]). occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(QC,QON,Rule,ID) <=> QC = C, QON = ON. get_occurrence_from_id(C,O,_,_) <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Late allocation late_allocation_analysis(Cs) :- ( chr_pp_flag(late_allocation,on) -> maplist(late_allocation, Cs) ; true ). late_allocation(C) :- late_allocation(C,0). late_allocation(C,O) :- allocation_occurrence(C,O), !. late_allocation(C,O) :- NO is O + 1, late_allocation(C,NO). % A L L O C C A T I O N O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% allocation_occurrence(C,0) ==> stored_in_guard_before_next_kept_occurrence(C,0). rule(RuleNb,Rule), occurrence(C,O,RuleNb,Id,Type), allocation_occurrence(C,O) ==> \+ is_passive(RuleNb,Id), Type == propagation, ( stored_in_guard_before_next_kept_occurrence(C,O) -> true ; Rule = pragma(rule([_|_],_,_,_),_,_,_,_) -> % simpagation rule is_observed(C,O) ; is_least_occurrence(RuleNb) -> % propagation rule is_observed(C,O) ; true ). stored_in_guard_before_next_kept_occurrence(C,O) :- chr_pp_flag(store_in_guards, on), NO is O + 1, stored_in_guard_lookahead(C,NO). :- chr_constraint stored_in_guard_lookahead/2. :- chr_option(mode, stored_in_guard_lookahead(+,+)). occurrence(C,O,RuleNb,Id,_), passive(RuleNb,Id) \ stored_in_guard_lookahead(C,O) <=> NO is O + 1, stored_in_guard_lookahead(C,NO). occurrence(C,O,RuleNb,Id,Type) \ stored_in_guard_lookahead(C,O) <=> Type == simplification, ( is_stored_in_guard(C,RuleNb) -> true ; NO is O + 1, stored_in_guard_lookahead(C,NO) ). stored_in_guard_lookahead(_,_) <=> fail. rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO) \ least_occurrence(RuleNb,[ID|IDs]) <=> AO >= O, \+ may_trigger(C) | least_occurrence(RuleNb,IDs). rule(RuleNb,Rule), passive(RuleNb,ID) \ least_occurrence(RuleNb,[ID|IDs]) <=> least_occurrence(RuleNb,IDs). rule(RuleNb,Rule) ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) | least_occurrence(RuleNb,IDs). least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb) <=> true. is_least_occurrence(_) <=> fail. allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q) <=> Q = O. get_allocation_occurrence(_,Q) <=> chr_pp_flag(late_allocation,off), Q=0. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% rule(RuleNb,Rule) \ get_rule(RuleNb,Q) <=> Q = Rule. get_rule(_,_) <=> fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% C O N S T R A I N T I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Default store constraint index assignment. :- chr_constraint constraint_index/2. % constraint_index(F/A,DefaultStoreAndAttachedIndex) :- chr_option(mode,constraint_index(+,+)). :- chr_option(type_declaration,constraint_index(constraint,int)). :- chr_constraint get_constraint_index/2. :- chr_option(mode,get_constraint_index(+,-)). :- chr_option(type_declaration,get_constraint_index(constraint,int)). :- chr_constraint get_indexed_constraint/2. :- chr_option(mode,get_indexed_constraint(+,-)). :- chr_option(type_declaration,get_indexed_constraint(int,constraint)). :- chr_constraint max_constraint_index/1. % max_constraint_index(MaxDefaultStoreAndAttachedIndex) :- chr_option(mode,max_constraint_index(+)). :- chr_option(type_declaration,max_constraint_index(int)). :- chr_constraint get_max_constraint_index/1. :- chr_option(mode,get_max_constraint_index(-)). :- chr_option(type_declaration,get_max_constraint_index(int)). constraint_index(C,Index) \ get_constraint_index(C,Query) <=> Query = Index. get_constraint_index(C,Query) <=> fail. constraint_index(C,Index) \ get_indexed_constraint(Index,Q) <=> Q = C. get_indexed_constraint(Index,Q) <=> fail. max_constraint_index(Index) \ get_max_constraint_index(Query) <=> Query = Index. get_max_constraint_index(Query) <=> Query = 0. set_constraint_indices(Constraints) :- set_constraint_indices(Constraints,1). set_constraint_indices([],M) :- N is M - 1, max_constraint_index(N). set_constraint_indices([C|Cs],N) :- ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ; is_stored(C), get_store_type(C,default) ; get_store_type(C,var_assoc_store(_,_))) -> constraint_index(C,N), M is N + 1, set_constraint_indices(Cs,M) ; set_constraint_indices(Cs,N) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Identifier Indexes :- chr_constraint identifier_size/1. :- chr_option(mode,identifier_size(+)). :- chr_option(type_declaration,identifier_size(natural)). identifier_size(_) \ identifier_size(_) <=> true. :- chr_constraint get_identifier_size/1. :- chr_option(mode,get_identifier_size(-)). :- chr_option(type_declaration,get_identifier_size(natural)). identifier_size(Size) \ get_identifier_size(Q) <=> Q = Size. get_identifier_size(Q) <=> Q = 1. :- chr_constraint identifier_index/3. :- chr_option(mode,identifier_index(+,+,+)). :- chr_option(type_declaration,identifier_index(constraint,natural,natural)). identifier_index(C,I,_) \ identifier_index(C,I,_) <=> true. :- chr_constraint get_identifier_index/3. :- chr_option(mode,get_identifier_index(+,+,-)). :- chr_option(type_declaration,get_identifier_index(constraint,natural,natural)). identifier_index(C,I,II) \ get_identifier_index(C,I,Q) <=> Q = II. identifier_size(Size), get_identifier_index(C,I,Q) <=> NSize is Size + 1, identifier_index(C,I,NSize), identifier_size(NSize), Q = NSize. get_identifier_index(C,I,Q) <=> identifier_index(C,I,2), identifier_size(2), Q = 2. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Type Indexed Identifier Indexes :- chr_constraint type_indexed_identifier_size/2. :- chr_option(mode,type_indexed_identifier_size(+,+)). :- chr_option(type_declaration,type_indexed_identifier_size(any,natural)). type_indexed_identifier_size(IndexType,_) \ type_indexed_identifier_size(IndexType,_) <=> true. :- chr_constraint get_type_indexed_identifier_size/2. :- chr_option(mode,get_type_indexed_identifier_size(+,-)). :- chr_option(type_declaration,get_type_indexed_identifier_size(any,natural)). type_indexed_identifier_size(IndexType,Size) \ get_type_indexed_identifier_size(IndexType,Q) <=> Q = Size. get_type_indexed_identifier_size(IndexType,Q) <=> Q = 1. :- chr_constraint type_indexed_identifier_index/4. :- chr_option(mode,type_indexed_identifier_index(+,+,+,+)). :- chr_option(type_declaration,type_indexed_identifier_index(any,constraint,natural,natural)). type_indexed_identifier_index(_,C,I,_) \ type_indexed_identifier_index(_,C,I,_) <=> true. :- chr_constraint get_type_indexed_identifier_index/4. :- chr_option(mode,get_type_indexed_identifier_index(+,+,+,-)). :- chr_option(type_declaration,get_type_indexed_identifier_index(any,constraint,natural,natural)). type_indexed_identifier_index(IndexType,C,I,II) \ get_type_indexed_identifier_index(IndexType,C,I,Q) <=> Q = II. type_indexed_identifier_size(IndexType,Size), get_type_indexed_identifier_index(IndexType,C,I,Q) <=> NSize is Size + 1, type_indexed_identifier_index(IndexType,C,I,NSize), type_indexed_identifier_size(IndexType,NSize), Q = NSize. get_type_indexed_identifier_index(IndexType,C,I,Q) <=> type_indexed_identifier_index(IndexType,C,I,2), type_indexed_identifier_size(IndexType,2), Q = 2. type_indexed_identifier_structure(IndexType,Structure) :- type_indexed_identifier_name(IndexType,type_indexed_identifier_struct,Functor), get_type_indexed_identifier_size(IndexType,Arity), functor(Structure,Functor,Arity). type_indexed_identifier_name(IndexType,Prefix,Name) :- ( atom(IndexType) -> IndexTypeName = IndexType ; term_to_atom(IndexType,IndexTypeName) ), atom_concat_list([Prefix,'_',IndexTypeName],Name). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% Translation chr_translate(Declarations,NewDeclarations) :- chr_translate_line_info(Declarations,'bootstrap',NewDeclarations). chr_translate_line_info(Declarations,File,NewDeclarations) :- chr_info(banner,'\tThe K.U.Leuven CHR System\t\n\t\tContributors:\tTom Schrijvers, Jon Sneyers, Bart Demoen,\n\t\t\t\tJan Wielemaker\n\t\tCopyright:\tK.U.Leuven, Belgium\n\t\tURL:\t\thttp://www.cs.kuleuven.be/~~toms/CHR/\n',[]), init_chr_pp_flags, chr_source_file(File), partition_clauses(Declarations,Constraints0,Rules0,OtherClauses), chr_compiler_options:sanity_check, check_declared_constraints(Constraints0), generate_show_constraint(Constraints0,Constraints,Rules0,Rules), add_constraints(Constraints), add_rules(Rules), % start analysis check_rules(Rules,Constraints), time('type checking',chr_translate:static_type_check), add_occurrences(Rules), time('functional dependency',chr_translate:functional_dependency_analysis(Rules)), time('set semantics',chr_translate:set_semantics_rules(Rules)), time('symmetry analysis',chr_translate:symmetry_analysis(Rules)), time('guard simplification',chr_translate:guard_simplification), time('late storage',chr_translate:storage_analysis(Constraints)), time('observation',chr_translate:observation_analysis(Constraints)), time('ai observation',chr_translate:ai_observation_analysis(Constraints)), time('late allocation',chr_translate:late_allocation_analysis(Constraints)), partial_wake_analysis, time('assume constraint stores',chr_translate:assume_constraint_stores(Constraints)), time('default constraint indices',chr_translate:set_constraint_indices(Constraints)), % end analysis time('constraint code generation',chr_translate:constraints_code(Constraints,ConstraintClauses)), time('validate store assumptions',chr_translate:validate_store_type_assumptions(Constraints)), phase_end(validate_store_type_assumptions), used_states_known, time('store code generation',chr_translate:store_management_preds(Constraints,StoreClauses)), % depends on actual code used insert_declarations(OtherClauses, Clauses0), chr_module_declaration(CHRModuleDeclaration), append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses), clean_clauses(StuffyGeneratedClauses,GeneratedClauses), append([Clauses0,GeneratedClauses], NewDeclarations). store_management_preds(Constraints,Clauses) :- generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses), generate_attr_unify_hook(AttrUnifyHookClauses), generate_attach_increment(AttachIncrementClauses), generate_extra_clauses(Constraints,ExtraClauses), generate_insert_delete_constraints(Constraints,DeleteClauses), generate_attach_code(Constraints,StoreClauses), generate_counter_code(CounterClauses), generate_dynamic_type_check_clauses(TypeCheckClauses), append([AttachAConstraintClauses ,AttachIncrementClauses ,AttrUnifyHookClauses ,ExtraClauses ,DeleteClauses ,StoreClauses ,CounterClauses ,TypeCheckClauses ] ,Clauses). insert_declarations(Clauses0, Clauses) :- findall((:- use_module(chr(Module))),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls), append(Clauses0, [(:- use_module(chr(chr_runtime)))|Decls], Clauses). auxiliary_module(chr_hashtable_store). auxiliary_module(chr_integertable_store). auxiliary_module(chr_assoc_store). generate_counter_code(Clauses) :- ( chr_pp_flag(store_counter,on) -> Clauses = [ ('$counter_init'(N1) :- nb_setval(N1,0)) , ('$counter'(N2,X1) :- nb_getval(N2,X1)), ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)), (:- '$counter_init'('$insert_counter')), (:- '$counter_init'('$delete_counter')), ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')), ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')), ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D)) ] ; Clauses = [] ). % for systems with multifile declaration chr_module_declaration(CHRModuleDeclaration) :- get_target_module(Mod), ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) -> CHRModuleDeclaration = [ (:- multifile chr:'$chr_module'/1), chr:'$chr_module'(Mod) ] ; CHRModuleDeclaration = [] ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% Partitioning of clauses into constraint declarations, chr rules and other %% clauses %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% partition_clauses(+Clauses,-ConstraintDeclarations,-Rules,-OtherClauses) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% partition_clauses([],[],[],[]). partition_clauses([Clause|Clauses],ConstraintDeclarations,Rules,OtherClauses) :- ( parse_rule(Clause,Rule) -> ConstraintDeclarations = RestConstraintDeclarations, Rules = [Rule|RestRules], OtherClauses = RestOtherClauses ; is_declaration(Clause,ConstraintDeclaration) -> append(ConstraintDeclaration,RestConstraintDeclarations,ConstraintDeclarations), Rules = RestRules, OtherClauses = RestOtherClauses ; is_module_declaration(Clause,Mod) -> target_module(Mod), ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = [Clause|RestOtherClauses] ; is_type_definition(Clause) -> ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = RestOtherClauses ; Clause = (handler _) -> chr_warning(deprecated(Clause),'Backward compatibility: ignoring handler/1 declaration.\n',[]), ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = RestOtherClauses ; Clause = (rules _) -> chr_warning(deprecated(Clause),'Backward compatibility: ignoring rules/1 declaration.\n',[]), ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = RestOtherClauses ; Clause = option(OptionName,OptionValue) -> chr_warning(deprecated(Clause),'Instead use `:-chr_option(~w,~w).\'\n',[OptionName,OptionValue]), handle_option(OptionName,OptionValue), ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = RestOtherClauses ; Clause = (:-chr_option(OptionName,OptionValue)) -> handle_option(OptionName,OptionValue), ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = RestOtherClauses ; Clause = ('$chr_compiled_with_version'(_)) -> ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = ['$chr_compiled_with_version'(3)|RestOtherClauses] ; ConstraintDeclarations = RestConstraintDeclarations, Rules = RestRules, OtherClauses = [Clause|RestOtherClauses] ), partition_clauses(Clauses,RestConstraintDeclarations,RestRules,RestOtherClauses). '$chr_compiled_with_version'(2). is_declaration(D, Constraints) :- %% constraint declaration ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) -> conj2list(Cs,Constraints0) ; ( D = (:- Decl) -> Decl =.. [constraints,Cs] ; D =.. [constraints,Cs] ), conj2list(Cs,Constraints0), chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs]) ), extract_type_mode(Constraints0,Constraints). extract_type_mode([],[]). extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2). extract_type_mode([C|R],[ConstraintSymbol|R2]) :- functor(C,F,A), ConstraintSymbol = F/A, C =.. [_|Args], extract_types_and_modes(Args,ArgTypes,ArgModes), constraint_type(ConstraintSymbol,ArgTypes), constraint_mode(ConstraintSymbol,ArgModes), extract_type_mode(R,R2). extract_types_and_modes([],[],[]). extract_types_and_modes([X|R],[T|R2],[M|R3]) :- extract_type_and_mode(X,T,M), extract_types_and_modes(R,R2,R3). extract_type_and_mode(+(T),T,(+)) :- !. extract_type_and_mode(?(T),T,(?)) :- !. extract_type_and_mode(-(T),T,(-)) :- !. extract_type_and_mode((+),any,(+)) :- !. extract_type_and_mode((?),any,(?)) :- !. extract_type_and_mode((-),any,(-)) :- !. extract_type_and_mode(Illegal,_,_) :- chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]). is_type_definition(Declaration) :- ( Declaration = (:- TDef) -> true ; Declaration = TDef ), TDef =.. [chr_type,TypeDef], ( TypeDef = (Name ---> Def) -> tdisj2list(Def,DefList), type_definition(Name,DefList) ; TypeDef = (Alias == Name) -> type_alias(Alias,Name) ; type_definition(TypeDef,[]), chr_warning(syntax,'Empty type definition `~w\'.\nAre you sure you want to declare a phantom type?\n',[Declaration]) ). %% tdisj2list(+Goal,-ListOfGoals) is det. % % no removal of fails, e.g. :- type bool ---> true ; fail. tdisj2list(Conj,L) :- tdisj2list(Conj,L,[]). tdisj2list(Conj,L,T) :- Conj = (G1;G2), !, tdisj2list(G1,L,T1), tdisj2list(G2,T1,T). tdisj2list(G,[G | T],T). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% parse_rule(+term,-pragma_rule) is semidet. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% parse_rule(RI,R) :- %% name @ rule RI = (Name @ RI2), !, rule(RI2,yes(Name),R). parse_rule(RI,R) :- rule(RI,no,R). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% parse_rule(+term,-pragma_rule) is semidet. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% rule(RI,Name,R) :- RI = (RI2 pragma P), !, %% pragmas ( var(P) -> Ps = [_] % intercept variable ; conj2list(P,Ps) ), inc_rule_count(RuleCount), R = pragma(R1,IDs,Ps,Name,RuleCount), is_rule(RI2,R1,IDs,R). rule(RI,Name,R) :- inc_rule_count(RuleCount), R = pragma(R1,IDs,[],Name,RuleCount), is_rule(RI,R1,IDs,R). is_rule(RI,R,IDs,RC) :- %% propagation rule RI = (H ==> B), !, conj2list(H,Head2i), get_ids(Head2i,IDs2,Head2,RC), IDs = ids([],IDs2), ( B = (G | RB) -> R = rule([],Head2,G,RB) ; R = rule([],Head2,true,B) ). is_rule(RI,R,IDs,RC) :- %% 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,RC), get_ids(Head1i,IDs1,Head1,N,_,RC), IDs = ids(IDs1,IDs2) ; conj2list(H,Head1i), Head2 = [], get_ids(Head1i,IDs1,Head1,RC), IDs = ids(IDs1,[]) ), R = rule(Head1,Head2,Guard,Body). get_ids(Cs,IDs,NCs,RC) :- get_ids(Cs,IDs,NCs,0,_,RC). get_ids([],[],[],N,N,_). get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :- ( C = (NC # N1) -> ( var(N1) -> N1 = N ; check_direct_pragma(N1,N,RC) ) ; NC = C ), M is N + 1, get_ids(Cs,IDs,NCs, M,NN,RC). check_direct_pragma(passive,Id,PragmaRule) :- !, PragmaRule = pragma(_,_,_,_,RuleNb), passive(RuleNb,Id). check_direct_pragma(Abbrev,Id,PragmaRule) :- ( direct_pragma(FullPragma), atom_concat(Abbrev,Remainder,FullPragma) -> chr_warning(problem_pragma(Abbrev,PragmaRule),'completed `~w\' to `~w\'\n',[Abbrev,FullPragma]) ; chr_warning(unsupported_pragma(Abbrev,PragmaRule),'',[]) ). direct_pragma(passive). is_module_declaration((:- module(Mod)),Mod). is_module_declaration((:- module(Mod,_)),Mod). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Add constraints add_constraints([]). add_constraints([C|Cs]) :- max_occurrence(C,0), C = _/A, length(Mode,A), set_elems(Mode,?), constraint_mode(C,Mode), add_constraints(Cs). % Add rules add_rules([]). add_rules([Rule|Rules]) :- Rule = pragma(_,_,_,_,RuleNb), rule(RuleNb,Rule), add_rules(Rules). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Some input verification: check_declared_constraints(Constraints) :- check_declared_constraints(Constraints,[]). check_declared_constraints([],_). check_declared_constraints([C|Cs],Acc) :- ( memberchk_eq(C,Acc) -> chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C]) ; true ), check_declared_constraints(Cs,[C|Acc]). %% - all constraints in heads are declared constraints %% - all passive pragmas refer to actual head constraints check_rules([],_). check_rules([PragmaRule|Rest],Decls) :- check_rule(PragmaRule,Decls), check_rules(Rest,Decls). check_rule(PragmaRule,Decls) :- check_rule_indexing(PragmaRule), check_trivial_propagation_rule(PragmaRule), PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N), Rule = rule(H1,H2,_,_), append(H1,H2,HeadConstraints), check_head_constraints(HeadConstraints,Decls,PragmaRule), check_pragmas(Pragmas,PragmaRule). % Make all heads passive in trivial propagation rule % ... ==> ... | true. check_trivial_propagation_rule(PragmaRule) :- PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb), ( Rule = rule([],_,_,true) -> chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]), set_all_passive(RuleNb) ; true ). check_head_constraints([],_,_). check_head_constraints([Constr|Rest],Decls,PragmaRule) :- functor(Constr,F,A), ( member(F/A,Decls) -> check_head_constraints(Rest,Decls,PragmaRule) ; chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls]) ). check_pragmas([],_). check_pragmas([Pragma|Pragmas],PragmaRule) :- check_pragma(Pragma,PragmaRule), check_pragmas(Pragmas,PragmaRule). check_pragma(Pragma,PragmaRule) :- var(Pragma), !, chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]). check_pragma(passive(ID), PragmaRule) :- !, PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb), ( memberchk_eq(ID,IDs1) -> true ; memberchk_eq(ID,IDs2) -> true ; chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)]) ), passive(RuleNb,ID). check_pragma(mpassive(IDs), PragmaRule) :- !, PragmaRule = pragma(_,_,_,_,RuleNb), chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[mpassive(IDs)]), maplist(passive(RuleNb),IDs). check_pragma(Pragma, PragmaRule) :- Pragma = already_in_heads, !, chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]). check_pragma(Pragma, PragmaRule) :- Pragma = already_in_head(_), !, chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]). check_pragma(Pragma, PragmaRule) :- Pragma = no_history, !, chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]), PragmaRule = pragma(_,_,_,_,N), no_history(N). check_pragma(Pragma, PragmaRule) :- Pragma = history(HistoryName,IDs), !, PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb), chr_warning(experimental,'Experimental pragma ~w. Use with care!\n',[Pragma]), ( IDs1 \== [] -> chr_error(syntax(Pragma),'Pragma history only implemented for propagation rules.\n',[]) ; \+ atom(HistoryName) -> chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not an atom (rule number ~w).\n',[HistoryName,RuleNb]) ; \+ is_set(IDs) -> chr_error(syntax(Pragma),'Illegal argument for pragma history: ~w is not a set (rule number ~w).\n',[IDs,RuleNb]) ; check_history_pragma_ids(IDs,IDs1,IDs2) -> history(RuleNb,HistoryName,IDs) ; chr_error(syntax(Pragma),'Invalid identifier(s) in pragma ~w of rule number ~w.\n',[Pragma,RuleNb]) ). check_pragma(Pragma,PragmaRule) :- Pragma = line_number(LineNumber), !, PragmaRule = pragma(_,_,_,_,RuleNb), line_number(RuleNb,LineNumber). check_history_pragma_ids([], _, _). check_history_pragma_ids([ID|IDs],IDs1,IDs2) :- ( memberchk_eq(ID,IDs2) ; memberchk_eq(ID,IDs1) ), check_history_pragma_ids(IDs,IDs1,IDs2). check_pragma(Pragma,PragmaRule) :- chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% no_history(+RuleNb) is det. :- chr_constraint no_history/1. :- chr_option(mode,no_history(+)). :- chr_option(type_declaration,no_history(int)). %% has_no_history(+RuleNb) is semidet. :- chr_constraint has_no_history/1. :- chr_option(mode,has_no_history(+)). :- chr_option(type_declaration,has_no_history(int)). no_history(RuleNb) \ has_no_history(RuleNb) <=> true. has_no_history(_) <=> fail. :- chr_constraint history/3. :- chr_option(mode,history(+,+,+)). :- chr_option(type_declaration,history(any,any,list)). :- chr_constraint named_history/3. history(RuleNb,_,_), history(RuleNb,_,_) ==> chr_error(syntax,'Only one pragma history allowed per rule (rule number ~w)\n',[RuleNb]). %' history(RuleNb1,Name,IDs1), history(RuleNb2,Name,IDs2) ==> length(IDs1,L1), length(IDs2,L2), ( L1 \== L2 -> chr_error(syntax,'The history named ~w does not always range over an equal amount of occurrences.\n',[Name]) ; test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2) ). test_named_history_id_pairs(_, [], _, []). test_named_history_id_pairs(RuleNb1, [ID1|IDs1], RuleNb2, [ID2|IDs2]) :- test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2), test_named_history_id_pairs(RuleNb1,IDs1,RuleNb2,IDs2). :- chr_constraint test_named_history_id_pair/4. :- chr_option(mode,test_named_history_id_pair(+,+,+,+)). occurrence(C,_,RuleNb1,ID1,_), occurrence(C,_,RuleNb2,ID2,_) \ test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> true. test_named_history_id_pair(RuleNb1,ID1,RuleNb2,ID2) <=> chr_error(syntax,'Occurrences of shared history in rules number ~w and ~w do not correspond\n', [RuleNb2,RuleNb1]). history(RuleNb,Name,IDs) \ named_history(RuleNb,QName,QIDs) <=> QName = Name, QIDs = IDs. named_history(_,_,_) <=> fail. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% format_rule(PragmaRule) :- PragmaRule = pragma(_,_,_,MaybeName,RuleNumber), ( MaybeName = yes(Name) -> write('rule '), write(Name) ; write('rule number '), write(RuleNumber) ), get_line_number(RuleNumber,LineNumber), write(' (line '), write(LineNumber), write(')'). check_rule_indexing(PragmaRule) :- PragmaRule = pragma(Rule,_,_,_,_), Rule = rule(H1,H2,G,_), term_variables(H1-H2,HeadVars), remove_anti_monotonic_guards(G,HeadVars,NG), check_indexing(H1,NG-H2), check_indexing(H2,NG-H1), % EXPERIMENT ( chr_pp_flag(term_indexing,on) -> term_variables(NG,GuardVariables), append(H1,H2,Heads), check_specs_indexing(Heads,GuardVariables,Specs) ; true ). :- chr_constraint indexing_spec/2. :- chr_option(mode,indexing_spec(+,+)). :- chr_constraint get_indexing_spec/2. :- chr_option(mode,get_indexing_spec(+,-)). indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec. get_indexing_spec(_,Spec) <=> Spec = []. indexing_spec(FA,Specs1), indexing_spec(FA,Specs2) <=> append(Specs1,Specs2,Specs), indexing_spec(FA,Specs). remove_anti_monotonic_guards(G,Vars,NG) :- conj2list(G,GL), remove_anti_monotonic_guard_list(GL,Vars,NGL), list2conj(NGL,NG). remove_anti_monotonic_guard_list([],_,[]). remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :- ( G = var(X), memberchk_eq(X,Vars) -> NGs = RGs % TODO: this is not correct % ; G = functor(Term,Functor,Arity), % isotonic % \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) -> % NGs = RGs ; NGs = [G|RGs] ), remove_anti_monotonic_guard_list(Gs,Vars,RGs). check_indexing([],_). check_indexing([Head|Heads],Other) :- functor(Head,F,A), Head =.. [_|Args], term_variables(Heads-Other,OtherVars), check_indexing(Args,1,F/A,OtherVars), check_indexing(Heads,[Head|Other]). check_indexing([],_,_,_). check_indexing([Arg|Args],I,FA,OtherVars) :- ( is_indexed_argument(FA,I) -> true ; nonvar(Arg) -> indexed_argument(FA,I) ; % var(Arg) -> term_variables(Args,ArgsVars), append(ArgsVars,OtherVars,RestVars), ( memberchk_eq(Arg,RestVars) -> indexed_argument(FA,I) ; true ) ), J is I + 1, term_variables(Arg,NVars), append(NVars,OtherVars,NOtherVars), check_indexing(Args,J,FA,NOtherVars). check_specs_indexing([],_,[]). check_specs_indexing([Head|Heads],Variables,Specs) :- Specs = [Spec|RSpecs], term_variables(Heads,OtherVariables,Variables), check_spec_indexing(Head,OtherVariables,Spec), term_variables(Head,NVariables,Variables), check_specs_indexing(Heads,NVariables,RSpecs). check_spec_indexing(Head,OtherVariables,Spec) :- functor(Head,F,A), Spec = spec(F,A,ArgSpecs), Head =.. [_|Args], check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs), indexing_spec(F/A,[ArgSpecs]). check_args_spec_indexing([],_,_,[]). check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :- term_variables(Args,Variables,OtherVariables), ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) -> ArgSpecs = [ArgSpec|RArgSpecs] ; ArgSpecs = RArgSpecs ), J is I + 1, term_variables(Arg,NOtherVariables,OtherVariables), check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs). check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :- ( var(Arg) -> memberchk_eq(Arg,Variables), ArgSpec = specinfo(I,any,[]) ; functor(Arg,F,A), ArgSpec = specinfo(I,F/A,[ArgSpecs]), Arg =.. [_|Args], check_args_spec_indexing(Args,1,Variables,ArgSpecs) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Occurrences add_occurrences([]). add_occurrences([Rule|Rules]) :- Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb), add_occurrences(H1,IDs1,simplification,Nb), add_occurrences(H2,IDs2,propagation,Nb), add_occurrences(Rules). add_occurrences([],[],_,_). add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :- functor(H,F,A), FA = F/A, new_occurrence(FA,RuleNb,ID,Type), add_occurrences(Hs,IDs,Type,RuleNb). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Observation Analysis % % CLASSIFICATION % % % % % % :- chr_constraint observation_analysis/1. :- chr_option(mode, observation_analysis(+)). observation_analysis(Cs), rule(RuleNb,PragmaRule) # Id ==> PragmaRule = pragma(rule(_,_,Guard,Body),_,_,_,_), ( chr_pp_flag(store_in_guards, on) -> observation_analysis(RuleNb, Guard, guard, Cs) ; true ), observation_analysis(RuleNb, Body, body, Cs) pragma passive(Id). observation_analysis(_) <=> true. observation_analysis(RuleNb, Term, GB, Cs) :- ( all_spawned(RuleNb,GB) -> true ; var(Term) -> spawns_all(RuleNb,GB) ; Term = true -> true ; Term = fail -> true ; Term = '!' -> true ; Term = (T1,T2) -> observation_analysis(RuleNb,T1,GB,Cs), observation_analysis(RuleNb,T2,GB,Cs) ; Term = (T1;T2) -> observation_analysis(RuleNb,T1,GB,Cs), observation_analysis(RuleNb,T2,GB,Cs) ; Term = (T1->T2) -> observation_analysis(RuleNb,T1,GB,Cs), observation_analysis(RuleNb,T2,GB,Cs) ; Term = (\+ T) -> observation_analysis(RuleNb,T,GB,Cs) ; functor(Term,F,A), member(F/A,Cs) -> spawns(RuleNb,GB,F/A) ; Term = (_ = _) -> spawns_all_triggers(RuleNb,GB) ; Term = (_ is _) -> spawns_all_triggers(RuleNb,GB) ; builtin_binds_b(Term,Vars) -> ( Vars == [] -> true ; spawns_all_triggers(RuleNb,GB) ) ; spawns_all(RuleNb,GB) ). :- chr_constraint spawns/3. :- chr_option(mode, spawns(+,+,+)). :- chr_type spawns_type ---> guard ; body. :- chr_option(type_declaration,spawns(any,spawns_type,any)). :- chr_constraint spawns_all/2, spawns_all_triggers/2. :- chr_option(mode, spawns_all(+,+)). :- chr_option(type_declaration,spawns_all(any,spawns_type)). :- chr_option(mode, spawns_all_triggers(+,+)). :- chr_option(type_declaration,spawns_all_triggers(any,spawns_type)). spawns_all(RuleNb,GB) \ spawns_all(RuleNb,GB) <=> true. spawns_all(RuleNb,guard) \ spawns_all(RuleNb,body) <=> true. spawns_all_triggers(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true. spawns_all_triggers(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true. spawns(RuleNb,GB,C) \ spawns(RuleNb,GB,C) <=> true. spawns(RuleNb,guard,C) \ spawns(RuleNb,body,C) <=> true. spawns_all(RuleNb,GB) \ spawns(RuleNb,GB,_) <=> true. spawns_all(RuleNb,guard) \ spawns(RuleNb,body,_) <=> true. spawns_all(RuleNb,GB) \ spawns_all_triggers(RuleNb,GB) <=> true. spawns_all(RuleNb,guard) \ spawns_all_triggers(RuleNb,body) <=> true. spawns_all_triggers(RuleNb,GB) \ spawns(RuleNb,GB,C) <=> may_trigger(C) | true. spawns_all_triggers(RuleNb,guard) \ spawns(RuleNb,body,C) <=> may_trigger(C) | true. spawns_all(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id \ spawns(RuleNb1,GB,C1) <=> \+ is_passive(RuleNb2,O) | spawns_all(RuleNb1,GB) pragma passive(Id). occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all(RuleNb2,_) ==> \+(\+ spawns_all_triggers_implies_spawns_all), % in the hope it schedules this guard early... \+ is_passive(RuleNb2,O), may_trigger(C1) | spawns_all_triggers_implies_spawns_all pragma passive(Id). :- chr_constraint spawns_all_triggers_implies_spawns_all/0. spawns_all_triggers_implies_spawns_all, spawns_all_triggers_implies_spawns_all <=> fail. spawns_all_triggers_implies_spawns_all \ spawns_all_triggers(RuleNb,GB) <=> spawns_all(RuleNb,GB). spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id \ spawns(RuleNb1,GB,C1) <=> may_trigger(C1), \+ is_passive(RuleNb2,O) | spawns_all_triggers(RuleNb1,GB) pragma passive(Id). spawns_all_triggers(RuleNb2,_), occurrence(C1,_,RuleNb2,O,_)#Id, spawns(RuleNb1,GB,C1) ==> \+ may_trigger(C1), \+ is_passive(RuleNb2,O) | spawns_all_triggers(RuleNb1,GB) pragma passive(Id). % a bit dangerous this rule: could start propagating too much too soon? spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id, spawns(RuleNb1,GB,C1) ==> RuleNb1 \== RuleNb2, C1 \== C2, \+ is_passive(RuleNb2,O) | spawns(RuleNb1,GB,C2) pragma passive(Id). spawns(RuleNb2,_,C2), occurrence(C1,_,RuleNb2,O,_)#Id, spawns_all_triggers(RuleNb1,GB) ==> \+ is_passive(RuleNb2,O), may_trigger(C1), \+ may_trigger(C2) | spawns(RuleNb1,GB,C2) pragma passive(Id). :- chr_constraint all_spawned/2. :- chr_option(mode, all_spawned(+,+)). spawns_all(RuleNb,guard) \ all_spawned(RuleNb,_) <=> true. spawns_all(RuleNb,GB) \ all_spawned(RuleNb,GB) <=> true. all_spawned(RuleNb,GB) <=> fail. % Overview of the supported queries: % is_observed(+functor/artiy, +occurrence_number, +(guard;body)) % only succeeds if the occurrence is observed by the % guard resp. body (depending on the last argument) of its rule % is_observed(+functor/artiy, +occurrence_number, -) % succeeds if the occurrence is observed by either the guard or % the body of its rule % NOTE: the last argument is NOT bound by this query % % do_is_observed(+functor/artiy,+rule_number,+(guard;body)) % succeeds if the given constraint is observed by the given % guard resp. body % do_is_observed(+functor/artiy,+rule_number) % succeeds if the given constraint is observed by the given % rule (either its guard or its body) is_observed(C,O) :- is_observed(C,O,_), ai_is_observed(C,O). is_stored_in_guard(C,RuleNb) :- chr_pp_flag(store_in_guards, on), do_is_observed(C,RuleNb,guard). :- chr_constraint is_observed/3. :- chr_option(mode, is_observed(+,+,+)). occurrence(C,O,RuleNb,_,_) \ is_observed(C,O,GB) <=> do_is_observed(C,RuleNb,GB). is_observed(_,_,_) <=> fail. % this will not happen in practice :- chr_constraint do_is_observed/3. :- chr_option(mode, do_is_observed(+,+,+)). :- chr_constraint do_is_observed/2. :- chr_option(mode, do_is_observed(+,+)). do_is_observed(C,RuleNb,GB) <=> var(GB) | do_is_observed(C,RuleNb). % (1) spawns_all % a constraint C is observed if the GB of the rule it occurs in spawns all, % and some non-passive occurrence of some (possibly other) constraint % exists in a rule (could be same rule) with at least one occurrence of C spawns_all(RuleNb,GB), occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) \ do_is_observed(C,RuleNb,GB) <=> \+ is_passive(RuleNb2,O) | true. spawns_all(RuleNb,_), occurrence(_,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) \ do_is_observed(C,RuleNb) <=> \+ is_passive(RuleNb2,O) | true. % (2) spawns % a constraint C is observed if the GB of the rule it occurs in spawns a % constraint C2 that occurs non-passively in a rule (possibly the same rule) % as an occurrence of C spawns(RuleNb,GB,C2), occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) \ do_is_observed(C,RuleNb,GB) <=> \+ is_passive(RuleNb2,O) | true. spawns(RuleNb,_,C2), occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) \ do_is_observed(C,RuleNb) <=> \+ is_passive(RuleNb2,O) | true. % (3) spawns_all_triggers % a constraint C is observed if the GB of the rule it occurs in spawns all triggers % and some non-passive occurrence of some (possibly other) constraint that may trigger % exists in a rule (could be same rule) with at least one occurrence of C spawns_all_triggers(RuleNb,GB), occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) \ do_is_observed(C,RuleNb,GB) <=> \+ is_passive(RuleNb2,O), may_trigger(C2) | true. spawns_all_triggers(RuleNb,_), occurrence(C2,_,RuleNb2,O,_), occurrence(C,_,RuleNb2,_,_) \ do_is_observed(C,RuleNb) <=> \+ is_passive(RuleNb2,O), may_trigger(C2) | true. % (4) conservativeness do_is_observed(_,_,_) <=> chr_pp_flag(observation_analysis,off). do_is_observed(_,_) <=> chr_pp_flag(observation_analysis,off). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% %% 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) :- ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) -> generate_attach_a_constraint(Constraint,Clauses1), generate_detach_a_constraint(Constraint,Clauses2) ; Clauses1 = [], Clauses2 = [] ), generate_attach_detach_a_constraint_all(Constraints,Clauses3), append([Clauses1,Clauses2,Clauses3],Clauses). generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :- generate_attach_a_constraint_nil(Constraint,Clause1), generate_attach_a_constraint_cons(Constraint,Clause2). attach_constraint_atom(FA,Vars,Susp,Atom) :- make_name('attach_',FA,Name), Atom =.. [Name,Vars,Susp]. generate_attach_a_constraint_nil(FA,Clause) :- Clause = (Head :- true), attach_constraint_atom(FA,[],_,Head). generate_attach_a_constraint_cons(FA,Clause) :- Clause = (Head :- Body), attach_constraint_atom(FA,[Var|Vars],Susp,Head), attach_constraint_atom(FA,Vars,Susp,RecursiveCall), Body = ( AttachBody, Subscribe, RecursiveCall ), get_max_constraint_index(N), ( N == 1 -> generate_attach_body_1(FA,Var,Susp,AttachBody) ; generate_attach_body_n(FA,Var,Susp,AttachBody) ), % SWI-Prolog specific code chr_pp_flag(solver_events,NMod), ( NMod \== none -> Args = [[Var|_],Susp], get_target_module(Mod), use_auxiliary_predicate(run_suspensions), Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp])) ; Subscribe = true ). generate_attach_body_1(FA,Var,Susp,Body) :- get_target_module(Mod), Body = ( get_attr(Var, Mod, Susps) -> put_attr(Var, Mod, [Susp|Susps]) ; put_attr(Var, Mod, [Susp]) ). generate_attach_body_n(F/A,Var,Susp,Body) :- get_constraint_index(F/A,Position), get_max_constraint_index(Total), get_target_module(Mod), add_attr(Total,Susp,Position,TAttr,AddGoal,NTAttr), singleton_attr(Total,Susp,Position,NewAttr3), Body = ( get_attr(Var,Mod,TAttr) -> AddGoal, put_attr(Var,Mod,NTAttr) ; put_attr(Var,Mod,NewAttr3) ), !. %% detach_$CONSTRAINT generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :- generate_detach_a_constraint_nil(Constraint,Clause1), generate_detach_a_constraint_cons(Constraint,Clause2). detach_constraint_atom(FA,Vars,Susp,Atom) :- make_name('detach_',FA,Name), Atom =.. [Name,Vars,Susp]. generate_detach_a_constraint_nil(FA,Clause) :- Clause = ( Head :- true), detach_constraint_atom(FA,[],_,Head). generate_detach_a_constraint_cons(FA,Clause) :- Clause = (Head :- Body), detach_constraint_atom(FA,[Var|Vars],Susp,Head), detach_constraint_atom(FA,Vars,Susp,RecursiveCall), Body = ( DetachBody, RecursiveCall ), get_max_constraint_index(N), ( N == 1 -> generate_detach_body_1(FA,Var,Susp,DetachBody) ; generate_detach_body_n(FA,Var,Susp,DetachBody) ). generate_detach_body_1(FA,Var,Susp,Body) :- 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 ). generate_detach_body_n(F/A,Var,Susp,Body) :- get_constraint_index(F/A,Position), get_max_constraint_index(Total), rem_attr(Total,Var,Susp,Position,TAttr,RemGoal), get_target_module(Mod), Body = ( get_attr(Var,Mod,TAttr) -> RemGoal ; true ), !. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %------------------------------------------------------------------------------- %% generate_indexed_variables_body(+ConstraintSymbol,+ArgList,-Body,-VarList) is det. :- chr_constraint generate_indexed_variables_body/4. :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)). :- chr_option(type_declaration,generate_indexed_variables_body(constraint,any,any,any)). %------------------------------------------------------------------------------- constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=> get_indexing_spec(F/A,Specs), ( chr_pp_flag(term_indexing,on) -> spectermvars(Specs,Args,F,A,Body,Vars) ; get_constraint_type_det(F/A,ArgTypes), create_indexed_variables_body(Args,ArgModes,ArgTypes,Vars,1,F/A,MaybeBody,N), ( MaybeBody == empty -> Body = true, Vars = [] ; N == 0 -> ( Args = [Term] -> true ; Term =.. [term|Args] ), Body = term_variables(Term,Vars) ; MaybeBody = Body ) ). generate_indexed_variables_body(FA,_,_,_) <=> chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]). %=============================================================================== create_indexed_variables_body([],[],[],_,_,_,empty,0). create_indexed_variables_body([V|Vs],[Mode|Modes],[Type|Types],Vars,I,FA,Body,N) :- J is I + 1, create_indexed_variables_body(Vs,Modes,Types,Tail,J,FA,RBody,M), ( Mode == (?), is_indexed_argument(FA,I) -> ( atomic_type(Type) -> Body = ( ( var(V) -> Vars = [V|Tail] ; Vars = Tail ), Continuation ), ( RBody == empty -> Continuation = true, Tail = [] ; Continuation = RBody ) ; ( RBody == empty -> Body = term_variables(V,Vars) ; Body = (term_variables(V,Vars,Tail),RBody) ) ), N = M ; Mode == (-), is_indexed_argument(FA,I) -> ( RBody == empty -> Body = (Vars = [V]) ; Body = (Vars = [V|Tail],RBody) ), N is M + 1 ; Vars = Tail, Body = RBody, N is M + 1 ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % EXPERIMENTAL spectermvars(Specs,Args,F,A,Goal,Vars) :- spectermvars(Args,1,Specs,F,A,Vars,[],Goal). spectermvars([],B,_,_,A,L,L,true) :- B > A, !. spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :- Goal = (ArgGoal,RGoal), argspecs(Specs,I,TempArgSpecs,RSpecs), merge_argspecs(TempArgSpecs,ArgSpecs), arggoal(ArgSpecs,Arg,ArgGoal,L,L1), J is I + 1, spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal). argspecs([],_,[],[]). argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :- argspecs(Rest,I,ArgSpecs,RestSpecs). argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :- ( I == J -> ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs], ( Specs = [] -> RRestSpecs = RestSpecs ; RestSpecs = [Specs|RRestSpecs] ) ; ArgSpecs = RArgSpecs, RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs] ), argspecs(Rest,I,RArgSpecs,RRestSpecs). merge_argspecs(In,Out) :- sort(In,Sorted), merge_argspecs_(Sorted,Out). merge_argspecs_([],[]). merge_argspecs_([X],R) :- !, R = [X]. merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :- ( (F1 == any ; F2 == any) -> merge_argspecs_([specinfo(I,any,[])|Rest],R) ; F1 == F2 -> append(A1,A2,A), merge_argspecs_([specinfo(I,F1,A)|Rest],R) ; R = [specinfo(I,F1,A1)|RR], merge_argspecs_([specinfo(I,F2,A2)|Rest],RR) ). arggoal(List,Arg,Goal,L,T) :- ( List == [] -> L = T, Goal = true ; List = [specinfo(_,any,_)] -> Goal = term_variables(Arg,L,T) ; Goal = ( var(Arg) -> L = [Arg|T] ; Cases ), arggoal_cases(List,Arg,L,T,Cases) ). arggoal_cases([],_,L,T,L=T). arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :- ( ArgSpecs == [] -> Cases = RCases ; ArgSpecs == [[]] -> Cases = RCases ; FA = F/A -> Cases = (Case ; RCases), functor(Term,F,A), Term =.. [_|Args], Case = (Arg = Term -> ArgsGoal), spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal) ), arggoal_cases(Rest,Arg,L,T,RCases). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% generate_extra_clauses(Constraints,List) :- generate_activate_clauses(Constraints,List,Tail0), generate_remove_clauses(Constraints,Tail0,Tail1), generate_allocate_clauses(Constraints,Tail1,Tail2), generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3), generate_novel_production(Tail3,Tail4), generate_extend_history(Tail4,Tail5), generate_run_suspensions_clauses(Constraints,Tail5,Tail6), generate_empty_named_history_initialisations(Tail6,Tail7), Tail7 = []. %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % remove_constraint_internal/[1/3] generate_remove_clauses([],List,List). generate_remove_clauses([C|Cs],List,Tail) :- generate_remove_clause(C,List,List1), generate_remove_clauses(Cs,List1,Tail). remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) :- uses_state(Constraint,removed), ( chr_pp_flag(inline_insertremove,off) -> use_auxiliary_predicate(remove_constraint_internal,Constraint), Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ), remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal) ; delay_phase_end(validate_store_type_assumptions, generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,Goal) ) ). remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :- make_name('$remove_constraint_internal_',Constraint,Name), ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) -> Goal =.. [Name, Susp,Delete] ; Goal =.. [Name,Susp,Agenda,Delete] ). generate_remove_clause(Constraint,List,Tail) :- ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) -> List = [RemoveClause|Tail], RemoveClause = (Head :- RemoveBody), remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head), generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,active,RemoveBody) ; List = Tail ). generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Role,RemoveBody) :- ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) -> ( Role == active -> get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState), if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue), if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete) ; Role == partner -> get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,_,UpdateState), GetStateValue = true, MaybeDelete = DeleteYes ), RemoveBody = ( GetState, GetStateValue, UpdateState, MaybeDelete ) ; static_suspension_term(Constraint,Susp2), get_static_suspension_term_field(arguments,Constraint,Susp2,Args), generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda), ( chr_pp_flag(debugable,on) -> Constraint = Functor / _, get_static_suspension_term_field(functor,Constraint,Susp2,Functor) ; true ), ( Role == active -> get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState), if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue), if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete) ; Role == partner -> get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,_,UpdateState), GetStateValue = true, MaybeDelete = (IndexedVariablesBody, DeleteYes) ), RemoveBody = ( Susp = Susp2, GetStateValue, UpdateState, MaybeDelete ) ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % activate_constraint/4 generate_activate_clauses([],List,List). generate_activate_clauses([C|Cs],List,Tail) :- generate_activate_clause(C,List,List1), generate_activate_clauses(Cs,List1,Tail). activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :- ( chr_pp_flag(inline_insertremove,off) -> use_auxiliary_predicate(activate_constraint,Constraint), Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ), activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal) ; delay_phase_end(validate_store_type_assumptions, activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal) ) ). activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :- make_name('$activate_constraint_',Constraint,Name), ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) -> Goal =.. [Name,Store, Susp] ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) -> Goal =.. [Name,Store, Susp, Generation] ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) -> Goal =.. [Name,Store, Vars, Susp, Generation] ; Goal =.. [Name,Store, Vars, Susp] ). generate_activate_clause(Constraint,List,Tail) :- ( is_used_auxiliary_predicate(activate_constraint,Constraint) -> List = [Clause|Tail], Clause = (Head :- Body), activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head), activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body) ; List = Tail ). activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :- ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) -> get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration), GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration) ; GenerationHandling = true ), get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState), if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue), ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) -> if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal) ; get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal), generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars), ( chr_pp_flag(guard_locks,off) -> NoneLocked = true ; NoneLocked = 'chr none_locked'( Vars) ), if_used_state(Constraint,not_stored_yet, ( State == not_stored_yet -> ArgumentsGoal, IndexedVariablesBody, NoneLocked, StoreYes ; % Vars = [], StoreNo ), % (Vars = [],StoreNo),StoreVarsGoal) StoreNo,StoreVarsGoal) ), Body = ( GetState, GetStateValue, UpdateState, GenerationHandling, StoreVarsGoal ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % allocate_constraint/4 generate_allocate_clauses([],List,List). generate_allocate_clauses([C|Cs],List,Tail) :- generate_allocate_clause(C,List,List1), generate_allocate_clauses(Cs,List1,Tail). allocate_constraint_goal(Constraint,Susp,Args,Goal) :- uses_state(Constraint,not_stored_yet), ( chr_pp_flag(inline_insertremove,off) -> use_auxiliary_predicate(allocate_constraint,Constraint), allocate_constraint_atom(Constraint,Susp,Args,Goal) ; Goal = (Susp = Suspension, Goal0), delay_phase_end(validate_store_type_assumptions, allocate_constraint_body(Constraint,Suspension,Args,Goal0) ) ). allocate_constraint_atom(Constraint, Susp, Args,Goal) :- make_name('$allocate_constraint_',Constraint,Name), Goal =.. [Name,Susp|Args]. generate_allocate_clause(Constraint,List,Tail) :- ( is_used_auxiliary_predicate(allocate_constraint,Constraint) -> List = [Clause|Tail], Clause = (Head :- Body), Constraint = _/A, length(Args,A), allocate_constraint_atom(Constraint,Susp,Args,Head), allocate_constraint_body(Constraint,Susp,Args,Body) ; List = Tail ). allocate_constraint_body(Constraint,Susp,Args,Body) :- static_suspension_term(Constraint,Suspension), get_static_suspension_term_field(arguments,Constraint,Suspension,Args), ( chr_pp_flag(debugable,on) -> Constraint = Functor / _, get_static_suspension_term_field(functor,Constraint,Suspension,Functor) ; true ), ( chr_pp_flag(debugable,on) -> ( may_trigger(Constraint) -> append(Args,[Susp],VarsSusp), build_head(F,A,[0],VarsSusp, ContinuationGoal), get_target_module(Mod), Continuation = Mod : ContinuationGoal ; Continuation = true ), Init = (Susp = Suspension), create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation), create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration) ; may_trigger(Constraint), uses_field(Constraint,generation) -> create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration), Susp = Suspension, Init = true, CreateContinuation = true ; CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true ), ( uses_history(Constraint) -> create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory) ; CreateHistory = true ), create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState), ( has_suspension_field(Constraint,id) -> get_static_suspension_term_field(id,Constraint,Suspension,Id), GenID = 'chr gen_id'(Id) ; GenID = true ), Body = ( Init, CreateContinuation, CreateGeneration, CreateHistory, CreateState, GenID ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % insert_constraint_internal generate_insert_constraint_internal_clauses([],List,List). generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :- generate_insert_constraint_internal_clause(C,List,List1), generate_insert_constraint_internal_clauses(Cs,List1,Tail). insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :- ( chr_pp_flag(inline_insertremove,off) -> use_auxiliary_predicate(remove_constraint_internal,Constraint), insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal) ; delay_phase_end(validate_store_type_assumptions, generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal) ) ). insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :- insert_constraint_internal_constraint_name(Constraint,Name), ( chr_pp_flag(debugable,on) -> Goal =.. [Name, Vars, Self, Closure | Args] ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))-> Goal =.. [Name,Self | Args] ; Goal =.. [Name,Vars, Self | Args] ). insert_constraint_internal_constraint_name(Constraint,Name) :- make_name('$insert_constraint_internal_',Constraint,Name). generate_insert_constraint_internal_clause(Constraint,List,Tail) :- ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) -> List = [Clause|Tail], Clause = (Head :- Body), Constraint = _/A, length(Args,A), insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head), generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body) ; List = Tail ). generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :- static_suspension_term(Constraint,Suspension), create_static_suspension_field(Constraint,Suspension,state,active,CreateState), ( chr_pp_flag(debugable,on) -> get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation), create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration) ; may_trigger(Constraint), uses_field(Constraint,generation) -> create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration) ; CreateGeneration = true ), ( chr_pp_flag(debugable,on) -> Constraint = Functor / _, get_static_suspension_term_field(functor,Constraint,Suspension,Functor) ; true ), ( uses_history(Constraint) -> create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory) ; CreateHistory = true ), get_static_suspension_term_field(arguments,Constraint,Suspension,Args), List = [Clause|Tail], ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))-> suspension_term_base_fields(Constraint,BaseFields), ( has_suspension_field(Constraint,id) -> get_static_suspension_term_field(id,Constraint,Suspension,Id), GenID = 'chr gen_id'(Id) ; GenID = true ), Body = ( Susp = Suspension, CreateState, CreateGeneration, CreateHistory, GenID ) ; ( has_suspension_field(Constraint,id) -> get_static_suspension_term_field(id,Constraint,Suspension,Id), GenID = 'chr gen_id'(Id) ; GenID = true ), generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars), ( chr_pp_flag(guard_locks,off) -> NoneLocked = true ; NoneLocked = 'chr none_locked'( Vars) ), Body = ( Susp = Suspension, IndexedVariablesBody, NoneLocked, CreateState, CreateGeneration, CreateHistory, GenID ) ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % novel_production/2 generate_novel_production(List,Tail) :- ( is_used_auxiliary_predicate(novel_production) -> List = [Clause|Tail], Clause = ( '$novel_production'( Self, Tuple) :- % arg( 3, Self, Ref), % ARGXXX % 'chr get_mutable'( History, Ref), arg( 3, Self, History), % ARGXXX ( hprolog:get_ds( Tuple, History, _) -> fail ; true ) ) ; List = Tail ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % extend_history/2 generate_extend_history(List,Tail) :- ( is_used_auxiliary_predicate(extend_history) -> List = [Clause|Tail], Clause = ( '$extend_history'( Self, Tuple) :- % arg( 3, Self, Ref), % ARGXXX % 'chr get_mutable'( History, Ref), arg( 3, Self, History), % ARGXXX hprolog:put_ds( Tuple, History, x, NewHistory), setarg( 3, Self, NewHistory) % ARGXXX ) ; List = Tail ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % :- chr_constraint empty_named_history_initialisations/2, generate_empty_named_history_initialisation/1, find_empty_named_histories/0. generate_empty_named_history_initialisations(List, Tail) :- empty_named_history_initialisations(List, Tail), find_empty_named_histories. find_empty_named_histories, history(_, Name, []) ==> generate_empty_named_history_initialisation(Name). generate_empty_named_history_initialisation(Name) \ generate_empty_named_history_initialisation(Name) <=> true. generate_empty_named_history_initialisation(Name) \ empty_named_history_initialisations(List, Tail) # Passive <=> empty_named_history_global_variable(Name, GlobalVariable), List = [(:- nb_setval(GlobalVariable, 0))|Rest], empty_named_history_initialisations(Rest, Tail) pragma passive(Passive). find_empty_named_histories \ generate_empty_named_history_initialisation(_) # Passive <=> true pragma passive(Passive). find_empty_named_histories, empty_named_history_initialisations(List, Tail) # Passive <=> List = Tail pragma passive(Passive). find_empty_named_histories <=> chr_error(internal, 'find_empty_named_histories was not removed', []). empty_named_history_global_variable(Name, GlobalVariable) :- atom_concat('chr empty named history ', Name, GlobalVariable). empty_named_history_novel_production(Name, nb_getval(GlobalVariable, 0)) :- empty_named_history_global_variable(Name, GlobalVariable). empty_named_history_extend_history(Name, b_setval(GlobalVariable, 1)) :- empty_named_history_global_variable(Name, GlobalVariable). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- % run_suspensions/2 generate_run_suspensions_clauses([],List,List). generate_run_suspensions_clauses([C|Cs],List,Tail) :- generate_run_suspensions_clause(C,List,List1), generate_run_suspensions_clauses(Cs,List1,Tail). run_suspensions_goal(Constraint,Suspensions,Goal) :- make_name('$run_suspensions_',Constraint,Name), Goal =.. [Name,Suspensions]. generate_run_suspensions_clause(Constraint,List,Tail) :- ( is_used_auxiliary_predicate(run_suspensions,Constraint) -> List = [Clause1,Clause2|Tail], run_suspensions_goal(Constraint,[],Clause1), ( chr_pp_flag(debugable,on) -> run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head), get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState), get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost), get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration), get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation), run_suspensions_goal(Constraint,Suspensions,Clause2Recursion), Clause2 = ( Clause2Head :- GetState, GetStateValue, ( State==active -> UpdateState, GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration, GetContinuation, ( 'chr debug_event'(wake(Suspension)), call(Continuation) ; 'chr debug_event'(fail(Suspension)), !, fail ), ( 'chr debug_event'(exit(Suspension)) ; 'chr debug_event'(redo(Suspension)), fail ), GetPost, GetPostValue, ( Post==triggered -> UpdatePost % catching constraints that did not do anything ; true ) ; true ), Clause2Recursion ) ; run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head), static_suspension_term(Constraint,SuspensionTerm), get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments), append(Arguments,[Suspension],VarsSusp), make_suspension_continuation_goal(Constraint,VarsSusp,Continuation), run_suspensions_goal(Constraint,Suspensions,Clause2Recursion), ( uses_field(Constraint,generation) -> get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration), GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration) ; GenerationHandling = true ), get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState), get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState), if_used_state(Constraint,removed, ( GetState, ( State==active -> ReactivateConstraint ; true) ),ReactivateConstraint,CondReactivate), ReactivateConstraint = ( UpdateState, GenerationHandling, Continuation, GetPostState, ( Post==triggered -> UpdatePostState % catching constraints that did not do anything ; true ) ), Clause2 = ( Clause2Head :- Suspension = SuspensionTerm, CondReactivate, Clause2Recursion ) ) ; List = Tail ). %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% generate_attach_increment(Clauses) :- get_max_constraint_index(N), ( is_used_auxiliary_predicate(attach_increment), N > 0 -> Clauses = [Clause1,Clause2], generate_attach_increment_empty(Clause1), ( N == 1 -> generate_attach_increment_one(Clause2) ; generate_attach_increment_many(N,Clause2) ) ; Clauses = [] ). generate_attach_increment_empty((attach_increment([],_) :- true)). generate_attach_increment_one(Clause) :- Head = attach_increment([Var|Vars],Susps), get_target_module(Mod), ( chr_pp_flag(guard_locks,off) -> NotLocked = true ; NotLocked = 'chr not_locked'( Var) ), Body = ( NotLocked, ( get_attr(Var,Mod,VarSusps) -> sort(VarSusps,SortedVarSusps), 'chr merge_attributes'(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) :- Head = attach_increment([Var|Vars],TAttr1), % writeln(merge_attributes_1_before), merge_attributes(N,TAttr1,TAttr2,MergeGoal,Attr), % writeln(merge_attributes_1_after), get_target_module(Mod), ( chr_pp_flag(guard_locks,off) -> NotLocked = true ; NotLocked = 'chr not_locked'( Var) ), Body = ( NotLocked, ( get_attr(Var,Mod,TAttr2) -> MergeGoal, put_attr(Var,Mod,Attr) ; put_attr(Var,Mod,TAttr1) ), attach_increment(Vars,TAttr1) ), Clause = (Head :- Body). %% attr_unify_hook generate_attr_unify_hook(Clauses) :- get_max_constraint_index(N), ( N == 0 -> Clauses = [] ; ( N == 1 -> generate_attr_unify_hook_one(Clauses) ; generate_attr_unify_hook_many(N,Clauses) ) ). generate_attr_unify_hook_one([Clause]) :- Head = attr_unify_hook(Susps,Other), get_target_module(Mod), get_indexed_constraint(1,C), ( get_store_type(C,ST), ( ST = default ; ST = multi_store(STs), member(default,STs) ) -> make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps), make_run_suspensions(SortedSusps,SortedSusps,WakeSusps), ( atomic_types_suspended_constraint(C) -> SortGoal1 = true, SortedSusps = Susps, SortGoal2 = true, SortedOtherSusps = OtherSusps, MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)), NonvarBody = true ; SortGoal1 = sort(Susps, SortedSusps), SortGoal2 = sort(OtherSusps,SortedOtherSusps), MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps), use_auxiliary_predicate(attach_increment), NonvarBody = ( compound(Other) -> term_variables(Other,OtherVars), attach_increment(OtherVars, SortedSusps) ; true ) ), Body = ( SortGoal1, ( var(Other) -> ( get_attr(Other,Mod,OtherSusps) -> SortGoal2, MergeGoal, put_attr(Other,Mod,NewSusps), WakeNewSusps ; put_attr(Other,Mod,SortedSusps), WakeSusps ) ; NonvarBody, WakeSusps ) ), Clause = (Head :- Body) ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) -> make_run_suspensions(List,List,WakeNewSusps), MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)), Body = ( get_attr(Other,Mod,OtherSusps) -> MergeGoal, WakeNewSusps ; put_attr(Other,Mod,Susps) ), Clause = (Head :- Body) ). generate_attr_unify_hook_many(N,[Clause]) :- chr_pp_flag(dynattr,off), !, Head = attr_unify_hook(Attr,Other), get_target_module(Mod), make_attr(N,Mask,SuspsList,Attr), bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList), list2conj(SortGoalList,SortGoals), bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList), merge_attributes2(N,Mask,SortedSuspsList,TOtherAttr,MergeGoal,MergedAttr), get_all_suspensions2(N,MergedAttr,MergedSuspsList), make_attr(N,Mask,SortedSuspsList,SortedAttr), make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps), make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps), ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) -> NonvarBody = true ; use_auxiliary_predicate(attach_increment), NonvarBody = ( compound(Other) -> term_variables(Other,OtherVars), attach_increment(OtherVars,SortedAttr) ; true ) ), Body = ( SortGoals, ( var(Other) -> ( get_attr(Other,Mod,TOtherAttr) -> MergeGoal, put_attr(Other,Mod,MergedAttr), WakeMergedSusps ; put_attr(Other,Mod,SortedAttr), WakeSortedSusps ) ; NonvarBody, WakeSortedSusps ) ), Clause = (Head :- Body). % NEW generate_attr_unify_hook_many(N,Clauses) :- Head = attr_unify_hook(Attr,Other), get_target_module(Mod), normalize_attr(Attr,NormalGoal,NormalAttr), normalize_attr(OtherAttr,NormalOtherGoal,NormalOtherAttr), merge_attributes(N,NormalAttr,NormalOtherAttr,MergeGoal,MergedAttr), make_run_suspensions(N), ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) -> NonvarBody = true ; use_auxiliary_predicate(attach_increment), NonvarBody = ( compound(Other) -> term_variables(Other,OtherVars), attach_increment(OtherVars,NormalAttr) ; true ) ), Body = ( NormalGoal, ( var(Other) -> ( get_attr(Other,Mod,OtherAttr) -> NormalOtherGoal, MergeGoal, put_attr(Other,Mod,MergedAttr), '$dispatch_run_suspensions'(MergedAttr) ; put_attr(Other,Mod,NormalAttr), '$dispatch_run_suspensions'(NormalAttr) ) ; NonvarBody, '$dispatch_run_suspensions'(NormalAttr) ) ), Clause = (Head :- Body), Clauses = [Clause,DispatchList1,DispatchList2|Dispatchers], DispatchList1 = ('$dispatch_run_suspensions'([])), DispatchList2 = ('$dispatch_run_suspensions'([Pos-List|Rest]) :- '$dispatch_run_suspensions'(Pos,List),'$dispatch_run_suspensions'(Rest)), run_suspensions_dispatchers(N,[],Dispatchers). % NEW run_suspensions_dispatchers(N,Acc,Dispatchers) :- ( N > 0 -> get_indexed_constraint(N,C), NAcc = [('$dispatch_run_suspensions'(N,List) :- Body)|Acc], ( may_trigger(C) -> run_suspensions_goal(C,List,Body) ; Body = true ), M is N - 1, run_suspensions_dispatchers(M,NAcc,Dispatchers) ; Dispatchers = Acc ). % NEW make_run_suspensions(N) :- ( N > 0 -> ( get_indexed_constraint(N,C), may_trigger(C) -> use_auxiliary_predicate(run_suspensions,C) ; true ), M is N - 1, make_run_suspensions(M) ; true ). make_run_suspensions(AllSusps,OneSusps,Goal) :- make_run_suspensions(1,AllSusps,OneSusps,Goal). make_run_suspensions(Index,AllSusps,OneSusps,Goal) :- ( get_indexed_constraint(Index,C), may_trigger(C) -> use_auxiliary_predicate(run_suspensions,C), ( wakes_partially(C) -> run_suspensions_goal(C,OneSusps,Goal) ; run_suspensions_goal(C,AllSusps,Goal) ) ; Goal = true ). make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :- make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal). make_run_suspensions_loop([],[],_,true). make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :- make_run_suspensions(I,AllSusps,OneSusps,Goal), J is I + 1, make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % $insert_in_store_F/A % $delete_from_store_F/A generate_insert_delete_constraints([],[]). generate_insert_delete_constraints([FA|Rest],Clauses) :- ( is_stored(FA) -> generate_insert_delete_constraint(FA,Clauses,RestClauses) ; Clauses = RestClauses ), generate_insert_delete_constraints(Rest,RestClauses). generate_insert_delete_constraint(FA,Clauses,RestClauses) :- insert_constraint_clause(FA,Clauses,RestClauses1), delete_constraint_clause(FA,RestClauses1,RestClauses). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % insert_in_store insert_constraint_goal(FA,Susp,Vars,Goal) :- ( chr_pp_flag(inline_insertremove,off) -> use_auxiliary_predicate(insert_in_store,FA), insert_constraint_atom(FA,Susp,Goal) ; delay_phase_end(validate_store_type_assumptions, ( insert_constraint_body(FA,Susp,UsedVars,Goal), insert_constraint_direct_used_vars(UsedVars,Vars) ) ) ). insert_constraint_direct_used_vars([],_). insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :- nth1(Index,Vars,Var), insert_constraint_direct_used_vars(Rest,Vars). insert_constraint_atom(FA,Susp,Call) :- make_name('$insert_in_store_',FA,Functor), Call =.. [Functor,Susp]. insert_constraint_clause(C,Clauses,RestClauses) :- ( is_used_auxiliary_predicate(insert_in_store,C) -> Clauses = [Clause|RestClauses], Clause = (Head :- InsertCounterInc,VarsBody,Body), insert_constraint_atom(C,Susp,Head), insert_constraint_body(C,Susp,UsedVars,Body), insert_constraint_used_vars(UsedVars,C,Susp,VarsBody), ( chr_pp_flag(store_counter,on) -> InsertCounterInc = '$insert_counter_inc' ; InsertCounterInc = true ) ; Clauses = RestClauses ). insert_constraint_used_vars([],_,_,true). insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :- get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal), insert_constraint_used_vars(Rest,C,Susp,Goals). insert_constraint_body(C,Susp,UsedVars,Body) :- get_store_type(C,StoreType), insert_constraint_body(StoreType,C,Susp,UsedVars,Body). insert_constraint_body(default,C,Susp,[],Body) :- global_list_store_name(C,StoreName), make_get_store_goal(StoreName,Store,GetStoreGoal), make_update_store_goal(StoreName,Cell,UpdateStoreGoal), ( chr_pp_flag(debugable,on) -> Cell = [Susp|Store], Body = ( GetStoreGoal, UpdateStoreGoal ) ; set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal), Body = ( GetStoreGoal, Cell = [Susp|Store], UpdateStoreGoal, ( Store = [NextSusp|_] -> SetGoal ; true ) ) ). % get_target_module(Mod), % get_max_constraint_index(Total), % ( Total == 1 -> % generate_attach_body_1(C,Store,Susp,AttachBody) % ; % generate_attach_body_n(C,Store,Susp,AttachBody) % ), % Body = % ( % 'chr default_store'(Store), % AttachBody % ). insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :- generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body). insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :- generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars), sort_out_used_vars(MixedUsedVars,UsedVars). insert_constraint_body(global_ground,C,Susp,[],Body) :- global_ground_store_name(C,StoreName), make_get_store_goal(StoreName,Store,GetStoreGoal), make_update_store_goal(StoreName,Cell,UpdateStoreGoal), ( chr_pp_flag(debugable,on) -> Cell = [Susp|Store], Body = ( GetStoreGoal, UpdateStoreGoal ) ; set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal), Body = ( GetStoreGoal, Cell = [Susp|Store], UpdateStoreGoal, ( Store = [NextSusp|_] -> SetGoal ; true ) ) ). % global_ground_store_name(C,StoreName), % make_get_store_goal(StoreName,Store,GetStoreGoal), % make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal), % Body = % ( % GetStoreGoal, % nb_getval(StoreName,Store), % UpdateStoreGoal % b_setval(StoreName,[Susp|Store]) % ). insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :- % TODO: generalize to more than one !!! get_target_module(Module), Body = ( get_attr(Variable,Module,AssocStore) -> insert_assoc_store(AssocStore,Key,Susp) ; new_assoc_store(AssocStore), put_attr(Variable,Module,AssocStore), insert_assoc_store(AssocStore,Key,Susp) ). insert_constraint_body(global_singleton,C,Susp,[],Body) :- global_singleton_store_name(C,StoreName), make_update_store_goal(StoreName,Susp,UpdateStoreGoal), Body = ( UpdateStoreGoal ). insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :- find_with_var_identity( B-UV, [Susp], ( member(ST,StoreTypes), chr_translate:insert_constraint_body(ST,C,Susp,UV,B) ), BodiesUsedVars ), once(pairup(Bodies,NestedUsedVars,BodiesUsedVars)), list2conj(Bodies,Body), sort_out_used_vars(NestedUsedVars,UsedVars). insert_constraint_body(identifier_store(Index),C,Susp,UsedVars,Body) :- UsedVars = [Index-Var], get_identifier_size(ISize), functor(Struct,struct,ISize), get_identifier_index(C,Index,IIndex), arg(IIndex,Struct,Susps), Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])). insert_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Susp,UsedVars,Body) :- UsedVars = [Index-Var], type_indexed_identifier_structure(IndexType,Struct), get_type_indexed_identifier_index(IndexType,C,Index,IIndex), arg(IIndex,Struct,Susps), Body = (Var = Struct, setarg(IIndex,Var,[Susp|Susps])). sort_out_used_vars(NestedUsedVars,UsedVars) :- flatten(NestedUsedVars,FlatUsedVars), sort(FlatUsedVars,SortedFlatUsedVars), sort_out_used_vars1(SortedFlatUsedVars,UsedVars). sort_out_used_vars1([],[]). sort_out_used_vars1([I-V],L) :- !, L = [I-V]. sort_out_used_vars1([I-X,J-Y|R],L) :- ( I == J -> X = Y, sort_out_used_vars1([I-X|R],L) ; L = [I-X|T], sort_out_used_vars1([J-Y|R],T) ). generate_multi_inthash_insert_constraint_bodies([],_,_,true). generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :- multi_hash_store_name(FA,Index,StoreName), multi_hash_key(FA,Index,Susp,KeyBody,Key), Body = ( KeyBody, nb_getval(StoreName,Store), insert_iht(Store,Key,Susp) ), generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies). generate_multi_hash_insert_constraint_bodies([],_,_,true,[]). generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :- multi_hash_store_name(FA,Index,StoreName), multi_hash_key_direct(FA,Index,Susp,Key,UsedVars), make_get_store_goal(StoreName,Store,GetStoreGoal), ( chr_pp_flag(ht_removal,on) -> ht_prev_field(Index,PrevField), set_dynamic_suspension_term_field(PrevField,FA,NextSusp,Result, SetGoal), Body = ( GetStoreGoal, insert_ht(Store,Key,Susp,Result), ( Result = [_,NextSusp|_] -> SetGoal ; true ) ) ; Body = ( GetStoreGoal, insert_ht(Store,Key,Susp) ) ), generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % Delete delete_constraint_clause(C,Clauses,RestClauses) :- ( is_used_auxiliary_predicate(delete_from_store,C) -> Clauses = [Clause|RestClauses], Clause = (Head :- Body), delete_constraint_atom(C,Susp,Head), C = F/A, functor(Head,F,A), delete_constraint_body(C,Head,Susp,[],Body) ; Clauses = RestClauses ). delete_constraint_goal(Head,Susp,VarDict,Goal) :- functor(Head,F,A), C = F/A, ( chr_pp_flag(inline_insertremove,off) -> use_auxiliary_predicate(delete_from_store,C), delete_constraint_atom(C,Susp,Goal) ; delay_phase_end(validate_store_type_assumptions, delete_constraint_body(C,Head,Susp,VarDict,Goal)) ). delete_constraint_atom(C,Susp,Atom) :- make_name('$delete_from_store_',C,Functor), Atom =.. [Functor,Susp]. delete_constraint_body(C,Head,Susp,VarDict,Body) :- Body = (CounterBody,DeleteBody), ( chr_pp_flag(store_counter,on) -> CounterBody = '$delete_counter_inc' ; CounterBody = true ), get_store_type(C,StoreType), delete_constraint_body(StoreType,C,Head,Susp,VarDict,DeleteBody). delete_constraint_body(default,C,_,Susp,_,Body) :- ( chr_pp_flag(debugable,on) -> global_list_store_name(C,StoreName), make_get_store_goal(StoreName,Store,GetStoreGoal), make_update_store_goal(StoreName,NStore,UpdateStoreGoal), Body = ( GetStoreGoal, % nb_getval(StoreName,Store), 'chr sbag_del_element'(Store,Susp,NStore), UpdateStoreGoal % b_setval(StoreName,NStore) ) ; get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal), global_list_store_name(C,StoreName), make_get_store_goal(StoreName,Store,GetStoreGoal), make_update_store_goal(StoreName,Tail,UpdateStoreGoal), set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1), set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2), Body = ( GetGoal, ( var(PredCell) -> GetStoreGoal, % nb_getval(StoreName,Store), Store = [_|Tail], UpdateStoreGoal, ( Tail = [NextSusp|_] -> SetGoal1 ; true ) ; PredCell = [_,_|Tail], setarg(2,PredCell,Tail), ( Tail = [NextSusp|_] -> SetGoal2 ; true ) ) ) ). % get_target_module(Mod), % get_max_constraint_index(Total), % ( Total == 1 -> % generate_detach_body_1(C,Store,Susp,DetachBody), % Body = % ( % 'chr default_store'(Store), % DetachBody % ) % ; % generate_detach_body_n(C,Store,Susp,DetachBody), % Body = % ( % 'chr default_store'(Store), % DetachBody % ) % ). delete_constraint_body(multi_inthash(Indexes),C,_,Susp,_,Body) :- generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body). delete_constraint_body(multi_hash(Indexes),C,Head,Susp,VarDict,Body) :- generate_multi_hash_delete_constraint_bodies(Indexes,C,Head,Susp,VarDict,Body). delete_constraint_body(global_ground,C,_,Susp,_,Body) :- ( chr_pp_flag(debugable,on) -> global_ground_store_name(C,StoreName), make_get_store_goal(StoreName,Store,GetStoreGoal), make_update_store_goal(StoreName,NStore,UpdateStoreGoal), Body = ( GetStoreGoal, % nb_getval(StoreName,Store), 'chr sbag_del_element'(Store,Susp,NStore), UpdateStoreGoal % b_setval(StoreName,NStore) ) ; get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal), global_ground_store_name(C,StoreName), make_get_store_goal(StoreName,Store,GetStoreGoal), make_update_store_goal(StoreName,Tail,UpdateStoreGoal), set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1), set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2), Body = ( GetGoal, ( var(PredCell) -> GetStoreGoal, % nb_getval(StoreName,Store), Store = [_|Tail], UpdateStoreGoal, ( Tail = [NextSusp|_] -> SetGoal1 ; true ) ; PredCell = [_,_|Tail], setarg(2,PredCell,Tail), ( Tail = [NextSusp|_] -> SetGoal2 ; true ) ) ) ). % global_ground_store_name(C,StoreName), % make_get_store_goal(StoreName,Store,GetStoreGoal), % make_update_store_goal(StoreName,NStore,UpdateStoreGoal), % Body = % ( % GetStoreGoal, % nb_getval(StoreName,Store), % 'chr sbag_del_element'(Store,Susp,NStore), % UpdateStoreGoal % b_setval(StoreName,NStore) % ). delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,_,Susp,_,Body) :- get_target_module(Module), get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal), get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal), Body = ( VariableGoal, get_attr(Variable,Module,AssocStore), KeyGoal, delete_assoc_store(AssocStore,Key,Susp) ). delete_constraint_body(global_singleton,C,_,_Susp,_,Body) :- global_singleton_store_name(C,StoreName), make_update_store_goal(StoreName,[],UpdateStoreGoal), Body = ( UpdateStoreGoal % b_setval(StoreName,[]) ). delete_constraint_body(multi_store(StoreTypes),C,Head,Susp,VarDict,Body) :- find_with_var_identity( B, [Susp/VarDict/Head], ( member(ST,StoreTypes), chr_translate:delete_constraint_body(ST,C,Head,Susp,VarDict,B) ), Bodies ), list2conj(Bodies,Body). delete_constraint_body(identifier_store(Index),C,Head,Susp,VarDict,Body) :- get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal), get_identifier_size(ISize), functor(Struct,struct,ISize), get_identifier_index(C,Index,IIndex), arg(IIndex,Struct,Susps), Body = ( VariableGoal, Variable = Struct, 'chr sbag_del_element'(Susps,Susp,NSusps), setarg(IIndex,Variable,NSusps) ). delete_constraint_body(type_indexed_identifier_store(Index,IndexType),C,Head,Susp,VarDict,Body) :- get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Variable,VariableGoal), type_indexed_identifier_structure(IndexType,Struct), get_type_indexed_identifier_index(IndexType,C,Index,IIndex), arg(IIndex,Struct,Susps), Body = ( VariableGoal, Variable = Struct, 'chr sbag_del_element'(Susps,Susp,NSusps), setarg(IIndex,Variable,NSusps) ). generate_multi_inthash_delete_constraint_bodies([],_,_,true). generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :- multi_hash_store_name(FA,Index,StoreName), multi_hash_key(FA,Index,Susp,KeyBody,Key), Body = ( KeyBody, nb_getval(StoreName,Store), delete_iht(Store,Key,Susp) ), generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies). generate_multi_hash_delete_constraint_bodies([],_,_,_,_,true). generate_multi_hash_delete_constraint_bodies([Index|Indexes],C,Head,Susp,VarDict,(Body,Bodies)) :- multi_hash_store_name(C,Index,StoreName), multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key), make_get_store_goal(StoreName,Store,GetStoreGoal), ( chr_pp_flag(ht_removal,on) -> ht_prev_field(Index,PrevField), get_dynamic_suspension_term_field(PrevField,C,Susp,Prev,GetGoal), set_dynamic_suspension_term_field(PrevField,C,NextSusp,_, SetGoal1), set_dynamic_suspension_term_field(PrevField,C,NextSusp,Prev, SetGoal2), Body = ( GetGoal, ( var(Prev) -> GetStoreGoal, KeyBody, delete_first_ht(Store,Key,Values), ( Values = [NextSusp|_] -> SetGoal1 ; true ) ; Prev = [_,_|Values], setarg(2,Prev,Values), ( Values = [NextSusp|_] -> SetGoal2 ; true ) ) ) ; Body = ( KeyBody, GetStoreGoal, % nb_getval(StoreName,Store), delete_ht(Store,Key,Susp) ) ), generate_multi_hash_delete_constraint_bodies(Indexes,FA,Head,Susp,VarDict,Bodies). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint module_initializer/1, module_initializers/1. module_initializers(G), module_initializer(Initializer) <=> G = (Initializer,Initializers), module_initializers(Initializers). module_initializers(G) <=> G = true. generate_attach_code(Constraints,[Enumerate|L]) :- enumerate_stores_code(Constraints,Enumerate), generate_attach_code(Constraints,L,T), module_initializers(Initializers), prolog_global_variables_code(PrologGlobalVariables), T = [('$chr_initialization' :- Initializers),(:- '$chr_initialization')|PrologGlobalVariables]. generate_attach_code([],L,L). generate_attach_code([C|Cs],L,T) :- get_store_type(C,StoreType), generate_attach_code(StoreType,C,L,L1), generate_attach_code(Cs,L1,T). generate_attach_code(default,C,L,T) :- global_list_store_initialisation(C,L,T). generate_attach_code(multi_inthash(Indexes),C,L,T) :- multi_inthash_store_initialisations(Indexes,C,L,L1), multi_inthash_via_lookups(Indexes,C,L1,T). generate_attach_code(multi_hash(Indexes),C,L,T) :- multi_hash_store_initialisations(Indexes,C,L,L1), multi_hash_via_lookups(Indexes,C,L1,T). generate_attach_code(global_ground,C,L,T) :- global_ground_store_initialisation(C,L,T). generate_attach_code(var_assoc_store(_,_),_,L,L) :- use_auxiliary_module(chr_assoc_store). generate_attach_code(global_singleton,C,L,T) :- global_singleton_store_initialisation(C,L,T). generate_attach_code(multi_store(StoreTypes),C,L,T) :- multi_store_generate_attach_code(StoreTypes,C,L,T). generate_attach_code(identifier_store(Index),C,L,T) :- get_identifier_index(C,Index,IIndex), ( IIndex == 2 -> get_identifier_size(ISize), functor(Struct,struct,ISize), Struct =.. [_,Label|Stores], set_elems(Stores,[]), Clause1 = new_identifier(Label,Struct), functor(Struct2,struct,ISize), arg(1,Struct2,Label2), Clause2 = ( user:portray(Struct2) :- write('') ), functor(Struct3,struct,ISize), arg(1,Struct3,Label3), Clause3 = identifier_label(Struct3,Label3), L = [Clause1,Clause2,Clause3|T] ; L = T ). generate_attach_code(type_indexed_identifier_store(Index,IndexType),C,L,T) :- get_type_indexed_identifier_index(IndexType,C,Index,IIndex), ( IIndex == 2 -> identifier_store_initialization(IndexType,L,L1), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% get_type_indexed_identifier_size(IndexType,ISize), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% type_indexed_identifier_structure(IndexType,Struct), Struct =.. [_,Label|Stores], set_elems(Stores,[]), type_indexed_identifier_name(IndexType,new_identifier,Name1), Clause1 =.. [Name1,Label,Struct], %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% Goal1 =.. [Name1,Label1b,S1b], type_indexed_identifier_structure(IndexType,Struct1b), Struct1b =.. [_,Label1b|Stores1b], set_elems(Stores1b,[]), Expansion1 = (S1b = Struct1b), Clause1b = user:goal_expansion(Goal1,Expansion1), % writeln(Clause1-Clause1b), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% type_indexed_identifier_structure(IndexType,Struct2), arg(1,Struct2,Label2), Clause2 = ( user:portray(Struct2) :- write('') ), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% type_indexed_identifier_structure(IndexType,Struct3), arg(1,Struct3,Label3), type_indexed_identifier_name(IndexType,identifier_label,Name3), Clause3 =.. [Name3,Struct3,Label3], %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% Goal3b =.. [Name3,S3b,L3b], type_indexed_identifier_structure(IndexType,Struct3b), arg(1,Struct3b,L3b), Expansion3b = (S3 = Struct3b), Clause3b = ( user:goal_expansion(Goal3b,Expansion3b) :- writeln(expanding)), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% identifier_store_name(IndexType,GlobalVariable), lookup_identifier_atom(IndexType,X,IX,LookupAtom), type_indexed_identifier_name(IndexType,new_identifier,NewIdentifierFunctor), NewIdentifierGoal =.. [NewIdentifierFunctor,X,IX], Clause4 = ( LookupAtom :- nb_getval(GlobalVariable,HT), ( lookup_ht(HT,X,[IX]) -> true ; NewIdentifierGoal, insert_ht(HT,X,IX) ) ), %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% L1 = [(:- multifile goal_expansion/2),(:- dynamic goal_expansion/2),Clause1,Clause1b,Clause2,Clause3,Clause3b,Clause4|T] ; L = T ). lookup_identifier_atom(Key,X,IX,Atom) :- atom_concat('lookup_identifier_',Key,LookupFunctor), Atom =.. [LookupFunctor,X,IX]. identifier_label_atom(IndexType,IX,X,Atom) :- type_indexed_identifier_name(IndexType,identifier_label,Name), Atom =.. [Name,IX,X]. multi_store_generate_attach_code([],_,L,L). multi_store_generate_attach_code([ST|STs],C,L,T) :- generate_attach_code(ST,C,L,L1), multi_store_generate_attach_code(STs,C,L1,T). multi_inthash_store_initialisations([],_,L,L). multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :- use_auxiliary_module(chr_integertable_store), multi_hash_store_name(FA,Index,StoreName), module_initializer((new_iht(HT),nb_setval(StoreName,HT))), % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1], L1 = L, multi_inthash_store_initialisations(Indexes,FA,L1,T). multi_hash_store_initialisations([],_,L,L). multi_hash_store_initialisations([Index|Indexes],FA,L,T) :- use_auxiliary_module(chr_hashtable_store), multi_hash_store_name(FA,Index,StoreName), prolog_global_variable(StoreName), make_init_store_goal(StoreName,HT,InitStoreGoal), module_initializer((new_ht(HT),InitStoreGoal)), L1 = L, multi_hash_store_initialisations(Indexes,FA,L1,T). global_list_store_initialisation(C,L,T) :- ( is_stored(C) -> global_list_store_name(C,StoreName), prolog_global_variable(StoreName), make_init_store_goal(StoreName,[],InitStoreGoal), module_initializer(InitStoreGoal) ; true ), L = T. global_ground_store_initialisation(C,L,T) :- global_ground_store_name(C,StoreName), prolog_global_variable(StoreName), make_init_store_goal(StoreName,[],InitStoreGoal), module_initializer(InitStoreGoal), L = T. global_singleton_store_initialisation(C,L,T) :- global_singleton_store_name(C,StoreName), prolog_global_variable(StoreName), make_init_store_goal(StoreName,[],InitStoreGoal), module_initializer(InitStoreGoal), L = T. identifier_store_initialization(IndexType,L,T) :- use_auxiliary_module(chr_hashtable_store), identifier_store_name(IndexType,StoreName), prolog_global_variable(StoreName), make_init_store_goal(StoreName,HT,InitStoreGoal), module_initializer((new_ht(HT),InitStoreGoal)), L = T. multi_inthash_via_lookups([],_,L,L). multi_inthash_via_lookups([Index|Indexes],C,L,T) :- multi_hash_via_lookup_goal(C,Index,Key,SuspsList,Head), multi_hash_store_name(C,Index,StoreName), Body = ( nb_getval(StoreName,HT), lookup_iht(HT,Key,SuspsList) ), L = [(Head :- Body)|L1], multi_inthash_via_lookups(Indexes,C,L1,T). multi_hash_via_lookups([],_,L,L). multi_hash_via_lookups([Index|Indexes],C,L,T) :- multi_hash_via_lookup_goal(C,Index,Key,SuspsList,Head), multi_hash_store_name(C,Index,StoreName), make_get_store_goal(StoreName,HT,GetStoreGoal), Body = ( GetStoreGoal, % nb_getval(StoreName,HT), lookup_ht(HT,Key,SuspsList) ), L = [(Head :- Body)|L1], multi_hash_via_lookups(Indexes,C,L1,T). %% multi_hash_via_lookup_goal(+ConstraintSymbol,+Index,+Key,+SuspsList,-Goal) is det. % % Returns goal that performs hash table lookup. multi_hash_via_lookup_goal(ConstraintSymbol,Index,Key,SuspsList,Goal) :- multi_hash_via_lookup_name(ConstraintSymbol,Index,Name), Goal =.. [Name,Key,SuspsList]. %% multi_hash_via_lookup_name(+ConstraintSymbol,+Index,-Name) % % Returns predicate name of hash table lookup predicate. multi_hash_via_lookup_name(F/A,Index,Name) :- ( integer(Index) -> IndexName = Index ; is_list(Index) -> atom_concat_list(Index,IndexName) ), atom_concat_list(['$via1_multi_hash_',F,'___',A,'-',IndexName],Name). multi_hash_store_name(F/A,Index,Name) :- get_target_module(Mod), ( integer(Index) -> IndexName = Index ; is_list(Index) -> atom_concat_list(Index,IndexName) ), atom_concat_list(['$chr_store_multi_hash_',Mod,'____',F,'___',A,'-',IndexName],Name). multi_hash_key(FA,Index,Susp,KeyBody,Key) :- ( ( integer(Index) -> I = Index ; Index = [I] ) -> get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody) ; is_list(Index) -> sort(Index,Indexes), find_with_var_identity(Goal-KeyI,[Susp],(member(I,Indexes),get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal)),ArgKeyPairs), once(pairup(Bodies,Keys,ArgKeyPairs)), Key =.. [k|Keys], list2conj(Bodies,KeyBody) ). multi_hash_key(C,Head,Index,Susp,VarDict,KeyBody,Key) :- ( ( integer(Index) -> I = Index ; Index = [I] ) -> get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,Key,KeyBody) ; is_list(Index) -> sort(Index,Indexes), find_with_var_identity( Goal-KeyI, [Susp/Head/VarDict], ( member(I,Indexes), get_suspension_argument_possibly_in_scope(Head,I,VarDict,Susp,KeyI,Goal) ), ArgKeyPairs ), once(pairup(Bodies,Keys,ArgKeyPairs)), Key =.. [k|Keys], list2conj(Bodies,KeyBody) ). get_suspension_argument_possibly_in_scope(Head,Index,VarDict,Susp,Arg,Goal) :- arg(Index,Head,OriginalArg), ( lookup_eq(VarDict,OriginalArg,Arg) -> Goal = true ; functor(Head,F,A), C = F/A, get_dynamic_suspension_term_field(argument(Index),C,Susp,Arg,Goal) ). multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :- ( ( integer(Index) -> I = Index ; Index = [I] ) -> UsedVars = [I-Key] ; is_list(Index) -> sort(Index,Indexes), pairup(Indexes,Keys,UsedVars), Key =.. [k|Keys] ). multi_hash_key_args(Index,Head,KeyArgs) :- ( integer(Index) -> arg(Index,Head,Arg), KeyArgs = [Arg] ; is_list(Index) -> sort(Index,Indexes), term_variables(Head,Vars), find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs) ). global_list_store_name(F/A,Name) :- get_target_module(Mod), atom_concat_list(['$chr_store_global_list_',Mod,'____',F,'___',A],Name). global_ground_store_name(F/A,Name) :- get_target_module(Mod), atom_concat_list(['$chr_store_global_ground_',Mod,'____',F,'___',A],Name). global_singleton_store_name(F/A,Name) :- get_target_module(Mod), atom_concat_list(['$chr_store_global_singleton_',Mod,'____',F,'___',A],Name). identifier_store_name(TypeName,Name) :- get_target_module(Mod), atom_concat_list(['$chr_identifier_lookup_',Mod,'____',TypeName],Name). :- chr_constraint prolog_global_variable/1. :- chr_option(mode,prolog_global_variable(+)). :- chr_constraint prolog_global_variables/1. :- chr_option(mode,prolog_global_variables(-)). prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true. prolog_global_variables(List), prolog_global_variable(Name) <=> List = [Name|Tail], prolog_global_variables(Tail). prolog_global_variables(List) <=> List = []. %% SWI begin prolog_global_variables_code(Code) :- prolog_global_variables(Names), ( Names == [] -> Code = [] ; findall('$chr_prolog_global_variable'(Name),member(Name,Names),NameDeclarations), Code = [(:- dynamic user:exception/3), (:- multifile user:exception/3), (user:exception(undefined_global_variable,Name,retry) :- ( '$chr_prolog_global_variable'(Name), '$chr_initialization' ) ) | NameDeclarations ] ). %% SWI end %% SICStus begin % prolog_global_variables_code([]). %% SICStus end %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %sbag_member_call(S,L,sysh:mem(S,L)). sbag_member_call(S,L,'chr sbag_member'(S,L)). %sbag_member_call(S,L,member(S,L)). update_mutable_call(A,B,'chr update_mutable'( A, B)). %update_mutable_call(A,B,setarg(1, B, A)). create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value). % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)). % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :- % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0), % create_get_mutable(Value,Field,Get1). % % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :- % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get), % update_mutable_call(NewValue,Field,Set). % % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :- % get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0), % create_get_mutable_ref(Value,Field,Get1), % update_mutable_call(NewValue,Field,Set). % % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :- % get_static_suspension_term_field(FieldName,Constraint,Susp,Field), % create_mutable_call(Value,Field,Create). % % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :- % get_static_suspension_term_field(FieldName,Constraint,Susp,Field), % create_get_mutable(Value,Field,Get). % % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :- % get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field), % create_get_mutable_ref(Value,Field,Get), % update_mutable_call(NewValue,Field,Set). get_suspension_field(Constraint,Susp,FieldName,Value,Get) :- get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get). update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :- set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set). get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :- get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get), set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set). create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :- get_static_suspension_term_field(FieldName,Constraint,Susp,Value). get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :- get_static_suspension_term_field(FieldName,Constraint,Susp,Value). get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :- get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value), set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% enumerate_stores_code(Constraints,Clause) :- Head = '$enumerate_constraints'(Constraint), enumerate_store_bodies(Constraints,Constraint,Bodies), list2disj(Bodies,Body), Clause = (Head :- Body). enumerate_store_bodies([],_,[]). enumerate_store_bodies([C|Cs],Constraint,L) :- ( is_stored(C) -> get_store_type(C,StoreType), enumerate_store_body(StoreType,C,Suspension,SuspensionBody), get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal), C = F/_, Constraint0 =.. [F|Arguments], Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0), L = [Body|T] ; L = T ), enumerate_store_bodies(Cs,Constraint,T). enumerate_store_body(default,C,Susp,Body) :- global_list_store_name(C,StoreName), sbag_member_call(Susp,List,Sbag), make_get_store_goal(StoreName,List,GetStoreGoal), Body = ( GetStoreGoal, % nb_getval(StoreName,List), Sbag ). % get_constraint_index(C,Index), % get_target_module(Mod), % get_max_constraint_index(MaxIndex), % Body1 = % ( % 'chr default_store'(GlobalStore), % get_attr(GlobalStore,Mod,Attr) % ), % ( MaxIndex > 1 -> % NIndex is Index + 1, % sbag_member_call(Susp,List,Sbag), % Body2 = % ( % arg(NIndex,Attr,List), % Sbag % ) % ; % sbag_member_call(Susp,Attr,Sbag), % Body2 = Sbag % ), % Body = (Body1,Body2). enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :- multi_inthash_enumerate_store_body(Index,C,Susp,Body). enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :- multi_hash_enumerate_store_body(Index,C,Susp,Body). enumerate_store_body(global_ground,C,Susp,Body) :- global_ground_store_name(C,StoreName), sbag_member_call(Susp,List,Sbag), make_get_store_goal(StoreName,List,GetStoreGoal), Body = ( GetStoreGoal, % nb_getval(StoreName,List), Sbag ). enumerate_store_body(var_assoc_store(_,_),C,_,Body) :- Body = fail. enumerate_store_body(global_singleton,C,Susp,Body) :- global_singleton_store_name(C,StoreName), make_get_store_goal(StoreName,Susp,GetStoreGoal), Body = ( GetStoreGoal, % nb_getval(StoreName,Susp), Susp \== [] ). enumerate_store_body(multi_store(STs),C,Susp,Body) :- once(( member(ST,STs), enumerate_store_body(ST,C,Susp,Body) )). enumerate_store_body(identifier_store(Index),C,Susp,Body) :- Body = fail. enumerate_store_body(type_indexed_identifier_store(Index,IndexType),C,Susp,Body) :- Body = fail. multi_inthash_enumerate_store_body(I,C,Susp,B) :- multi_hash_store_name(C,I,StoreName), B = ( nb_getval(StoreName,HT), value_iht(HT,Susp) ). multi_hash_enumerate_store_body(I,C,Susp,B) :- multi_hash_store_name(C,I,StoreName), make_get_store_goal(StoreName,HT,GetStoreGoal), B = ( GetStoreGoal, % nb_getval(StoreName,HT), value_ht(HT,Susp) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint prev_guard_list/8, prev_guard_list/6, simplify_guards/1, set_all_passive/1. :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+,+)). :- chr_option(mode,prev_guard_list(+,+,+,+,+,+)). :- chr_option(type_declaration,prev_guard_list(any,any,any,any,any,list)). :- chr_option(mode,simplify_guards(+)). :- chr_option(mode,set_all_passive(+)). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % GUARD SIMPLIFICATION %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % If the negation of the guards of earlier rules entails (part of) % the current guard, the current guard can be simplified. We can only % use earlier rules with a head that matches if the head of the current % rule does, and which make it impossible for the current rule to match % if they fire (i.e. they shouldn't be propagation rules and their % head constraints must be subsets of those of the current rule). % At this point, we know for sure that the negation of the guard % of such a rule has to be true (otherwise the earlier rule would have % fired, because of the refined operational semantics), so we can use % that information to simplify the guard by replacing all entailed % conditions by true/0. As a consequence, the never-stored analysis % (in a further phase) will detect more cases of never-stored constraints. % % e.g. c(X),d(Y) <=> X > 0 | ... % e(X) <=> X < 0 | ... % c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ... % \____________/ % true guard_simplification :- ( chr_pp_flag(guard_simplification,on) -> precompute_head_matchings, simplify_guards(1) ; true ). % for every rule, we create a prev_guard_list where the last argument % eventually is a list of the negations of earlier guards rule(RuleNb,Rule) \ simplify_guards(RuleNb) <=> Rule = pragma(rule(Head1,Head2,Guard,_B),ids(IDs1,IDs2),_Pragmas,_Name,RuleNb), append(Head1,Head2,Heads), make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings), multiple_occ_constraints_checked([]), apply_guard_wrt_term(Heads,Guard,SubstitutedHeads), append(IDs1,IDs2,IDs), findall(tuple(C,O,RuleNb)-(-RuleNb),(member(ID,IDs),get_occurrence_from_id(C,O,RuleNb,ID)),HeapData), empty_q(EmptyHeap), insert_list_q(HeapData,EmptyHeap,Heap), next_prev_rule(Heap,_,Heap1), next_prev_rule(Heap1,PrevRuleNb,NHeap), prev_guard_list(RuleNb,PrevRuleNb,NHeap,MatchingFreeHeads,Guard,[],Matchings,[SubstitutedHeads]), NextRule is RuleNb+1, simplify_guards(NextRule). next_prev_rule(Heap,RuleNb,NHeap) :- ( find_min_q(Heap,_-Priority) -> Priority = (-RuleNb), normalize_heap(Heap,Priority,NHeap) ; RuleNb = 0, NHeap = Heap ). normalize_heap(Heap,Priority,NHeap) :- ( find_min_q(Heap,_-Priority) -> delete_min_q(Heap,Heap1,tuple(C,O,_)-_), ( O > 1 -> NO is O -1, get_occurrence(C,NO,RuleNb,_), insert_q(Heap1,tuple(C,NO,RuleNb)-(-RuleNb),Heap2) ; Heap2 = Heap1 ), normalize_heap(Heap2,Priority,NHeap) ; NHeap = Heap ). % no more rule simplify_guards(_) <=> true. % The negation of the guard of a non-propagation rule is added % if its kept head constraints are a subset of the kept constraints of % the rule we're working on, and its removed head constraints (at least one) % are a subset of the removed constraints. rule(PrevRuleNb,PrevRule) \ prev_guard_list(RuleNb,PrevRuleNb,Heap,CurrentHeads,G,GuardList,Matchings,GH) <=> PrevRule = pragma(rule(H1,H2,PrevGuard,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), % PrevRuleNb == _PrevRuleNb H1 \== [], make_head_matchings_explicit(PrevRuleNb,MatchingFreeHeads,PrevMatchings), setof(Renaming,chr_translate:head_subset(MatchingFreeHeads,CurrentHeads,Renaming),Renamings) | append(H1,H2,Heads), compute_derived_info(Renamings,PrevMatchings,MatchingFreeHeads,Heads,PrevGuard,Matchings,CurrentHeads,GH,DerivedInfo,GH_New1), append(GuardList,DerivedInfo,GL1), normalize_conj_list(GL1,GL), append(GH_New1,GH,GH1), normalize_conj_list(GH1,GH_New), next_prev_rule(Heap,PrevPrevRuleNb,NHeap), % PrevPrevRuleNb is PrevRuleNb-1, prev_guard_list(RuleNb,PrevPrevRuleNb,NHeap,CurrentHeads,G,GL,Matchings,GH_New). % if this isn't the case, we skip this one and try the next rule prev_guard_list(RuleNb,N,Heap,H,G,GuardList,M,GH) <=> ( N > 0 -> next_prev_rule(Heap,N1,NHeap), % N1 is N-1, prev_guard_list(RuleNb,N1,NHeap,H,G,GuardList,M,GH) ; prev_guard_list(RuleNb,H,G,GuardList,M,GH) ). prev_guard_list(RuleNb,H,G,GuardList,M,GH) <=> GH \== [] | head_types_modes_condition(GH,H,TypeInfo), conj2list(TypeInfo,TI), term_variables(H,HeadVars), append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info), normalize_conj_list(Info,InfoL), prev_guard_list(RuleNb,H,G,InfoL,M,[]). head_types_modes_condition([],H,true). head_types_modes_condition([GH|GHs],H,(TI1, TI2)) :- types_modes_condition(H,GH,TI1), head_types_modes_condition(GHs,H,TI2). %% % % when all earlier guards are added or skipped, we simplify the guard. % if it's different from the original one, we change the rule prev_guard_list(RuleNb,H,G,GuardList,M,[]), rule(RuleNb,Rule) <=> Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb), G \== true, % let's not try to simplify this ;) append(M,GuardList,Info), simplify_guard(G,B,Info,SimpleGuard,NB), G \== SimpleGuard | rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)), prev_guard_list(RuleNb,H,SimpleGuard,GuardList,M,[]). %% normalize_conj_list(+List,-NormalList) is det. % % Removes =true= elements and flattens out conjunctions. normalize_conj_list(List,NormalList) :- list2conj(List,Conj), conj2list(Conj,NormalList). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % AUXILIARY PREDICATES (GUARD SIMPLIFICATION) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% compute_derived_info([],_PrevMatchings,_MatchingFreeHeads,_Heads,_PrevGuard,_Matchings,_H,_GH,[],[]). compute_derived_info([Renaming1|RestRenamings],PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,[DerivedInfo1|DerivedInfo2],[GH3|GH_New2]) :- copy_term(PrevMatchings-PrevGuard,FreshMatchings), variable_replacement(PrevMatchings-PrevGuard,FreshMatchings,ExtraRenaming), append(Renaming1,ExtraRenaming,Renaming2), list2conj(PrevMatchings,Match), negate_b(Match,HeadsDontMatch), make_head_matchings_explicit_not_negated2(PrevHeads,PrevMatchingFreeHeads,HeadsMatch), list2conj(HeadsMatch,HeadsMatchBut), term_variables(Renaming2,RenVars), term_variables(PrevMatchings-PrevGuard-HeadsMatch,MGVars), new_vars(MGVars,RenVars,ExtraRenaming2), append(Renaming2,ExtraRenaming2,Renaming), ( PrevGuard == true -> % true can't fail Info_ = HeadsDontMatch ; negate_b(PrevGuard,TheGuardFailed), Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed)) ), copy_with_variable_replacement(Info_,DerivedInfo1,Renaming), copy_with_variable_replacement(PrevGuard,RenamedG2,Renaming), copy_with_variable_replacement(PrevMatchings,RenamedMatchings_,Renaming), list2conj(RenamedMatchings_,RenamedMatchings), apply_guard_wrt_term(H,RenamedG2,GH2), apply_guard_wrt_term(GH2,RenamedMatchings,GH3), compute_derived_info(RestRenamings,PrevMatchings,PrevMatchingFreeHeads,PrevHeads,PrevGuard,Matchings,H,GH,DerivedInfo2,GH_New2). simplify_guard(G,B,Info,SG,NB) :- conj2list(G,LG), % writeq(guard_entailment:simplify_guards(Info,B,LG,SGL,NB)),nl, guard_entailment:simplify_guards(Info,B,LG,SGL,NB), list2conj(SGL,SG). new_vars([],_,[]). new_vars([A|As],RV,ER) :- ( memberchk_eq(A,RV) -> new_vars(As,RV,ER) ; ER = [A-NewA,NewA-A|ER2], new_vars(As,RV,ER2) ). %% head_subset(+Subset,+MultiSet,-Renaming) is nondet. % % check if a list of constraints is a subset of another list of constraints % (multiset-subset), meanwhile computing a variable renaming to convert % one into the other. head_subset(H,Head,Renaming) :- head_subset(H,Head,Renaming,[],_). head_subset([],Remainder,Renaming,Renaming,Remainder). head_subset([X|Xs],MultiSet,Renaming,Acc,Remainder) :- head_member(MultiSet,X,NAcc,Acc,Remainder1), head_subset(Xs,Remainder1,Renaming,NAcc,Remainder). % check if A is in the list, remove it from Headleft head_member([X|Xs],A,Renaming,Acc,Remainder) :- ( variable_replacement(A,X,Acc,Renaming), Remainder = Xs ; Remainder = [X|RRemainder], head_member(Xs,A,Renaming,Acc,RRemainder) ). %-------------------------------------------------------------------------------% % memoing code to speed up repeated computation :- chr_constraint precompute_head_matchings/0. rule(RuleNb,PragmaRule), precompute_head_matchings ==> PragmaRule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_PrevRuleNb), append(H1,H2,Heads), make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings), copy_term_nat(MatchingFreeHeads-Matchings,A-B), make_head_matchings_explicit_memo_table(RuleNb,A,B). precompute_head_matchings <=> true. :- chr_constraint make_head_matchings_explicit_memo_table/3. :- chr_constraint make_head_matchings_explicit_memo_lookup/3. :- chr_option(mode,make_head_matchings_explicit_memo_table(+,?,?)). :- chr_option(mode,make_head_matchings_explicit_memo_lookup(+,?,?)). make_head_matchings_explicit_memo_table(RuleNb,NHeads,Matchings) \ make_head_matchings_explicit_memo_lookup(RuleNb,Q1,Q2) <=> Q1 = NHeads, Q2 = Matchings. make_head_matchings_explicit_memo_lookup(_,_,_) <=> fail. make_head_matchings_explicit(RuleNb,MatchingFreeHeads,Matchings) :- make_head_matchings_explicit_memo_lookup(RuleNb,A,B), copy_term_nat(A-B,MatchingFreeHeads-Matchings). %-------------------------------------------------------------------------------% make_head_matchings_explicit_(Heads,MatchingFreeHeads,Matchings) :- extract_arguments(Heads,Arguments), make_matchings_explicit(Arguments,FreeVariables,[],[],_,Matchings), substitute_arguments(Heads,FreeVariables,MatchingFreeHeads). make_head_matchings_explicit_not_negated(Heads,MatchingFreeHeads,Matchings) :- extract_arguments(Heads,Arguments), make_matchings_explicit_not_negated(Arguments,FreshVariables,Matchings), substitute_arguments(Heads,FreshVariables,MatchingFreeHeads). make_head_matchings_explicit_not_negated2(Heads,MatchingFreeHeads,Matchings) :- extract_arguments(Heads,Arguments1), extract_arguments(MatchingFreeHeads,Arguments2), make_matchings_explicit_not_negated(Arguments1,Arguments2,Matchings). %% extract_arguments(+ListOfConstraints,-ListOfVariables) is det. % % Returns list of arguments of given list of constraints. extract_arguments([],[]). extract_arguments([Constraint|Constraints],AllArguments) :- Constraint =.. [_|Arguments], append(Arguments,RestArguments,AllArguments), extract_arguments(Constraints,RestArguments). %% substitute_arguments(+InListOfConstraints,ListOfVariables,-OutListOfConstraints) is det. % % Substitutes arguments of constraints with those in the given list. substitute_arguments([],[],[]). substitute_arguments([Constraint|Constraints],Variables,[NConstraint|NConstraints]) :- functor(Constraint,F,N), split_at(N,Variables,Arguments,RestVariables), NConstraint =.. [F|Arguments], substitute_arguments(Constraints,RestVariables,NConstraints). make_matchings_explicit([],[],_,MC,MC,[]). make_matchings_explicit([Arg|Args],[NewVar|NewVars],VarAcc,MatchingCondition,MatchingConditionO,Matchings) :- ( var(Arg) -> ( memberchk_eq(Arg,VarAcc) -> list2disj(MatchingCondition,MatchingCondition_disj), Matchings = [(MatchingCondition_disj ; NewVar == Arg)|RestMatchings], % or only = ?? NVarAcc = VarAcc ; Matchings = RestMatchings, NewVar = Arg, NVarAcc = [Arg|VarAcc] ), MatchingCondition2 = MatchingCondition ; functor(Arg,F,A), Arg =.. [F|RecArgs], make_matchings_explicit(RecArgs,RecVars,VarAcc,MatchingCondition,MatchingCondition_,RecMatchings), FlatArg =.. [F|RecVars], ( RecMatchings == [] -> Matchings = [functor(NewVar,F,A)|RestMatchings] ; list2conj(RecMatchings,ArgM_conj), list2disj(MatchingCondition,MatchingCondition_disj), ArgM_ = (NewVar \= FlatArg ; MatchingCondition_disj ; ArgM_conj), Matchings = [ functor(NewVar,F,A) , ArgM_|RestMatchings] ), MatchingCondition2 = [ NewVar \= FlatArg |MatchingCondition_], term_variables(Args,ArgVars), append(ArgVars,VarAcc,NVarAcc) ), make_matchings_explicit(Args,NewVars,NVarAcc,MatchingCondition2,MatchingConditionO,RestMatchings). %% make_matchings_explicit_not_negated(+ListOfTerms,-ListOfVariables,-ListOfMatchings) is det. % % Returns list of new variables and list of pairwise unifications between given list and variables. make_matchings_explicit_not_negated([],[],[]). make_matchings_explicit_not_negated([X|Xs],[Var|Vars],Matchings) :- Matchings = [Var = X|RMatchings], make_matchings_explicit_not_negated(Xs,Vars,RMatchings). %% apply_guard_wrt_term(+ListOfConstraints,+Goal,-NewListOfConstraints) is det. % % (Partially) applies substitutions of =Goal= to given list. apply_guard_wrt_term([],_Guard,[]). apply_guard_wrt_term([Term|RH],Guard,[NTerm|RGH]) :- ( var(Term) -> apply_guard_wrt_variable(Guard,Term,NTerm) ; Term =.. [F|HArgs], apply_guard_wrt_term(HArgs,Guard,NewHArgs), NTerm =.. [F|NewHArgs] ), apply_guard_wrt_term(RH,Guard,RGH). %% apply_guard_wrt_variable(+Goal,+Variable,-NVariable) is det. % % (Partially) applies goal =Guard= wrt variable. apply_guard_wrt_variable((Guard1,Guard2),Variable,NVariable) :- !, apply_guard_wrt_variable(Guard1,Variable,NVariable1), apply_guard_wrt_variable(Guard2,NVariable1,NVariable). apply_guard_wrt_variable(Guard,Variable,NVariable) :- ( Guard = (X = Y), Variable == X -> NVariable = Y ; Guard = functor(AVariable,Functor,Arity), Variable == AVariable, ground(Functor), ground(Arity) -> functor(NVariable,Functor,Arity) ; NVariable = Variable ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % ALWAYS FAILING HEADS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% rule(RuleNb,Rule) \ prev_guard_list(RuleNb,H,G,GuardList,M,[]) <=> chr_pp_flag(check_impossible_rules,on), Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb), append(M,GuardList,Info), guard_entailment:entails_guard(Info,fail) | chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]), set_all_passive(RuleNb). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % HEAD SIMPLIFICATION %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % now we check the head matchings (guard may have been simplified meanwhile) prev_guard_list(RuleNb,H,G,GuardList,M,[]) \ rule(RuleNb,Rule) <=> Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb), simplify_heads(M,GuardList,G,B,NewM,NewB), NewM \== [], extract_arguments(Head1,VH1), extract_arguments(Head2,VH2), extract_arguments(H,VH), replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_), substitute_arguments(Head1,H1,NewH1), substitute_arguments(Head2,H2,NewH2), append(NewB,NewB_,NewBody), list2conj(NewBody,BodyMatchings), NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb), (Head1 \== NewH1 ; Head2 \== NewH2 ) | rule(RuleNb,NewRule). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % AUXILIARY PREDICATES (HEAD SIMPLIFICATION) %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !. replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !, ( NH == M -> H2_ = M, replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB) ; (M = functor(X,F,A), NH == X -> length(A_args,A), (var(H2) -> NewB1 = [], H2_ =.. [F|A_args] ; H2 =.. [F|OrigArgs], use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1), H2_ =.. [F|A_args_] ), replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2), append(NewB1,NewB2,NewB) ; H2_ = H2, replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB) ) ). replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !, ( NH == M -> H1_ = M, replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB) ; (M = functor(X,F,A), NH == X -> length(A_args,A), (var(H1) -> NewB1 = [], H1_ =.. [F|A_args] ; H1 =.. [F|OrigArgs], use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1), H1_ =.. [F|A_args_] ), replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2), append(NewB1,NewB2,NewB) ; H1_ = H1, replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB) ) ). use_same_args([],[],[],_,_,[]). use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :- var(OA),!, Out = OA, use_same_args(ROA,RNA,ROut,G,Body,NewB). use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :- nonvar(OA),!, ( common_variables(OA,Body) -> NewB = [NA = OA|NextB] ; NewB = NextB ), Out = NA, use_same_args(ROA,RNA,ROut,G,Body,NextB). simplify_heads([],_GuardList,_G,_Body,[],[]). simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :- M = (A = B), ( (nonvar(B) ; common_variables(B,RM-GuardList)), guard_entailment:entails_guard(GuardList,(A=B)) -> ( common_variables(B,G-RM-GuardList) -> NewB = NextB, NewM = NextM ; ( common_variables(B,Body) -> NewB = [A = B|NextB] ; NewB = NextB ), NewM = [A|NextM] ) ; ( nonvar(B), functor(B,BFu,BAr), guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) -> NewB = NextB, ( common_variables(B,G-RM-GuardList) -> NewM = NextM ; NewM = [functor(A,BFu,BAr)|NextM] ) ; NewM = NextM, NewB = NextB ) ), simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB). common_variables(B,G) :- term_variables(B,BVars), term_variables(G,GVars), intersect_eq(BVars,GVars,L), L \== []. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % ALWAYS FAILING GUARDS %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID). set_all_passive(_) <=> true. prev_guard_list(RuleNb,H,G,GuardList,M,[]),rule(RuleNb,Rule) ==> chr_pp_flag(check_impossible_rules,on), Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb), conj2list(G,GL), % writeq(guard_entailment:entails_guard(GL,fail)),nl, guard_entailment:entails_guard(GL,fail) | chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]), set_all_passive(RuleNb). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % OCCURRENCE SUBSUMPTION %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint first_occ_in_rule/4, next_occ_in_rule/6. :- chr_option(mode,first_occ_in_rule(+,+,+,+)). :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)). :- chr_constraint multiple_occ_constraints_checked/1. :- chr_option(mode,multiple_occ_constraints_checked(+)). prev_guard_list(RuleNb,H,G,GuardList,M,[]), occurrence(C,O,RuleNb,ID,_), occurrence(C,O2,RuleNb,ID2,_), rule(RuleNb,Rule) \ multiple_occ_constraints_checked(Done) <=> O < O2, chr_pp_flag(occurrence_subsumption,on), Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,_RuleNb), % RuleNb == _RuleNb H1 \== [], \+ memberchk_eq(C,Done) | first_occ_in_rule(RuleNb,C,O,ID), multiple_occ_constraints_checked([C|Done]). % Find first occurrence of constraint =C= in rule =RuleNb= occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_) <=> O < O2 | first_occ_in_rule(RuleNb,C,O,ID). first_occ_in_rule(RuleNb,C,O,ID_o1) <=> C = F/A, functor(FreshHead,F,A), next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead). % Skip passive occurrences. passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=> O2 is O+1 | next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH). prev_guard_list(RuleNb,H,G,GuardList,M,[]), occurrence(C,O2,RuleNb,ID_o2,_), rule(RuleNb,Rule) \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=> O2 is O+1, Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb) | append(H1,H2,Heads), add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl), ( ExtraCond == [chr_pp_void_info] -> next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH) ; append(ExtraCond,Cond,NewCond), add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2), copy_term(GuardList,FGuardList), variable_replacement(GuardList,FGuardList,GLRepl), copy_with_variable_replacement(GuardList,GuardList2,Repl), copy_with_variable_replacement(GuardList,GuardList3_,Repl2), copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl), append(NewCond,GuardList2,BigCond), append(BigCond,GuardList3,BigCond2), copy_with_variable_replacement(M,M2,Repl), copy_with_variable_replacement(M,M3,Repl2), append(M3,BigCond2,BigCond3), append([chr_pp_active_constraint(FH)|M2],BigCond3,Info), list2conj(CheckCond,OccSubsum), copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)), ( OccSubsum \= chr_pp_void_info -> ( guard_entailment:entails_guard(Info2,OccSubsum2) -> passive(RuleNb,ID_o2) ; true ) ; true ),!, next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH) ). next_occ_in_rule(RuleNb,C,O,ID,Cond,Args) <=> true. prev_guard_list(RuleNb,H,G,GuardList,M,[]), multiple_occ_constraints_checked(Done) <=> true. add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :- Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb), append(ID2,ID1,IDs), missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C), copy_term((H,Heads,NH),(FH2,FHeads,NH2)), variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl), copy_with_variable_replacement(G,FG,Repl), extract_explicit_matchings(FG,FG2), negate_b(FG2,NotFG), copy_with_variable_replacement(MPCond,FMPCond,Repl), ( safely_unifiable(FH,FH2), FH=FH2 -> FailCond = [(NotFG;FMPCond)] ; % in this case, not much can be done % e.g. c(f(...)), c(g(...)) <=> ... FailCond = [chr_pp_void_info] ). missing_partner_cond([],[],[],ID_o1,fail,H2,C). missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !, missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C). missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :- Cond = (chr_pp_not_in_store(H);Cond1), missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A). extract_explicit_matchings((A,B),D) :- !, ( extract_explicit_matchings(A) -> extract_explicit_matchings(B,D) ; D = (A,E), extract_explicit_matchings(B,E) ). extract_explicit_matchings(A,D) :- !, ( extract_explicit_matchings(A) -> D = true ; D = A ). extract_explicit_matchings(A=B) :- var(A), var(B), !, A=B. extract_explicit_matchings(A==B) :- var(A), var(B), !, A=B. safely_unifiable(H,I) :- var(H), !. safely_unifiable([],[]) :- !. safely_unifiable([H|Hs],[I|Is]) :- !, safely_unifiable(H,I), safely_unifiable(Hs,Is). safely_unifiable(H,I) :- nonvar(H), nonvar(I), H =.. [F|HA], I =.. [F|IA], safely_unifiable(HA,IA). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % TYPE INFORMATION %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint type_definition/2, type_alias/2, constraint_type/2, get_type_definition/2, get_constraint_type/2. :- chr_option(mode,type_definition(?,?)). :- chr_option(mode,get_type_definition(?,?)). :- chr_option(mode,type_alias(?,?)). :- chr_option(mode,constraint_type(+,+)). :- chr_option(mode,get_constraint_type(+,-)). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Consistency checks of type aliases type_alias(T,T2) <=> nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A), copy_term((T,T2),(X,Y)),oneway_unification(Y,X) | chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]). type_alias(T1,A1), type_alias(T2,A2) <=> nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A), \+ (T1\=T2) | copy_term_nat(T1,T1_), copy_term_nat(T2,T2_), T1_ = T2_, chr_error(type_error, 'Ambiguous type aliases: you have defined \n\t`~w\'\n\t`~w\'\n\tresulting in two definitions for "~w".\n',[T1==A1,T2==A2,T1_]). type_alias(T,B) \ type_alias(X,T2) <=> nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A), copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) | chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]), type_alias(X2,D1). oneway_unification(X,Y) :- term_variables(X,XVars), chr_runtime:lockv(XVars), X=Y, chr_runtime:unlockv(XVars). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Consistency checks of type definitions type_definition(T1,_), type_definition(T2,_) <=> functor(T1,F,A), functor(T2,F,A) | chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]). type_definition(T1,_), type_alias(T2,_) <=> functor(T1,F,A), functor(T2,F,A) | chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ %% get_type_definition(+Type,-Definition) is semidet. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ get_type_definition(T,Def) <=> \+ ground(T) | chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]). type_alias(T,D) \ get_type_definition(T2,Def) <=> nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A), copy_term_nat((T,D),(T1,D1)),T1=T2 | ( get_type_definition(D1,Def) -> true ; chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail ). type_definition(T,D) \ get_type_definition(T2,Def) <=> nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A), copy_term_nat((T,D),(T1,D1)),T1=T2 | Def = D1. get_type_definition(Type,Def) <=> atomic_builtin_type(Type,_,_) | Def = [Type]. get_type_definition(Type,Def) <=> compound_builtin_type(Type,_,_) | Def = [Type]. get_type_definition(X,Y) <=> fail. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ %% get_type_definition_det(+Type,-Definition) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ get_type_definition_det(Type,Definition) :- ( get_type_definition(Type,Definition) -> true ; chr_error(type,'Could not find type definition for type `~w\'.\n',[Type]) ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% get_constraint_type(+ConstraintSymbol,-Types) is semidet. % % Return argument types of =ConstraintSymbol=, but fails if none where % declared. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T. get_constraint_type(_,_) <=> fail. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% get_constraint_type_det(+ConstraintSymbol,-Types) is det. % % Like =get_constraint_type/2=, but returns list of =any= types when % no types are declared. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% get_constraint_type_det(ConstraintSymbol,Types) :- ( get_constraint_type(ConstraintSymbol,Types) -> true ; ConstraintSymbol = _ / N, replicate(N,any,Types) ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% unalias_type(+Alias,-Type) is det. % % Follows alias chain until base type is reached. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% :- chr_constraint unalias_type/2. unalias_var @ unalias_type(Alias,BaseType) <=> var(Alias) | BaseType = Alias. unalias_alias @ type_alias(AliasProtoType,ProtoType) \ unalias_type(Alias,BaseType) <=> nonvar(AliasProtoType), nonvar(Alias), functor(AliasProtoType,F,A), functor(Alias,F,A), copy_term_nat((AliasProtoType,ProtoType),(AliasInstance,Type)), Alias = AliasInstance | unalias_type(Type,BaseType). unalias_type_definition @ type_definition(ProtoType,Definition) \ unalias_type(Alias,BaseType) <=> nonvar(ProtoType), nonvar(Alias), functor(ProtoType,F,A), functor(Alias,F,A) | BaseType = Alias. unalias_atomic_builtin @ unalias_type(Alias,BaseType) <=> atomic_builtin_type(Alias,_,_) | BaseType = Alias. unalias_compound_builtin @ unalias_type(Alias,BaseType) <=> compound_builtin_type(Alias,_,_) | BaseType = Alias. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% types_modes_condition(+Heads,+UnrollHeads,-Condition) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% :- chr_constraint types_modes_condition/3. :- chr_option(mode,types_modes_condition(+,+,?)). :- chr_option(type_declaration,types_modes_condition(list,list,goal)). types_modes_condition([],[],T) <=> T=true. constraint_mode(F/A,Modes) \ types_modes_condition([Head|Heads],[UnrollHead|UnrollHeads],Condition) <=> functor(Head,F,A) | Head =.. [_|Args], Condition = (ModesCondition, TypesCondition, RestCondition), modes_condition(Modes,Args,ModesCondition), get_constraint_type_det(F/A,Types), UnrollHead =.. [_|RealArgs], types_condition(Types,Args,RealArgs,Modes,TypesCondition), types_modes_condition(Heads,UnrollHeads,RestCondition). types_modes_condition([Head|_],_,_) <=> functor(Head,F,A), chr_error(internal,'Mode information missing for ~w.\n',[F/A]). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% modes_condition(+Modes,+Args,-Condition) is det. % % Return =Condition= on =Args= that checks =Modes=. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% modes_condition([],[],true). modes_condition([Mode|Modes],[Arg|Args],Condition) :- ( Mode == (+) -> Condition = ( ground(Arg) , RCondition ) ; Mode == (-) -> Condition = ( var(Arg) , RCondition ) ; Condition = RCondition ), modes_condition(Modes,Args,RCondition). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% types_condition(+Types,+Args,+UnrollArgs,+Modes,-Condition) is det. % % Return =Condition= on =Args= that checks =Types= given =Modes=. % =UnrollArgs= controls the depth of type definition unrolling. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% types_condition([],[],[],[],true). types_condition([Type|Types],[Arg|Args],[UnrollArg|UnrollArgs],[Mode|Modes],(DisjTypeConditionList,RCondition)) :- ( Mode == (-) -> TypeConditionList = [true] % TypeConditionList = [var(Arg)] already encoded in modes_condition ; get_type_definition_det(Type,Def), type_condition(Def,Arg,UnrollArg,Mode,TypeConditionList1), ( Mode == (+) -> TypeConditionList = TypeConditionList1 ; TypeConditionList = [(\+ ground(Arg))|TypeConditionList1] ) ), list2disj(TypeConditionList,DisjTypeConditionList), types_condition(Types,Args,UnrollArgs,Modes,RCondition). type_condition([],_,_,_,[]). type_condition([DefCase|DefCases],Arg,UnrollArg,Mode,[Condition|Conditions]) :- ( var(DefCase) -> chr_error(type,'Unexpected variable type in type definition!\n',[]) % Condition = true ; atomic_builtin_type(DefCase,Arg,Condition) -> true ; compound_builtin_type(DefCase,Arg,Condition) -> true ; type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) ), type_condition(DefCases,Arg,UnrollArg,Mode,Conditions). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% :- chr_type atomic_builtin_type ---> any ; number ; float ; int ; natural ; dense_int ; chr_identifier ; chr_identifier(any). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% atomic_builtin_type(any,_Arg,true). atomic_builtin_type(dense_int,Arg,(integer(Arg),Arg>=0)). atomic_builtin_type(int,Arg,integer(Arg)). atomic_builtin_type(number,Arg,number(Arg)). atomic_builtin_type(float,Arg,float(Arg)). atomic_builtin_type(natural,Arg,(integer(Arg),Arg>=0)). atomic_builtin_type(chr_identifier,_Arg,true). compound_builtin_type(chr_identifier(_),_Arg,true). type_def_case_condition(DefCase,Arg,UnrollArg,Mode,Condition) :- ( nonvar(DefCase) -> functor(DefCase,F,A), ( A == 0 -> Condition = (Arg = DefCase) ; var(UnrollArg) -> Condition = functor(Arg,F,A) ; functor(UnrollArg,F,A) -> Condition = (functor(Arg,F,A),Arg=Template,ArgsCondition), DefCase =.. [_|ArgTypes], UnrollArg =.. [_|UnrollArgs], functor(Template,F,A), Template =.. [_|TemplateArgs], replicate(A,Mode,ArgModes), types_condition(ArgTypes,TemplateArgs,UnrollArgs,ArgModes,ArgsCondition) ; Condition = functor(Arg,F,A) ) ; chr_error(internal,'Illegal type definition (must be nonvar).\n',[]) ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Static type checking %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Checks head constraints and CHR constraint calls in bodies. % % TODO: % - type clashes involving built-in types % - Prolog built-ins in guard and body % - indicate position in terms in error messages %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ :- chr_constraint static_type_check/0. :- chr_type type_error_src ---> head(any) ; body(any). rule(_,Rule), static_type_check ==> copy_term_nat(Rule,RuleCopy), RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb), ( catch( ( static_type_check_heads(Head1), static_type_check_heads(Head2), conj2list(Body,GoalList), static_type_check_body(GoalList) ), type_error(Error), ( Error = invalid_functor(Src,Term,Type) -> chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n', [chr_translate:format_src(Src),format_rule(Rule),Term,Type]) ; Error = type_clash(Var,Src1,Src2,Type1,Type2) -> chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n', [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)]) ) ), fail % cleanup constraints ; true ). static_type_check <=> true. static_type_check_heads([]). static_type_check_heads([Head|Heads]) :- static_type_check_head(Head), static_type_check_heads(Heads). static_type_check_head(Head) :- functor(Head,F,A), get_constraint_type_det(F/A,Types), Head =..[_|Args], maplist(static_type_check_term(head(Head)),Args,Types). static_type_check_body([]). static_type_check_body([Goal|Goals]) :- functor(Goal,F,A), get_constraint_type_det(F/A,Types), Goal =..[_|Args], maplist(static_type_check_term(body(Goal)),Args,Types), static_type_check_body(Goals). :- chr_constraint static_type_check_term/3. :- chr_option(mode,static_type_check_term(?,?,?)). :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)). static_type_check_term(Src,Term,Type) <=> var(Term) | static_type_check_var(Src,Term,Type). static_type_check_term(Src,Term,Type) <=> atomic_builtin_type(Type,Term,Goal) | ( call(Goal) -> true ; throw(type_error(invalid_functor(Src,Term,Type))) ). static_type_check_term(Src,Term,Type) <=> compound_builtin_type(Type,Term,Goal) | ( call(Goal) -> true ; throw(type_error(invalid_functor(Src,Term,Type))) ). type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type) <=> functor(Type,F,A), functor(AType,F,A) | copy_term_nat(AType-ADef,Type-Def), static_type_check_term(Src,Term,Def). type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type) <=> functor(Type,F,A), functor(AType,F,A) | copy_term_nat(AType-ADef,Type-Variants), functor(Term,TF,TA), ( member(Variant,Variants), functor(Variant,TF,TA) -> Term =.. [_|Args], Variant =.. [_|Types], maplist(static_type_check_term(Src),Args,Types) ; throw(type_error(invalid_functor(Src,Term,Type))) ). static_type_check_term(Src,Term,Type) <=> chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]). :- chr_constraint static_type_check_var/3. :- chr_option(mode,static_type_check_var(?,-,?)). :- chr_option(type_declaration,static_type_check_term(type_error_src,any,any)). type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type) <=> functor(AType,F,A), functor(Type,F,A) | copy_term_nat(AType-ADef,Type-Def), static_type_check_var(Src,Var,Def). static_type_check_var(Src,Var,Type) <=> atomic_builtin_type(Type,_,_) | static_atomic_builtin_type_check_var(Src,Var,Type). static_type_check_var(Src,Var,Type) <=> compound_builtin_type(Type,_,_) | true. static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2) <=> Type1 \== Type2 | throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% static_atomic_builtin_type_check_var(+type_error_src,-Var,+atomic_builtin_type) %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% :- chr_constraint static_atomic_builtin_type_check_var/3. :- chr_option(mode,static_type_check_var(?,-,+)). :- chr_option(type_declaration,static_type_check_term(type_error_src,any,atomic_builtin_type)). static_atomic_builtin_type_check_var(_,_,any) <=> true. static_atomic_builtin_type_check_var(_,Var,BuiltinType) \ static_atomic_builtin_type_check_var(_,Var,BuiltinType) <=> true. static_atomic_builtin_type_check_var(_,Var,float) \ static_atomic_builtin_type_check_var(_,Var,number) <=> true. static_atomic_builtin_type_check_var(_,Var,int) \ static_atomic_builtin_type_check_var(_,Var,number) <=> true. static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,number) <=> true. static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,number) <=> true. static_atomic_builtin_type_check_var(_,Var,natural) \ static_atomic_builtin_type_check_var(_,Var,int) <=> true. static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,int) <=> true. static_atomic_builtin_type_check_var(_,Var,dense_int) \ static_atomic_builtin_type_check_var(_,Var,natural) <=> true. static_atomic_builtin_type_check_var(Src1,Var,Type1), static_atomic_builtin_type_check_var(Src2,Var,Type2) <=> throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% format_src(+type_error_src) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% format_src(head(Head)) :- format('head ~w',[Head]). format_src(body(Goal)) :- format('body goal ~w',[Goal]). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Dynamic type checking %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ :- chr_constraint dynamic_type_check/0, dynamic_type_check_clauses/1, get_dynamic_type_check_clauses/1. generate_dynamic_type_check_clauses(Clauses) :- ( chr_pp_flag(debugable,on) -> dynamic_type_check, get_dynamic_type_check_clauses(Clauses0), append(Clauses0, [('$dynamic_type_check'(Type,Term) :- throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error'))) )], Clauses) ; Clauses = [] ). type_definition(T,D), dynamic_type_check ==> copy_term_nat(T-D,Type-Definition), maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks), dynamic_type_check_clauses(DynamicChecks). type_alias(A,B), dynamic_type_check ==> copy_term_nat(A-B,Alias-Body), dynamic_type_check_alias_clause(Alias,Body,Clause), dynamic_type_check_clauses([Clause]). dynamic_type_check <=> findall( ('$dynamic_type_check'(Type,Term) :- Goal), ( atomic_builtin_type(Type,Term,Goal) ; compound_builtin_type(Type,Term,Goal) ), BuiltinChecks ), dynamic_type_check_clauses(BuiltinChecks). dynamic_type_check_clause(T,DC,Clause) :- copy_term(T-DC,Type-DefinitionClause), functor(DefinitionClause,F,A), functor(Term,F,A), DefinitionClause =.. [_|DCArgs], Term =.. [_|TermArgs], maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList), list2conj(RecursiveCallList,RecursiveCalls), Clause = ( '$dynamic_type_check'(Type,Term) :- RecursiveCalls ). dynamic_type_check_alias_clause(Alias,Body,Clause) :- Clause = ( '$dynamic_type_check'(Alias,Term) :- '$dynamic_type_check'(Body,Term) ). dynamic_type_check_call(Type,Term,Call) :- % ( nonvar(Type), atomic_builtin_type(Type,Term,Goal) -> % Call = when(nonvar(Term),Goal) % ; nonvar(Type), compound_builtin_type(Type,Term,Goal) -> % Call = when(nonvar(Term),Goal) % ; ( Type == any -> Call = true ; Call = when(nonvar(Term),once('$dynamic_type_check'(Type,Term))) ) % ) . dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2) <=> append(C1,C2,C), dynamic_type_check_clauses(C). get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C) <=> Q = C. get_dynamic_type_check_clauses(Q) <=> Q = []. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Atomic Types %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Some optimizations can be applied for atomic types... %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ atomic_types_suspended_constraint(C) :- C = _/N, get_constraint_type(C,ArgTypes), get_constraint_mode(C,ArgModes), findall(I,between(1,N,I),Indexes), maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes). atomic_types_suspended_constraint(C,Type,Mode,Index) :- ( is_indexed_argument(C,Index) -> ( Mode == (?) -> atomic_type(Type) ; true ) ; true ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% atomic_type(+Type) is semidet. % % Succeeds when all values of =Type= are atomic. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% :- chr_constraint atomic_type/1. atomic_type(Type) <=> atomic_builtin_type(Type,_,_) | Type \== any. type_definition(TypePat,Def) \ atomic_type(Type) <=> functor(Type,F,A), functor(TypePat,F,A) | forall(member(Term,Def),atomic(Term)). type_alias(TypePat,Alias) \ atomic_type(Type) <=> functor(Type,F,A), functor(TypePat,F,A) | atomic(Alias), copy_term_nat(TypePat-Alias,Type-NType), atomic_type(NType). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint stored/3, % constraint,occurrence,(yes/no/maybe) stored_completing/3, stored_complete/3, is_stored/1, is_finally_stored/1, check_all_passive/2. :- chr_option(mode,stored(+,+,+)). :- chr_option(type_declaration,stored(any,int,storedinfo)). :- chr_type storedinfo ---> yes ; no ; maybe. :- chr_option(mode,stored_complete(+,+,+)). :- chr_option(mode,maybe_complementary_guards(+,+,?,?)). :- chr_option(mode,guard_list(+,+,+,+)). :- chr_option(mode,check_all_passive(+,+)). :- chr_option(type_declaration,check_all_passive(any,list)). % change yes in maybe when yes becomes passive passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \ stored(C,O,yes), stored_complete(C,RO,Yesses) <=> O < RO | NYesses is Yesses - 1, stored(C,O,maybe), stored_complete(C,RO,NYesses). % change yes in maybe when not observed ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses) <=> O < RO | NYesses is Yesses - 1, stored(C,O,maybe), stored_complete(C,RO,NYesses). occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2) ==> RO =< MO2 | % C2 is never stored passive(RuleNb,ID). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% rule(RuleNb,Rule),passive(RuleNb,Id) ==> Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) | append(IDs1,IDs2,I), check_all_passive(RuleNb,I). rule(RuleNb,Rule),passive(RuleNb,Id) ==> Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) | check_all_passive(RuleNb,IDs2). passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=> check_all_passive(RuleNb,IDs). rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=> chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % collect the storage information stored(C,O,yes) \ stored_completing(C,O,Yesses) <=> NO is O + 1, NYesses is Yesses + 1, stored_completing(C,NO,NYesses). stored(C,O,maybe) \ stored_completing(C,O,Yesses) <=> NO is O + 1, stored_completing(C,NO,Yesses). stored(C,O,no) \ stored_completing(C,O,Yesses) <=> stored_complete(C,O,Yesses). stored_completing(C,O,Yesses) <=> stored_complete(C,O,Yesses). stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==> O2 > O | passive(RuleNb,Id). % decide whether a constraint is stored max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C) <=> RO =< MO | fail. is_stored(C) <=> true. % decide whether a constraint is suspends after occurrences max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C) <=> RO =< MO | fail. is_finally_stored(C) <=> true. storage_analysis(Constraints) :- ( chr_pp_flag(storage_analysis,on) -> check_constraint_storages(Constraints) ; true ). check_constraint_storages([]). check_constraint_storages([C|Cs]) :- check_constraint_storage(C), check_constraint_storages(Cs). check_constraint_storage(C) :- get_max_occurrence(C,MO), check_occurrences_storage(C,1,MO). check_occurrences_storage(C,O,MO) :- ( O > MO -> stored_completing(C,1,0) ; check_occurrence_storage(C,O), NO is O + 1, check_occurrences_storage(C,NO,MO) ). check_occurrence_storage(C,O) :- get_occurrence(C,O,RuleNb,ID), ( is_passive(RuleNb,ID) -> stored(C,O,maybe) ; get_rule(RuleNb,PragmaRule), PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_), ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) -> check_storage_head1(Head1,O,Heads1,Heads2,Guard) ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) -> check_storage_head2(Head2,O,Heads1,Body) ) ). check_storage_head1(Head,O,H1,H2,G) :- functor(Head,F,A), C = F/A, ( H1 == [Head], H2 == [], % writeq(guard_entailment:entails_guard([chr_pp_headvariables(Head)],G)),nl, guard_entailment:entails_guard([chr_pp_headvariables(Head)],G), Head =.. [_|L], no_matching(L,[]) -> stored(C,O,no) ; stored(C,O,maybe) ). no_matching([],_). no_matching([X|Xs],Prev) :- var(X), \+ memberchk_eq(X,Prev), no_matching(Xs,[X|Prev]). check_storage_head2(Head,O,H1,B) :- functor(Head,F,A), C = F/A, ( %( ( H1 \== [], B == true ) %; % \+ is_observed(F/A,O) % always fails because observation analysis has not been performed yet %) -> stored(C,O,maybe) ; stored(C,O,yes) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ ____ _ _ _ _ %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __ %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \ %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | | %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_| %% |_| constraints_code(Constraints,Clauses) :- (chr_pp_flag(reduced_indexing,on), \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) -> none_suspended_on_variables ; true ), constraints_code1(Constraints,Clauses,[]). %=============================================================================== :- chr_constraint constraints_code1/3. :- chr_option(mode,constraints_code1(+,+,+)). :- chr_option(type_declaration,constraints_code1(list,any,any)). %------------------------------------------------------------------------------- constraints_code1([],L,T) <=> L = T. constraints_code1([C|RCs],L,T) <=> constraint_code(C,L,T1), constraints_code1(RCs,T1,T). %=============================================================================== :- chr_constraint constraint_code/3. :- chr_option(mode,constraint_code(+,+,+)). %------------------------------------------------------------------------------- %% Generate code for a single CHR constraint constraint_code(Constraint, L, T) <=> true | ( (chr_pp_flag(debugable,on) ; is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)), ( may_trigger(Constraint) ; get_allocation_occurrence(Constraint,AO), get_max_occurrence(Constraint,MO), MO >= AO ) ) -> constraint_prelude(Constraint,Clause), add_dummy_location(Clause,LocatedClause), L = [LocatedClause | L1] ; L = L1 ), Id = [0], occurrences_code(Constraint,1,Id,NId,L1,L2), gen_cond_attach_clause(Constraint,NId,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], make_suspension_continuation_goal(F/A,VarsSusp,Continuation), build_head(F,A,[0],VarsSusp,Delegate), ( chr_pp_flag(debugable,on) -> insert_constraint_goal(F/A,Susp,Vars,InsertCall), attach_constraint_atom(F/A,Vars2,Susp,AttachCall), delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)), insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal), ( get_constraint_type(F/A,ArgTypeList) -> maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList), list2conj(DynamicTypeCheckList,DynamicTypeChecks) ; DynamicTypeChecks = true ), Clause = ( Head :- DynamicTypeChecks, InsertGoal, InsertCall, AttachCall, Inactive, 'chr debug_event'(insert(Head#Susp)), ( 'chr debug_event'(call(Susp)), Delegate ; 'chr debug_event'(fail(Susp)), !, fail ), ( 'chr debug_event'(exit(Susp)) ; 'chr debug_event'(redo(Susp)), fail ) ) ; get_allocation_occurrence(F/A,0) -> gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp), delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)), Clause = ( Head :- Goal, Inactive, Delegate ) ; Clause = ( Head :- Delegate ) ). make_suspension_continuation_goal(F/A,VarsSusp,Goal) :- ( may_trigger(F/A) -> build_head(F,A,[0],VarsSusp,Delegate), ( chr_pp_flag(debugable,off) -> Goal = Delegate ; get_target_module(Mod), Goal = Mod:Delegate ) ; Goal = true ). %=============================================================================== :- chr_constraint has_active_occurrence/1, has_active_occurrence/2. :- chr_option(mode,has_active_occurrence(+)). :- chr_option(mode,has_active_occurrence(+,+)). %------------------------------------------------------------------------------- has_active_occurrence(C) <=> has_active_occurrence(C,1). max_occurrence(C,MO) \ has_active_occurrence(C,O) <=> O > MO | fail. passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \ has_active_occurrence(C,O) <=> NO is O + 1, has_active_occurrence(C,NO). has_active_occurrence(C,O) <=> true. %=============================================================================== gen_cond_attach_clause(F/A,Id,L,T) :- ( is_finally_stored(F/A) -> get_allocation_occurrence(F/A,AllocationOccurrence), get_max_occurrence(F/A,MaxOccurrence), ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence -> ( only_ground_indexed_arguments(F/A) -> gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp) ; gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp) ) ; vars_susp(A,Args,Susp,AllArgs), gen_uncond_attach_goal(F/A,Susp,Args,Body,_) ), build_head(F,A,Id,AllArgs,Head), Clause = ( Head :- Body ), add_dummy_location(Clause,LocatedClause), L = [LocatedClause | T] ; L = T ). :- chr_constraint use_auxiliary_predicate/1. :- chr_option(mode,use_auxiliary_predicate(+)). :- chr_constraint use_auxiliary_predicate/2. :- chr_option(mode,use_auxiliary_predicate(+,+)). :- chr_constraint is_used_auxiliary_predicate/1. :- chr_option(mode,is_used_auxiliary_predicate(+)). :- chr_constraint is_used_auxiliary_predicate/2. :- chr_option(mode,is_used_auxiliary_predicate(+,+)). use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true. use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true. use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true. use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true. is_used_auxiliary_predicate(P) <=> fail. use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true. use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true. is_used_auxiliary_predicate(P,C) <=> fail. %------------------------------------------------------------------------------% % Only generate import statements for actually used modules. %------------------------------------------------------------------------------% :- chr_constraint use_auxiliary_module/1. :- chr_option(mode,use_auxiliary_module(+)). :- chr_constraint is_used_auxiliary_module/1. :- chr_option(mode,is_used_auxiliary_module(+)). use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true. use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true. is_used_auxiliary_module(P) <=> fail. % only called for constraints with % at least one % non-ground indexed argument gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :- vars_susp(A,Args,Susp,AllArgs), make_suspension_continuation_goal(F/A,AllArgs,Closure), ( get_store_type(F/A,var_assoc_store(_,_)) -> Attach = true ; attach_constraint_atom(F/A,Vars,Susp,Attach) ), FTerm =.. [F|Args], insert_constraint_goal(F/A,Susp,Args,InsertCall), insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal), ( may_trigger(F/A) -> activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal), Goal = ( ( var(Susp) -> InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args) InsertCall, Attach ; ActivateGoal % activate_constraint(Stored,Vars,Susp,_) ) ) ; Goal = ( InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args), InsertCall, Attach ) ). gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :- vars_susp(A,Args,Susp,AllArgs), make_suspension_continuation_goal(F/A,AllArgs,Cont), ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) -> attach_constraint_atom(F/A,Vars,Susp,Attach) ; Attach = true ), FTerm =.. [F|Args], insert_constraint_goal(F/A,Susp,Args,InsertCall), insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal), ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) -> Goal = ( InsertInternalGoal, % insert_constraint_internal(Susp,F,Args), InsertCall ) ; Goal = ( InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args), InsertCall, Attach ) ). gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :- ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) -> attach_constraint_atom(FA,Vars,Susp,Attach) ; Attach = true ), insert_constraint_goal(FA,Susp,Args,InsertCall), ( chr_pp_flag(late_allocation,on) -> activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal) ; activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal) ). %------------------------------------------------------------------------------- :- chr_constraint occurrences_code/6. :- chr_option(mode,occurrences_code(+,+,+,+,+,+)). %------------------------------------------------------------------------------- max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T) <=> O > MO | NId = Id, L = T. occurrences_code(C,O,Id,NId,L,T) <=> occurrence_code(C,O,Id,Id1,L,L1), NO is O + 1, occurrences_code(C,NO,Id1,NId,L1,T). %------------------------------------------------------------------------------- :- chr_constraint occurrence_code/6. :- chr_option(mode,occurrence_code(+,+,+,+,+,+)). %------------------------------------------------------------------------------- occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T) <=> ( named_history(RuleNb,_,_) -> does_use_history(C,O) ; true ), NId = Id, L = T. occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T) <=> true | PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_), ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) -> NId = Id, head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T) ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) -> head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1), inc_id(Id,NId), ( unconditional_occurrence(C,O) -> L1 = T ; gen_alloc_inc_clause(C,O,Id,L1,T) ) ). occurrence_code(C,O,_,_,_,_) <=> chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]). %------------------------------------------------------------------------------- %% Generate code based on one removed head of a CHR rule head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :- PragmaRule = pragma(Rule,_,_,_Name,RuleNb), Rule = rule(_,Head2,_,_), ( Head2 == [] -> reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs), simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T) ; simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) ). %% Generate code based on one persistent head of a CHR rule head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :- PragmaRule = pragma(Rule,_,_,_Name,RuleNb), Rule = rule(Head1,_,_,_), ( Head1 == [] -> reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs), propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T) ; simpagation_head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) ). gen_alloc_inc_clause(F/A,O,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), gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc), Clause = ( Head :- ConditionalAlloc, CallHead ), add_dummy_location(Clause,LocatedClause), L = [LocatedClause|T]. gen_occ_allocation(FA,O,Vars,Susp,Goal) :- get_allocation_occurrence(FA,AO), ( chr_pp_flag(debugable,off), O == AO -> allocate_constraint_goal(FA,Susp,Vars,Goal0), ( may_trigger(FA) -> Goal = (var(Susp) -> Goal0 ; true) ; Goal = Goal0 ) ; Goal = true ). gen_occ_allocation_in_guard(FA,O,Vars,Susp,Goal) :- get_allocation_occurrence(FA,AO), ( chr_pp_flag(debugable,off), O < AO -> allocate_constraint_goal(FA,Susp,Vars,Goal0), ( may_trigger(FA) -> Goal = (var(Susp) -> Goal0 ; true) ; Goal = Goal0 ) ; Goal = true ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % Reorders guard goals with respect to partner constraint retrieval goals and % active constraint. Returns combined partner retrieval + guard goal. guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :- ( chr_pp_flag(guard_via_reschedule,on) -> guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton), list2conj(ScheduleSkeleton,GoalSkeleton) ; length(Retrievals,RL), length(LookupSkeleton,RL), length(GuardList,GL), length(GuardListSkeleton,GL), append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton), list2conj(GoalListSkeleton,GoalSkeleton) ). guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead, GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :- initialize_unit_dictionary(ActiveHead,Dict), maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups), maplist(wrap_in_functor(guard),GuardList,WrappedGuardList), build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units), dependency_reorder(Units,NUnits), wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton), sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton), snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton). wrap_in_functor(Functor,X,Term) :- Term =.. [Functor,X]. wrappedunits2lists([],[],[],[]). wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :- Ss = [GoalCopy|TSs], ( WrappedGoal = lookup(Goal) -> Ls = [GoalCopy|TLs], Gs = TGs ; WrappedGoal = guard(Goal) -> Gs = [N-GoalCopy|TGs], Ls = TLs ), wrappedunits2lists(Units,TGs,TLs,TSs). guard_splitting(Rule,SplitGuardList) :- Rule = rule(H1,H2,Guard,_), append(H1,H2,Heads), conj2list(Guard,GuardList), term_variables(Heads,HeadVars), split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList), append(GuardPrefix,[RestGuard],SplitGuardList), term_variables(RestGuardList,GuardVars1), % variables that are declared to be ground don't need to be locked ground_vars(Heads,GroundVars), list_difference_eq(HeadVars,GroundVars,LockableHeadVars), intersect_eq(LockableHeadVars,GuardVars1,GuardVars), ( chr_pp_flag(guard_locks,on), bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) -> once(pairup(Locks,Unlocks,LocksUnlocks)) ; Locks = [], Unlocks = [] ), list2conj(Locks,LockPhase), list2conj(Unlocks,UnlockPhase), list2conj(RestGuardList,RestGuard1), RestGuard = (LockPhase,(RestGuard1,UnlockPhase)). guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :- Rule = rule(_,_,_,Body), my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList), my_term_copy(Body,VarDict2,BodyCopy). split_off_simple_guard_new([],_,[],[]). split_off_simple_guard_new([G|Gs],VarDict,S,C) :- ( simple_guard_new(G,VarDict) -> S = [G|Ss], split_off_simple_guard_new(Gs,VarDict,Ss,C) ; S = [], C = [G|Gs] ). % simple guard: cheap and benign (does not bind variables) simple_guard_new(G,Vars) :- builtin_binds_b(G,BoundVars), \+ (( member(V,BoundVars), memberchk_eq(V,Vars) )). 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,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). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ ____ _ _ %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _ %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_) %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_ %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_) %% %% _ _ _ ___ __ %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___ %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \ %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/ %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___| %% |_| :- chr_constraint functional_dependency/4, get_functional_dependency/4. :- chr_option(mode,functional_dependency(+,+,?,?)). :- chr_option(mode,get_functional_dependency(+,+,?,?)). allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key) <=> RuleNb > 1, AO > O | functional_dependency(C,1,Pattern,Key). functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey) <=> RuleNb2 >= RuleNb1 | QPattern = Pattern, QKey = Key. get_functional_dependency(_,_,_,_) <=> fail. functional_dependency_analysis(Rules) :- ( fail, chr_pp_flag(functional_dependency_analysis,on) -> functional_dependency_analysis_main(Rules) ; true ). functional_dependency_analysis_main([]). functional_dependency_analysis_main([PRule|PRules]) :- ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) -> functional_dependency(C,RuleNb,Pattern,Key) ; true ), functional_dependency_analysis_main(PRules). discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :- PragmaRule = pragma(Rule,_,_,Name,RuleNb), Rule = rule(H1,H2,Guard,_), ( H1 = [C1], H2 = [C2] -> true ; H1 = [C1,C2], H2 == [] -> true ), check_unique_constraints(C1,C2,Guard,RuleNb,List), term_variables(C1,Vs), \+ ( member(V1,Vs), lookup_eq(List,V1,V2), memberchk_eq(V2,Vs) ), select_pragma_unique_variables(Vs,List,Key1), copy_term_nat(C1-Key1,Pattern-Key), functor(C1,F,A). select_pragma_unique_variables([],_,[]). select_pragma_unique_variables([V|Vs],List,L) :- ( lookup_eq(List,V,_) -> L = T ; L = [V|T] ), select_pragma_unique_variables(Vs,List,T). % depends on functional dependency analysis % and shape of rule: C1 \ C2 <=> true. set_semantics_rules(Rules) :- ( fail, chr_pp_flag(set_semantics_rule,on) -> set_semantics_rules_main(Rules) ; true ). set_semantics_rules_main([]). set_semantics_rules_main([R|Rs]) :- set_semantics_rule_main(R), set_semantics_rules_main(Rs). set_semantics_rule_main(PragmaRule) :- PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb), ( Rule = rule([C1],[C2],true,_), IDs = ids([ID1],[ID2]), \+ is_passive(RuleNb,ID1), functor(C1,F,A), get_functional_dependency(F/A,RuleNb,Pattern,Key), copy_term_nat(Pattern-Key,C1-Key1), copy_term_nat(Pattern-Key,C2-Key2), Key1 == Key2 -> passive(RuleNb,ID2) ; true ). check_unique_constraints(C1,C2,G,RuleNb,List) :- \+ any_passive_head(RuleNb), variable_replacement(C1-C2,C2-C1,List), copy_with_variable_replacement(G,OtherG,List), negate_b(G,NotG), once(entails_b(NotG,OtherG)). % checks for rules of the shape ...,C1,C2... (<|=)=> ... % where C1 and C2 are symmteric constraints symmetry_analysis(Rules) :- ( chr_pp_flag(check_unnecessary_active,off) -> true ; symmetry_analysis_main(Rules) ). symmetry_analysis_main([]). symmetry_analysis_main([R|Rs]) :- R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb), Rule = rule(H1,H2,_,_), ( ( \+ chr_pp_flag(check_unnecessary_active,simplification) ; H2 == [] ), H1 \== [] -> symmetry_analysis_heads_simplification(H1,IDs1,[],[],Rule,RuleNb), symmetry_analysis_heads_propagation(H2,IDs2,[],[],Rule,RuleNb) ; true ), symmetry_analysis_main(Rs). symmetry_analysis_heads_simplification([],[],_,_,_,_). symmetry_analysis_heads_simplification([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :- ( \+ is_passive(RuleNb,ID), member2(PreHs,PreIDs,PreH-PreID), \+ is_passive(RuleNb,PreID), variable_replacement(PreH,H,List), copy_with_variable_replacement(Rule,Rule2,List), identical_guarded_rules(Rule,Rule2) -> passive(RuleNb,ID) ; true ), symmetry_analysis_heads_simplification(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb). symmetry_analysis_heads_propagation([],[],_,_,_,_). symmetry_analysis_heads_propagation([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :- ( \+ is_passive(RuleNb,ID), member2(PreHs,PreIDs,PreH-PreID), \+ is_passive(RuleNb,PreID), variable_replacement(PreH,H,List), copy_with_variable_replacement(Rule,Rule2,List), identical_rules(Rule,Rule2) -> passive(RuleNb,ID) ; true ), symmetry_analysis_heads_propagation(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ _ _ __ _ _ _ %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __ %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \ %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | | %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_| %% |_| simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :- PragmaRule = pragma(Rule,_,Pragmas,_,RuleNb), head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs), build_head(F,A,Id,HeadVars,ClauseHead), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars), guard_splitting(Rule,GuardList0), ( is_stored_in_guard(F/A, RuleNb) -> GuardList = [Hole1|GuardList0] ; GuardList = GuardList0 ), guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest), rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_), guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy), ( is_stored_in_guard(F/A, RuleNb) -> gen_occ_allocation_in_guard(F/A,O,Vars,Susp,Allocation), gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_), GuardCopyList = [Hole1Copy|_], Hole1Copy = (Allocation, Attachment) ; true ), partner_constraint_detachments(Susps,RestHeads,VarDict,SuspsDetachments), active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment), ( chr_pp_flag(debugable,on) -> Rule = rule(_,_,Guard,Body), my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps), DebugTry = 'chr debug_event'( try(SortedSusps,[],DebugGuard,DebugBody)), DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)), instrument_goal(ActualCut,DebugTry,DebugApply,Cut) ; Cut = ActualCut ), ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ), Clause = ( ClauseHead :- FirstMatching, RescheduledTest, Cut, SuspsDetachments, SuspDetachment, BodyCopy ), add_location(Clause,RuleNb,LocatedClause), L = [LocatedClause | T]. add_location(Clause,RuleNb,NClause) :- ( chr_pp_flag(line_numbers,on) -> get_chr_source_file(File), get_line_number(RuleNb,LineNb), NClause = '$source_location'(File,LineNb):Clause ; NClause = Clause ). add_dummy_location(Clause,NClause) :- ( chr_pp_flag(line_numbers,on) -> get_chr_source_file(File), NClause = '$source_location'(File,1):Clause ; NClause = Clause ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict) is det. % % Return goal matching newly introduced variables with variables in % previously looked-up heads. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :- head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% head_arg_matches(+Pairs,+Modes,+VarDict,-Goal,-NVarDict,+GroundVars,-NGroundVars) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :- head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars), list2conj(GoalList,Goal). head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars). head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :- ( var(Arg) -> ( lookup_eq(VarDict,Arg,OtherVar) -> ( Mode = (+) -> ( memberchk_eq(Arg,GroundVars) -> GoalList = [Var = OtherVar | RestGoalList], GroundVars1 = GroundVars ; GoalList = [Var == OtherVar | RestGoalList], GroundVars1 = [Arg|GroundVars] ) ; GoalList = [Var == OtherVar | RestGoalList], GroundVars1 = GroundVars ), VarDict1 = VarDict ; VarDict1 = [Arg-Var | VarDict], GoalList = RestGoalList, ( Mode = (+) -> GroundVars1 = [Arg|GroundVars] ; GroundVars1 = GroundVars ) ), Pairs = Rest, RestModes = Modes ; ground(Arg), Arg = '$chr_identifier_match'(ActualArg,IndexType) -> identifier_label_atom(IndexType,Var,ActualArg,Goal), GoalList = [Goal|RestGoalList], VarDict = VarDict1, GroundVars1 = GroundVars, Pairs = Rest, RestModes = Modes ; atomic(Arg) -> ( Mode = (+) -> GoalList = [ Var = Arg | RestGoalList] ; GoalList = [ Var == Arg | RestGoalList] ), VarDict = VarDict1, GroundVars1 = GroundVars, Pairs = Rest, RestModes = Modes ; Mode == (+), is_ground(GroundVars,Arg) -> copy_with_variable_replacement(Arg,ArgCopy,VarDict), GoalList = [ Var = ArgCopy | RestGoalList], VarDict = VarDict1, GroundVars1 = GroundVars, Pairs = Rest, RestModes = Modes ; Arg =.. [_|Args], functor(Arg,Fct,N), functor(Term,Fct,N), Term =.. [_|Vars], ( Mode = (+) -> GoalList = [ Var = Term | RestGoalList ] ; GoalList = [ nonvar(Var), Var = Term | RestGoalList ] ), pairup(Args,Vars,NewPairs), append(NewPairs,Rest,Pairs), replicate(N,Mode,NewModes), append(NewModes,Modes,RestModes), VarDict1 = VarDict, GroundVars1 = GroundVars ), head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % add_heads_types(+ListOfHeads,+VarTypes,-NVarTypes) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% add_heads_types([],VarTypes,VarTypes). add_heads_types([Head|Heads],VarTypes,NVarTypes) :- add_head_types(Head,VarTypes,VarTypes1), add_heads_types(Heads,VarTypes1,NVarTypes). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % add_head_types(+Head,+VarTypes,-NVarTypes) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% add_head_types(Head,VarTypes,NVarTypes) :- functor(Head,F,A), get_constraint_type_det(F/A,ArgTypes), Head =.. [_|Args], add_args_types(Args,ArgTypes,VarTypes,NVarTypes). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % add_args_types(+Terms,+Types,+VarTypes,-NVarTypes) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% add_args_types([],[],VarTypes,VarTypes). add_args_types([Arg|Args],[Type|Types],VarTypes,NVarTypes) :- add_arg_types(Arg,Type,VarTypes,VarTypes1), add_args_types(Args,Types,VarTypes1,NVarTypes). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% % add_arg_types(+Term,+Type,+VarTypes,-NVarTypes) is det. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% add_arg_types(Term,Type,VarTypes,NVarTypes) :- ( var(Term) -> ( lookup_eq(VarTypes,Term,_) -> NVarTypes = VarTypes ; NVarTypes = [Term-Type|VarTypes] ) ; ground(Term) -> NVarTypes = VarTypes ; % TODO improve approximation! term_variables(Term,Vars), length(Vars,VarNb), replicate(VarNb,any,Types), add_args_types(Vars,Types,VarTypes,NVarTypes) ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% add_heads_ground_variables(+ListOfHeads,+GroundVars,-NGroundVars) is det. % %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% add_heads_ground_variables([],GroundVars,GroundVars). add_heads_ground_variables([Head|Heads],GroundVars,NGroundVars) :- add_head_ground_variables(Head,GroundVars,GroundVars1), add_heads_ground_variables(Heads,GroundVars1,NGroundVars). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% add_head_ground_variables(+Head,+GroundVars,-GroundVars) is det. % %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% add_head_ground_variables(Head,GroundVars,NGroundVars) :- functor(Head,F,A), get_constraint_mode(F/A,ArgModes), Head =.. [_|Args], add_arg_ground_variables(Args,ArgModes,GroundVars,NGroundVars). add_arg_ground_variables([],[],GroundVars,GroundVars). add_arg_ground_variables([Arg|Args],[Mode|Modes],GroundVars,NGroundVars) :- ( Mode == (+) -> term_variables(Arg,Vars), add_var_ground_variables(Vars,GroundVars,GroundVars1) ; GroundVars = GroundVars1 ), add_arg_ground_variables(Args,Modes,GroundVars1,NGroundVars). add_var_ground_variables([],GroundVars,GroundVars). add_var_ground_variables([Var|Vars],GroundVars,NGroundVars) :- ( memberchk_eq(Var,GroundVars) -> GroundVars1 = GroundVars ; GroundVars1 = [Var|GroundVars] ), add_var_ground_variables(Vars,GroundVars1,NGroundVars). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% is_ground(+GroundVars,+Term) is semidet. % % Determine whether =Term= is always ground. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% is_ground(GroundVars,Term) :- ( ground(Term) -> true ; compound(Term) -> Term =.. [_|Args], maplist(is_ground(GroundVars),Args) ; memberchk_eq(Term,GroundVars) ). %% check_ground(+GroundVars,+Term,-Goal) is det. % % Return runtime check to see whether =Term= is ground. check_ground(GroundVars,Term,Goal) :- term_variables(Term,Variables), check_ground_variables(Variables,GroundVars,Goal). check_ground_variables([],_,true). check_ground_variables([Var|Vars],GroundVars,Goal) :- ( memberchk_eq(Var,GroundVars) -> check_ground_variables(Vars,GroundVars,Goal) ; Goal = (ground(Var), RGoal), check_ground_variables(Vars,GroundVars,RGoal) ). rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :- rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_). rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :- ( Heads = [_|_] -> rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars) ; GoalList = [], Susps = [], VarDict = NVarDict, GroundVars = NGroundVars ). rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars). rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead, [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :- functor(H,F,A), head_info(H,A,Vars,_,_,Pairs), get_store_type(F/A,StoreType), ( StoreType == default -> passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,Suspension), get_static_suspension_term_field(arguments,F/A,Suspension,Vars), get_static_suspension_field(F/A,Suspension,state,active,GetState) ) ), % create_get_mutable_ref(active,State,GetMutable), get_constraint_mode(F/A,Mode), head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1), NPairs = Pairs, sbag_member_call(Susp,VarSusps,Sbag), ExistentialLookup = ( ViaGoal, Sbag, Susp = Suspension, % not inlined GetState ) ; delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,Suspension), get_static_suspension_term_field(arguments,F/A,Suspension,Vars) ) ), existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,GroundVars,Suspension,ExistentialLookup,Susp,Pairs,NPairs), get_constraint_mode(F/A,Mode), filter_mode(NPairs,Pairs,Mode,NMode), head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1) ), different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals), append(NPairs,VarDict1,DA_), % order important here translate(GroundVars1,DA_,GroundVarsA), translate(GroundVars1,VarDict1,GroundVarsB), inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB), Goal = ( ExistentialLookup, DiffSuspGoals, MatchingGoal2 ), rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars). inline_matching_goal(A==B,true,GVA,GVB) :- memberchk_eq(A,GVA), memberchk_eq(B,GVB), A=B, !. % inline_matching_goal(A=B,true,_,_) :- A=B, !. inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !, inline_matching_goal(A,A2,GVA,GVB), inline_matching_goal(B,B2,GVA,GVB). inline_matching_goal(X,X,_,_). filter_mode([],_,_,[]). filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :- ( Var == V -> Modes = [M|MT], filter_mode(Rest,R,Ms,MT) ; filter_mode([Arg-Var|Rest],R,Ms,Modes) ). 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 % TODO: detect more cases where constraints need be different different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :- different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList), list2conj(DiffSuspGoalList,DiffSuspGoals). different_from_other_susps_(_,[],_,_,[]) :- !. different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :- ( functor(Head,F,A), functor(PreHead,F,A), copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy), \+ \+ PreHeadCopy = HeadCopy -> List = [Susp \== PreSusp | Tail] ; List = Tail ), different_from_other_susps_(Heads,Susps,Head,Susp,Tail). % passive_head_via(in,in,in,in,out,out,out) :- passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :- functor(Head,F,A), get_constraint_index(F/A,Pos), common_variables(Head,PrevHeads,CommonVars), global_list_store_name(F/A,Name), GlobalGoal = nb_getval(Name,AllSusps), get_constraint_mode(F/A,ArgModes), ( Vars == [] -> Goal = GlobalGoal ; member(CommonVar,CommonVars), nth(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar -> translate([CommonVar],VarDict,[Var]), gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps), Goal = AttrGoal ; translate(CommonVars,VarDict,Vars), add_heads_types(PrevHeads,[],TypeDict), my_term_copy(TypeDict,VarDict,TypeDictCopy), gen_get_mod_constraints(F/A,Vars,TypeDictCopy,ViaGoal,AttrGoal,AllSusps), Goal = ( ViaGoal -> AttrGoal ; GlobalGoal ) ). common_variables(T,Ts,Vs) :- term_variables(T,V1), term_variables(Ts,V2), intersect_eq(V1,V2,Vs). gen_get_mod_constraints(FA,Vars,TypeDict,ViaGoal,AttrGoal,AllSusps) :- get_target_module(Mod), ( Vars = [A] -> lookup_eq(TypeDict,A,Type), ( atomic_type(Type) -> ViaGoal = var(A), A = V ; ViaGoal = 'chr newvia_1'(A,V) ) ; Vars = [A,B] -> ViaGoal = 'chr newvia_2'(A,B,V) ; ViaGoal = 'chr newvia'(Vars,V) ), AttrGoal = ( get_attr(V,Mod,TSusps), TSuspsEqSusps % TSusps = Susps ), get_max_constraint_index(N), ( N == 1 -> TSuspsEqSusps = true, % TSusps = Susps AllSusps = TSusps ; get_constraint_index(FA,Pos), get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps) ). gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :- get_target_module(Mod), AttrGoal = ( get_attr(Var,Mod,TSusps), TSuspsEqSusps % TSusps = Susps ), get_max_constraint_index(N), ( N == 1 -> TSuspsEqSusps = true, % TSusps = Susps AllSusps = TSusps ; get_constraint_index(FA,Pos), get_suspensions(N,Pos,TSusps,TSuspsEqSusps,AllSusps) ). 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(H,_,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), % variables that are declared to be ground don't need to be locked ground_vars(H,GroundVars), list_difference_eq(GuardVars,GroundVars,GuardVars_), ( chr_pp_flag(guard_locks,on), bagof(('chr lock'(Y)) - ('chr unlock'(Y)), X ^ (lists:member(X,GuardVars), % X is a variable appearing in the original guard pairlist: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(G,VarDict) :- binds_b(G,Vars), \+ (( member(V,Vars), lookup_eq(VarDict,V,_) )). active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment) :- functor(Head,F,A), C = F/A, ( is_stored(C) -> ( ( Id == [0], chr_pp_flag(store_in_guards, off) ; ( get_allocation_occurrence(C,AO), get_max_occurrence(C,MO), MO < AO ) ), only_ground_indexed_arguments(C), chr_pp_flag(late_allocation,on) -> SuspDetachment = true ; gen_uncond_susp_detachment(Head,Susp,active,VarDict,UnCondSuspDetachment), ( chr_pp_flag(late_allocation,on) -> SuspDetachment = ( var(Susp) -> true ; UnCondSuspDetachment ) ; SuspDetachment = UnCondSuspDetachment ) ) ; SuspDetachment = true ). partner_constraint_detachments([],[],_,true). partner_constraint_detachments([Susp|Susps],[Head|Heads],VarDict,(SuspDetachment,SuspsDetachments)) :- gen_uncond_susp_detachment(Head,Susp,partner,VarDict,SuspDetachment), partner_constraint_detachments(Susps,Heads,VarDict,SuspsDetachments). gen_uncond_susp_detachment(Head,Susp,Role,VarDict,SuspDetachment) :- functor(Head,F,A), C = F/A, ( is_stored(C) -> SuspDetachment = ( DebugEvent, RemoveInternalGoal), ( chr_pp_flag(debugable,on) -> DebugEvent = 'chr debug_event'(remove(Susp)) ; DebugEvent = true ), remove_constraint_goal(C,Susp,Vars,true,(DeleteCall,Detach),Role,RemoveInternalGoal), delete_constraint_goal(Head,Susp,VarDict,DeleteCall), ( \+ only_ground_indexed_arguments(C), \+ get_store_type(C,var_assoc_store(_,_)) -> detach_constraint_atom(C,Vars,Susp,Detach) ; Detach = true ) ; SuspDetachment = true ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ _ _ _ %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / | %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | | %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | | %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_| %% |_| |___/ simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,O,Id,L,T) :- PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,RuleNb), Rule = rule(_Heads,Heads2,Guard,Body), head_info(Head,A,Vars,Susp,HeadVars,HeadPairs), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars), build_head(F,A,Id,HeadVars,ClauseHead), append(RestHeads,Heads2,Heads), append(OtherIDs,Heads2IDs,IDs), reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs), guard_splitting(Rule,GuardList0), ( is_stored_in_guard(F/A, RuleNb) -> GuardList = [Hole1|GuardList0] ; GuardList = GuardList0 ), guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest), rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_), split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs), guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy), ( is_stored_in_guard(F/A, RuleNb) -> gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,_), GuardCopyList = [Hole1Copy|_], Hole1Copy = Attachment ; true ), sort_by_key(Susps1,Susps1IDs,SortedSusps1), partner_constraint_detachments(SortedSusps1,RestHeads,VarDict,SuspsDetachments), active_constraint_detachment(Id,Susp,Head,VarDict,SuspDetachment), ( chr_pp_flag(debugable,on) -> my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps), sort_by_key(Susps2,Susps2IDs,KeptSusps), DebugTry = 'chr debug_event'( try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)), DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)), instrument_goal((!),DebugTry,DebugApply,Cut) ; Cut = (!) ), Clause = ( ClauseHead :- FirstMatching, RescheduledTest, Cut, SuspsDetachments, SuspDetachment, BodyCopy ), add_location(Clause,RuleNb,LocatedClause), L = [LocatedClause | 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). split_by_ids([],[],_,[],[],[],[]). split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :- ( memberchk_eq(I,I1s) -> S1s = [S | R1s], SI1s = [I|RSI1s], S2s = R2s, SI2s = RSI2s ; S1s = R1s, SI1s = RSI1s, S2s = [S | R2s], SI2s = [I|RSI2s] ), split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ _ _ ____ %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \ %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) | %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/ %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____| %% |_| |___/ %% Genereate prelude + worker predicate %% prelude calls worker %% worker iterates over one type of removed constraints simpagation_head2_code(Head2,ID,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :- PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb), Rule = rule(Heads1,_,Guard,Body), append(Heads1,RestHeads2,Heads), append(IDs1,RestIDs,IDs), reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]), simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1), extend_id(Id,Id1), ( memberchk_eq(NID,IDs2) -> simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2) ; L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs ), universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,Id2,L2,L3), simpagation_head2_worker(PreHeads,NextHeads,NextIDs,ID,PragmaRule,FA,O,Id2,L3,T). simpagation_universal_searches([],[],_,PreHeads,_,_,[],PreHeads,[],Id,Id,L,L). simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :- Heads = [Head|RHeads], inc_id(Id,Id1), universal_search_iterator_end(PreHeads,Heads,Rule,C,Id,L,L0), universal_search_iterator(Heads,PreHeads,Rule,C,Id,L0,L1), ( memberchk_eq(ID,IDs2) -> simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T) ; NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :- head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), build_head(F,A,Id1,VarsSusp,ClauseHead), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars), lookup_passive_head(Head1,[Head],VarDict,GroundVars,ModConstraintsGoal,AllSusps), gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal), extend_id(Id1,DelegateId), extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars), append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars), build_head(F,A,DelegateId,DelegateCallVars,Delegate), PreludeClause = ( ClauseHead :- FirstMatching, ModConstraintsGoal, !, ConstraintAllocationGoal, Delegate ), add_dummy_location(PreludeClause,LocatedPreludeClause), L = [LocatedPreludeClause|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([CurrentHead|PreHeads],NextHeads,NextIDs,ID,PragmaRule,F/A,O,Id,L,T) :- PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb), Rule = rule(_,_,Guard,Body), get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps), gen_var(OtherSusp), gen_var(OtherSusps), functor(CurrentHead,OtherF,OtherA), gen_vars(OtherA,OtherVars), head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs), get_constraint_mode(OtherF/OtherA,Mode), head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(OtherF/OtherA,OtherSuspension), get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState), get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars) ) ), % create_get_mutable_ref(active,State,GetMutable), different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals), CurrentSuspTest = ( OtherSusp = OtherSuspension, GetState, DiffSuspGoals, FirstMatching ), ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], build_head(F,A,Id,ClauseVars,ClauseHead), guard_splitting(Rule,GuardList0), ( is_stored_in_guard(F/A, RuleNb) -> GuardList = [Hole1|GuardList0] ; GuardList = GuardList0 ), guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest), rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]), split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2), split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_), partner_constraint_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],VarDict2,Susps1Detachments), RecursiveVars = [OtherSusps|PreVarsAndSusps], build_head(F,A,Id,RecursiveVars,RecursiveCall), RecursiveVars2 = [[]|PreVarsAndSusps], build_head(F,A,Id,RecursiveVars2,RecursiveCall2), guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy), ( is_stored_in_guard(F/A, RuleNb) -> GuardCopyList = [GuardAttachment|_] % once( ) ?? ; true ), ( is_observed(F/A,O) -> gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation), gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall), gen_state_cond_call(Susp,F/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 ), ( is_stored_in_guard(F/A, RuleNb) -> GuardAttachment = Attachment, BodyAttachment = true ; GuardAttachment = true, BodyAttachment = Attachment % will be true if not observed at all ), ( member(unique(ID1,UniqueKeys), Pragmas), check_unique_keys(UniqueKeys,VarDict) -> Clause = ( ClauseHead :- ( CurrentSuspTest -> ( RescheduledTest, DebugTry -> DebugApply, Susps1Detachments, BodyAttachment, BodyCopy, ConditionalRecursiveCall2 ; RecursiveCall2 ) ; RecursiveCall ) ) ; Clause = ( ClauseHead :- ( CurrentSuspTest, RescheduledTest, DebugTry -> DebugApply, Susps1Detachments, BodyAttachment, BodyCopy, ConditionalRecursiveCall ; RecursiveCall ) ) ), add_location(Clause,RuleNb,LocatedClause), L = [LocatedClause | T]. gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :- ( may_trigger(FA) -> does_use_field(FA,generation), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(FA,Suspension), get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState), get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration), get_static_suspension_term_field(arguments,FA,Suspension,Args) ) ) ; delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(FA,Suspension), get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState), get_static_suspension_term_field(arguments,FA,Suspension,Args) ) ), GetGeneration = true ), ConditionalCall = ( Susp = Suspension, GetState, GetGeneration -> UpdateState, Call ; true ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ _ %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | | %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| %% |_| |___/ propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :- ( RestHeads == [] -> propagation_single_headed(Head,ID,Rule,RuleNb,FA,O,Id,L,T) ; propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% Single headed propagation %% everything in a single clause propagation_single_headed(Head,ID,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :- 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), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars), guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy), % - recursive call - RecursiveCall = NextHead, ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = ! ), Rule = rule(_,_,Guard,Body), ( chr_pp_flag(debugable,on) -> my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)), DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)), instrument_goal(ActualCut,DebugTry,DebugApply,Cut) ; Cut = ActualCut ), ( may_trigger(F/A), \+ has_no_history(RuleNb)-> use_auxiliary_predicate(novel_production), use_auxiliary_predicate(extend_history), does_use_history(F/A,O), gen_occ_allocation(F/A,O,Vars,Susp,Allocation), ( named_history(RuleNb,HistoryName,HistoryIDs) -> ( HistoryIDs == [] -> empty_named_history_novel_production(HistoryName,NovelProduction), empty_named_history_extend_history(HistoryName,ExtendHistory) ; Tuple = HistoryName ) ; Tuple = RuleNb ), ( var(NovelProduction) -> NovelProduction = '$novel_production'(Susp,Tuple), ExtendHistory = '$extend_history'(Susp,Tuple) ; true ), ( is_observed(F/A,O) -> gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation), gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall) ; Attachment = true, ConditionalRecursiveCall = RecursiveCall ) ; Allocation = true, NovelProduction = true, ExtendHistory = true, ( is_observed(F/A,O) -> get_allocation_occurrence(F/A,AllocO), ( O == AllocO -> gen_insert_constraint_internal_goal(F/A,Attachment,VarsSusp,Vars,Susp), Generation = 0 ; % more room for improvement? Attachment = (Attachment1, Attachment2), gen_occ_allocation(F/A,O,Vars,Susp,Attachment1), gen_uncond_attach_goal(F/A,Susp,Vars,Attachment2,Generation) ), gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall) ; gen_occ_allocation(F/A,O,Vars,Susp,Attachment), ConditionalRecursiveCall = RecursiveCall ) ), ( is_stored_in_guard(F/A, RuleNb) -> GuardAttachment = Attachment, BodyAttachment = true ; GuardAttachment = true, BodyAttachment = Attachment % will be true if not observed at all ), Clause = ( ClauseHead :- HeadMatching, Allocation, NovelProduction, GuardAttachment, GuardCopy, Cut, ExtendHistory, BodyAttachment, BodyCopy, ConditionalRecursiveCall ), add_location(Clause,RuleNb,LocatedClause), ProgramList = [LocatedClause | ProgramTail]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% multi headed propagation %% prelude + predicates to accumulate the necessary combinations of suspended %% constraints + predicate to execute the body propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :- RestHeads = [First|Rest], propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1), extend_id(Id,ExtendedId), propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :- head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs), build_head(F,A,Id,VarsSusp,PreludeHead), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict,[],GroundVars), Rule = rule(_,_,Guard,Body), extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars), lookup_passive_head(First,[Head],VarDict,GroundVars,FirstSuspGoal,Susps), gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation), extend_id(Id,NestedId), append([Susps|VarsSusp],ExtraVars,NestedVars), build_head(F,A,NestedId,NestedVars,NestedHead), NestedCall = NestedHead, Prelude = ( PreludeHead :- FirstMatching, FirstSuspGoal, !, CondAllocation, NestedCall ), add_dummy_location(Prelude,LocatedPrelude), L = [LocatedPrelude|T]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :- universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1), propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T). propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :- universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1), universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2), inc_id(Id,IncId), propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T). %check_fd_lookup_condition(_,_,_,_) :- fail. check_fd_lookup_condition(F,A,_,_) :- get_store_type(F/A,global_singleton), !. check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :- \+ may_trigger(F/A), get_functional_dependency(F/A,1,P,K), copy_term(P-K,CurrentHead-Key), term_variables(PreHeads,PreVars), intersect_eq(Key,PreVars,Key),!. propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :- Rule = rule(_,H2,Guard,Body), gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators), flatten(PreVarsAndSuspsList,PreVarsAndSusps), init(AllSusps,RestSusps), last(AllSusps,Susp), gen_var(OtherSusp), gen_var(OtherSusps), functor(CurrentHead,OtherF,OtherA), gen_vars(OtherA,OtherVars), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(OtherF/OtherA,Suspension), get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState), get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars) ) ), % create_get_mutable_ref(active,State,GetMutable), CurrentSuspTest = ( OtherSusp = Suspension, GetState ), ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps], build_head(F,A,Id,ClauseVars,ClauseHead), ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId), RecursiveVars = PreVarsAndSusps1 ; RecursiveVars = [OtherSusps|PreVarsAndSusps], PrevId = Id ), build_head(F,A,PrevId,RecursiveVars,RecursiveHead), RecursiveCall = RecursiveHead, CurrentHead =.. [_|OtherArgs], pairup(OtherArgs,OtherVars,OtherPairs), get_constraint_mode(OtherF/OtherA,Mode), head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict), different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals), guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy), get_occurrence(F/A,O,_,ID), ( is_observed(F/A,O) -> init(FirstVarsSusp,FirstVars), gen_uncond_attach_goal(F/A,Susp,FirstVars,Attachment,Generation), gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall) ; Attachment = true, ConditionalRecursiveCall = RecursiveCall ), ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) -> NovelProduction = true, ExtendHistory = true ; \+ may_trigger(F/A), forall(member(SomeID,RestIDs),(chr_translate:is_passive(RuleNb,SomeID))) -> NovelProduction = true, ExtendHistory = true ; get_occurrence(F/A,O,_,ID), use_auxiliary_predicate(novel_production), use_auxiliary_predicate(extend_history), does_use_history(F/A,O), ( named_history(RuleNb,HistoryName,HistoryIDs) -> ( HistoryIDs == [] -> empty_named_history_novel_production(HistoryName,NovelProduction), empty_named_history_extend_history(HistoryName,ExtendHistory) ; reverse([OtherSusp|RestSusps],NamedSusps), named_history_susps(HistoryIDs,[ID|RestIDs],[Susp|NamedSusps],HistorySusps), HistorySusps = [HistorySusp|_], ( length(HistoryIDs, 1) -> ExtendHistory = '$extend_history'(HistorySusp,HistoryName), NovelProduction = '$novel_production'(HistorySusp,HistoryName) ; findall(ConstraintSymbol,(member(SomeID,HistoryIDs),get_occurrence_from_id(ConstraintSymbol,_,RuleNb,SomeID)),ConstraintSymbols), Tuple =.. [t,HistoryName|HistorySusps] ) ) ; HistorySusp = Susp, findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols), sort([ID|RestIDs],HistoryIDs), history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps), Tuple =.. [t,RuleNb|HistorySusps] ), ( var(NovelProduction) -> novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions), ExtendHistory = '$extend_history'(HistorySusp,TupleVar), NovelProduction = ( TupleVar = Tuple, NovelProductions ) ; true ) ), ( chr_pp_flag(debugable,on) -> Rule = rule(_,_,Guard,Body), my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody), get_occurrence(F/A,O,_,ID), sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps), DebugTry = 'chr debug_event'( try([],KeptSusps,DebugGuard,DebugBody)), DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody)) ; DebugTry = true, DebugApply = true ), ( is_stored_in_guard(F/A, RuleNb) -> GuardAttachment = Attachment, BodyAttachment = true ; GuardAttachment = true, BodyAttachment = Attachment % will be true if not observed at all ), Clause = ( ClauseHead :- ( CurrentSuspTest, DiffSuspGoals, Matching, NovelProduction, GuardAttachment, GuardCopy, DebugTry -> DebugApply, ExtendHistory, BodyAttachment, BodyCopy, ConditionalRecursiveCall ; RecursiveCall ) ), add_location(Clause,RuleNb,LocatedClause), L = [LocatedClause|T]. novel_production_calls([],[],[],_,_,true). novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :- get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID), delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)), novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals). history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :- reverse(ReversedRestSusps,RestSusps), sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps). named_history_susps([],_,_,[]). named_history_susps([HistoryID|HistoryIDs],IDs,Susps,[HistorySusp|HistorySusps]) :- select2(HistoryID,HistorySusp,IDs,Susps,RestIDs,RestSusps), !, named_history_susps(HistoryIDs,RestIDs,RestSusps,HistorySusps). gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :- !, functor(Head,F,A), head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,[],_,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), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict), passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars), append(HeadVars,[Susp,Susps|Rest],VarsSusps). % returns % VarDict for the copies of variables in the original heads % VarsSuspsList list of lists of arguments for the successive heads % FirstVarsSusp top level arguments % SuspList list of all suspensions % Iterators list of all iterators gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :- !, functor(Head,F,A), head_info(Head,A,_Vars,Susp,VarsSusp,Pairs), % make variables for argument positions get_constraint_mode(F/A,Mode), head_arg_matches(Pairs,Mode,[],_,VarDict), % copy variables inside arguments, build dictionary extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), % decide what additional variables are needed append(VarsSusp,ExtraVars,HeadVars). % add additional variables to head variables gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :- gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators), functor(Head,F,A), gen_var(Susps), head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs), get_constraint_mode(F/A,Mode), head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict), passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars), append(HeadVars,[Susp,Susps],Vars). get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :- !, functor(Head,F,A), head_info(Head,A,Vars,Susp,VarsSusp,Pairs), get_constraint_mode(F/A,Mode), head_arg_matches(Pairs,Mode,[],_,VarDict), extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars), append(VarsSusp,ExtraVars,HeadVars). get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :- get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps), functor(Head,F,A), gen_var(Susps), head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs), get_constraint_mode(F/A,Mode), head_arg_matches(Pairs,Mode,VarDict,_,NVarDict), passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars), append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ____ _ _ _ _ %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| | %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` | %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| | %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_| %% %% ____ _ _ _ %% | _ \ ___| |_ _ __(_) _____ ____ _| | %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | | %% | _ < __/ |_| | | | __/\ V / (_| | | %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_| %% %% ____ _ _ %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _ %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` | %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| | %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, | %% |___/ reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :- ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 -> reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) ; NRestHeads = RestHeads, NRestIDs = RestIDs ). reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :- term_variables(Head,Vars), InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb), copy_term_nat(InitialData,InitialDataCopy), a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData), InitialDataCopy = InitialData, FinalData = entry(RNRestHeads,RNRestIDs,_,_,_,_), reverse(RNRestHeads,NRestHeads), reverse(RNRestIDs,NRestIDs). final_data(Entry) :- Entry = entry(_,_,_,_,[],_). expand_data(Entry,NEntry,Cost) :- Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb), select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1), term_variables([Head1|Vars],Vars1), NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb), order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost). % Assigns score to head based on known variables and heads to lookup order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :- functor(Head,F,A), get_store_type(F/A,StoreType), order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score). order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :- term_variables(Head,HeadVars), term_variables(RestHeads,RestVars), order_score_vars(HeadVars,KnownVars,RestVars,Score). order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :- order_score_indexes(Indexes,Head,KnownVars,0,Score). order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :- order_score_indexes(Indexes,Head,KnownVars,0,Score). order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :- term_variables(Head,HeadVars), term_variables(RestHeads,RestVars), order_score_vars(HeadVars,KnownVars,RestVars,Score_), Score is Score_ * 2. order_score(var_assoc_store(_,_),_,_,_,_,_,1). order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :- Score = 1. % guaranteed O(1) order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :- find_with_var_identity( S, t(Head,KnownVars,RestHeads), ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ), Scores ), min_list(Scores,Score). order_score(identifier_store(Index),Head,ID,KnownVars,RestHeads,RuleNb,Score) :- Score = 10. order_score(type_indexed_identifier_store(_,_),Head,ID,KnownVars,RestHeads,RuleNb,Score) :- Score = 10. order_score_indexes([],_,_,Score,NScore) :- Score > 0, NScore = 100. order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :- multi_hash_key_args(I,Head,Args), ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) -> Score1 is Score + 1 ; Score1 = Score ), order_score_indexes(Is,Head,KnownVars,Score1,NScore). order_score_vars(Vars,KnownVars,RestVars,Score) :- order_score_count_vars(Vars,KnownVars,RestVars,K-R-O), ( K-R-O == 0-0-0 -> Score = 0 ; K > 0 -> Score is max(10 - K,0) ; R > 0 -> Score is max(10 - R,1) * 10 ; Score is max(10-O,1) * 100 ). order_score_count_vars([],_,_,0-0-0). order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :- order_score_count_vars(Vs,KnownVars,RestVars,K-R-O), ( memberchk_eq(V,KnownVars) -> NK is K + 1, NR = R, NO = O ; memberchk_eq(V,RestVars) -> NR is R + 1, NK = K, NO = O ; NO is O + 1, NK = K, NR = R ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% ___ _ _ _ %% |_ _|_ __ | (_)_ __ (_)_ __ __ _ %% | || '_ \| | | '_ \| | '_ \ / _` | %% | || | | | | | | | | | | | | (_| | %% |___|_| |_|_|_|_| |_|_|_| |_|\__, | %% |___/ %% SWI begin create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)). create_get_mutable(V,M,GM) :- M = mutable(V), GM = true. %% SWI end %% SICStus begin %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M). %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M). %% SICStus end %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %% _ _ _ _ _ _ _ %% | | | | |_(_) (_) |_ _ _ %% | | | | __| | | | __| | | | %% | |_| | |_| | | | |_| |_| | %% \___/ \__|_|_|_|\__|\__, | %% |___/ % Create a fresh variable. gen_var(_). % Create =N= fresh variables. 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. % return clause Head % for F/A constraint symbol, predicate identifier Id and arguments Head build_head(F,A,Id,Args,Head) :- buildName(F,A,Id,Name), ( (chr_pp_flag(debugable,on) ; is_stored(F/A), ( has_active_occurrence(F/A) ; chr_pp_flag(late_allocation,off)), ( may_trigger(F/A) ; get_allocation_occurrence(F/A,AO), get_max_occurrence(F/A,MO), MO >= AO ) ) -> Head =.. [Name|Args] ; init(Args,ArgsWOSusp), % XXX not entirely correct! Head =.. [Name|ArgsWOSusp] ). % return predicate name Result % for Fct/Aty constraint symbol and predicate identifier List buildName(Fct,Aty,List,Result) :- ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)), ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO), MO >= AO ) ; List \= [0])) ) ) -> atom_concat(Fct, '___' ,FctSlash), atomic_concat(FctSlash,Aty,FctSlashAty), buildName_(List,FctSlashAty,Result) ; Result = Fct ). buildName_([],Name,Name). buildName_([N|Ns],Name,Result) :- buildName_(Ns,Name,Name1), atom_concat(Name1,'__',NameDash), % '_' is a char :-( atomic_concat(NameDash,N,Result). vars_susp(A,Vars,Susp,VarsSusp) :- length(Vars,A), append(Vars,[Susp],VarsSusp). 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). make_name(Prefix,F/A,Name) :- atom_concat_list([Prefix,F,'___',A],Name). %=============================================================================== % Attribute for attributed variables make_attr(N,Mask,SuspsList,Attr) :- length(SuspsList,N), Attr =.. [v,Mask|SuspsList]. get_all_suspensions2(N,Attr,SuspensionsList) :- chr_pp_flag(dynattr,off), !, make_attr(N,_,SuspensionsList,Attr). % NEW get_all_suspensions2(N,Attr,Goal,SuspensionsList) :- % writeln(get_all_suspensions2), length(SuspensionsList,N), Goal = 'chr all_suspensions'(SuspensionsList,1,Attr). % NEW normalize_attr(Attr,NormalGoal,NormalAttr) :- % writeln(normalize_attr), NormalGoal = 'chr normalize_attr'(Attr,NormalAttr). get_suspensions(N,Position,TAttr,(TAttr = Attr),Suspensions) :- chr_pp_flag(dynattr,off), !, make_attr(N,_,SuspsList,Attr), nth1(Position,SuspsList,Suspensions). % NEW get_suspensions(N,Position,TAttr,Goal,Suspensions) :- % writeln(get_suspensions), Goal = ( memberchk(Position-Suspensions,TAttr) -> true ; Suspensions = [] ). %------------------------------------------------------------------------------- % +N: number of constraint symbols % +Suspension: source-level variable, for suspension % +Position: constraint symbol number % -Attr: source-level term, for new attribute singleton_attr(N,Suspension,Position,Attr) :- chr_pp_flag(dynattr,off), !, or_pattern(Position,Pattern), make_attr(N,Pattern,SuspsList,Attr), nth1(Position,SuspsList,[Suspension]), chr_delete(SuspsList,[Suspension],RestSuspsList), set_elems(RestSuspsList,[]). % NEW singleton_attr(N,Suspension,Position,Attr) :- % writeln(singleton_attr), Attr = [Position-[Suspension]]. %------------------------------------------------------------------------------- % +N: number of constraint symbols % +Suspension: source-level variable, for suspension % +Position: constraint symbol number % +TAttr: source-level variable, for old attribute % -Goal: goal for creating new attribute % -NTAttr: source-level variable, for new attribute add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :- chr_pp_flag(dynattr,off), !, make_attr(N,Mask,SuspsList,Attr), or_pattern(Position,Pattern), nth1(Position,SuspsList,Susps), substitute_eq(Susps,SuspsList,[Suspension|Susps],SuspsList1), make_attr(N,Mask,SuspsList1,NewAttr1), substitute_eq(Susps,SuspsList,[Suspension],SuspsList2), make_attr(N,NewMask,SuspsList2,NewAttr2), Goal = ( TAttr = Attr, ( Mask /\ Pattern =:= Pattern -> NTAttr = NewAttr1 ; NewMask is Mask \/ Pattern, NTAttr = NewAttr2 ) ), !. % NEW add_attr(N,Suspension,Position,TAttr,Goal,NTAttr) :- % writeln(add_attr), Goal = ( 'chr select'(TAttr,Position-Suspensions,RAttr) -> NTAttr = [Position-[Suspension|Suspensions]|RAttr] ; NTAttr = [Position-[Suspension]|TAttr] ). rem_attr(N,Var,Suspension,Position,TAttr,Goal) :- chr_pp_flag(dynattr,off), !, or_pattern(Position,Pattern), and_pattern(Position,DelPattern), make_attr(N,Mask,SuspsList,Attr), nth1(Position,SuspsList,Susps), substitute_eq(Susps,SuspsList,[],SuspsList1), make_attr(N,NewMask,SuspsList1,Attr1), substitute_eq(Susps,SuspsList,NewSusps,SuspsList2), make_attr(N,Mask,SuspsList2,Attr2), get_target_module(Mod), Goal = ( TAttr = Attr, ( Mask /\ Pattern =:= Pattern -> 'chr sbag_del_element'(Susps,Suspension,NewSusps), ( NewSusps == [] -> NewMask is Mask /\ DelPattern, ( NewMask == 0 -> del_attr(Var,Mod) ; put_attr(Var,Mod,Attr1) ) ; put_attr(Var,Mod,Attr2) ) ; true ) ), !. % NEW rem_attr(N,Var,Suspension,Position,TAttr,Goal) :- % writeln(rem_attr), get_target_module(Mod), Goal = ( 'chr select'(TAttr,Position-Suspensions,RAttr) -> 'chr sbag_del_element'(Suspensions,Suspension,NSuspensions), ( NSuspensions == [] -> ( RAttr == [] -> del_attr(Var,Mod) ; put_attr(Var,Mod,RAttr) ) ; put_attr(Var,Mod,[Position-NSuspensions|RAttr]) ) ; true ). %------------------------------------------------------------------------------- % +N: number of constraint symbols % +TAttr1: source-level variable, for attribute % +TAttr2: source-level variable, for other attribute % -Goal: goal for merging the two attributes % -Attr: source-level term, for merged attribute merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :- chr_pp_flag(dynattr,off), !, make_attr(N,Mask1,SuspsList1,Attr1), merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal2,Attr), Goal = ( TAttr1 = Attr1, Goal2 ). % NEW merge_attributes(N,TAttr1,TAttr2,Goal,Attr) :- % writeln(merge_attributes), Goal = ( sort(TAttr1,Sorted1), sort(TAttr2,Sorted2), 'chr new_merge_attributes'(Sorted1,Sorted2,Attr) ). %------------------------------------------------------------------------------- % +N: number of constraint symbols % +Mask1: ... % +SuspsList1: static term, for suspensions list % +TAttr2: source-level variable, for other attribute % -Goal: goal for merging the two attributes % -Attr: source-level term, for merged attribute merge_attributes2(N,Mask1,SuspsList1,TAttr2,Goal,Attr) :- make_attr(N,Mask2,SuspsList2,Attr2), bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList1,SuspsList2,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), SuspsList), make_attr(N,Mask,SuspsList,Attr), Goal = ( TAttr2 = Attr2, SortGoals, Mask is Mask1 \/ Mask2 ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Storetype dependent lookup %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict, %% -Goal,-SuspensionList) is det. % % Create a universal lookup goal for given head. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :- functor(Head,F,A), get_store_type(F/A,StoreType), lookup_passive_head(StoreType,Head,PreJoin,VarDict,[],Goal,AllSusps). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% lookup_passive_head(+Head,+PreviousVars,+RenamingVarDict,+GroundVars, %% -Goal,-SuspensionList) is det. % % Create a universal lookup goal for given head. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% lookup_passive_head(Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :- functor(Head,F,A), get_store_type(F/A,StoreType), lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% lookup_passive_head(+StoreType,+Head,+PreviousVars,+RenamingVarDict, %% +GroundVars,-Goal,-SuspensionList) is det. % % Create a universal lookup goal for given head. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% lookup_passive_head(default,Head,PreJoin,VarDict,_,Goal,AllSusps) :- functor(Head,F,A), passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps), update_store_type(F/A,default). lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :- hash_lookup_passive_head(inthash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_). lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,GroundVars,Goal,AllSusps) :- hash_lookup_passive_head(hash,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,_). lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :- functor(Head,F,A), global_ground_store_name(F/A,StoreName), make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps), update_store_type(F/A,global_ground). lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,_,Goal,AllSusps) :- arg(VarIndex,Head,OVar), arg(KeyIndex,Head,OKey), translate([OVar,OKey],VarDict,[Var,Key]), get_target_module(Module), Goal = ( get_attr(Var,Module,AssocStore), lookup_assoc_store(AssocStore,Key,AllSusps) ). lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,_,Goal,AllSusps) :- functor(Head,F,A), global_singleton_store_name(F/A,StoreName), make_get_store_goal(StoreName,Susp,GetStoreGoal), Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]), update_store_type(F/A,global_singleton). lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :- once(( member(ST,StoreTypes), lookup_passive_head(ST,Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) )). lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :- functor(Head,F,A), arg(Index,Head,Var), translate([Var],VarDict,[KeyVar]), delay_phase_end(validate_store_type_assumptions, identifier_lookup(F/A,Index,AllSusps,KeyVar,Goal) ), update_store_type(F/A,identifier_store(Index)), get_identifier_index(F/A,Index,_). lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,Goal,AllSusps) :- functor(Head,F,A), arg(Index,Head,Var), ( var(Var) -> translate([Var],VarDict,[KeyVar]), Goal = StructGoal ; ground(Var), Var = '$chr_identifier_match'(ActualVar,_) -> lookup_identifier_atom(IndexType,ActualVar,KeyVar,LookupGoal), Goal = (LookupGoal,StructGoal) ), delay_phase_end(validate_store_type_assumptions, type_indexed_identifier_lookup(F/A,Index,IndexType,AllSusps,KeyVar,StructGoal) ), update_store_type(F/A,type_indexed_identifier_store(Index,IndexType)), get_type_indexed_identifier_index(IndexType,F/A,Index,_). identifier_lookup(C,Index,AllSusps,KeyVar,Goal) :- get_identifier_size(ISize), functor(Struct,struct,ISize), get_identifier_index(C,Index,IIndex), arg(IIndex,Struct,AllSusps), Goal = (KeyVar = Struct). type_indexed_identifier_lookup(C,Index,IndexType,AllSusps,KeyVar,Goal) :- type_indexed_identifier_structure(IndexType,Struct), get_type_indexed_identifier_index(IndexType,C,Index,IIndex), arg(IIndex,Struct,AllSusps), Goal = (KeyVar = Struct). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% hash_lookup_passive_head(+StoreType,+Indexes,+Head,+RenamingVarDict, %% +GroundVars,-Goal,-SuspensionList,-Index) is det. % % Create a universal hash lookup goal for given head. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,Goal,AllSusps,Index) :- once(( member(Index,Indexes), multi_hash_key_args(Index,Head,KeyArgs), ( translate(KeyArgs,VarDict,KeyArgCopies) ; ground(KeyArgs), KeyArgCopies = KeyArgs ) )), ( KeyArgCopies = [KeyCopy] -> true ; KeyCopy =.. [k|KeyArgCopies] ), functor(Head,F,A), multi_hash_via_lookup_goal(F/A,Index,KeyCopy,AllSusps,LookupGoal), check_ground(GroundVars,KeyArgs,OriginalGroundCheck), my_term_copy(OriginalGroundCheck,VarDict,GroundCheck), Goal = (GroundCheck,LookupGoal), ( HashType == inthash -> update_store_type(F/A,multi_inthash([Index])) ; update_store_type(F/A,multi_hash([Index])) ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% existential_lookup(+StoreType,+Head,+PrevVariablesHead,+RenamingVarDict, %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar, %% +VarArgDict,-NewVarArgDict) is det. % % Create existential lookup goal for given head. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- !, lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,PreJoin,VarDict,GroundVars,UniversalGoal,AllSusps), sbag_member_call(Susp,AllSusps,Sbag), functor(Head,F,A), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,SuspTerm), get_static_suspension_field(F/A,SuspTerm,state,active,GetState) ) ), Goal = ( UniversalGoal, Sbag, Susp = SuspTerm, GetState ). existential_lookup(global_singleton,Head,_PreJoin,_VarDict,_,SuspTerm,Goal,Susp,Pairs,Pairs) :- !, functor(Head,F,A), global_singleton_store_name(F/A,StoreName), make_get_store_goal(StoreName,Susp,GetStoreGoal), Goal = ( GetStoreGoal, % nb_getval(StoreName,Susp), Susp \== [], Susp = SuspTerm ), update_store_type(F/A,global_singleton). existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, once(( member(ST,StoreTypes), existential_lookup(ST,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) )). existential_lookup(multi_inthash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, existential_hash_lookup(inthash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs). existential_lookup(multi_hash(Indexes),Head,_,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, existential_hash_lookup(hash,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs). existential_lookup(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, lookup_passive_head(identifier_store(Index),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps), hash_index_filter(Pairs,Index,NPairs), functor(Head,F,A), ( check_fd_lookup_condition(F,A,Head,KeyArgs) -> Sbag = (AllSusps = [Susp]) ; sbag_member_call(Susp,AllSusps,Sbag) ), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,SuspTerm), get_static_suspension_field(F/A,SuspTerm,state,active,GetState) ) ), Goal = ( LookupGoal, Sbag, Susp = SuspTerm, % not inlined GetState ). existential_lookup(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- !, lookup_passive_head(type_indexed_identifier_store(Index,IndexType),Head,PreJoin,VarDict,GroundVars,LookupGoal,AllSusps), hash_index_filter(Pairs,Index,NPairs), functor(Head,F,A), ( check_fd_lookup_condition(F,A,Head,KeyArgs) -> Sbag = (AllSusps = [Susp]) ; sbag_member_call(Susp,AllSusps,Sbag) ), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,SuspTerm), get_static_suspension_field(F/A,SuspTerm,state,active,GetState) ) ), Goal = ( LookupGoal, Sbag, Susp = SuspTerm, % not inlined GetState ). existential_lookup(StoreType,Head,PreJoin,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,Pairs) :- lookup_passive_head(StoreType,Head,PreJoin,VarDict,GroundVars,UGoal,Susps), sbag_member_call(Susp,Susps,Sbag), functor(Head,F,A), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,SuspTerm), get_static_suspension_field(F/A,SuspTerm,state,active,GetState) ) ), Goal = ( UGoal, Sbag, Susp = SuspTerm, % not inlined GetState ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% existential_hash_lookup(+StoreType,+Indexes,+Head,+RenamingVarDict, %% +GroundVariables,-SuspensionTerm,-Goal,-SuspVar, %% +VarArgDict,-NewVarArgDict) is det. % % Create existential hash lookup goal for given head. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% existential_hash_lookup(HashType,Indexes,Head,VarDict,GroundVars,SuspTerm,Goal,Susp,Pairs,NPairs) :- hash_lookup_passive_head(HashType,Indexes,Head,VarDict,GroundVars,LookupGoal,AllSusps,Index), hash_index_filter(Pairs,Index,NPairs), functor(Head,F,A), ( check_fd_lookup_condition(F,A,Head,KeyArgs) -> Sbag = (AllSusps = [Susp]) ; sbag_member_call(Susp,AllSusps,Sbag) ), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(F/A,SuspTerm), get_static_suspension_field(F/A,SuspTerm,state,active,GetState) ) ), Goal = ( LookupGoal, Sbag, Susp = SuspTerm, % not inlined GetState ). %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% %% hash_index_filter(+Pairs,+Index,-NPairs) is det. % % Filter out pairs already covered by given hash index. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~% hash_index_filter(Pairs,Index,NPairs) :- ( integer(Index) -> NIndex = [Index] ; NIndex = Index ), hash_index_filter(Pairs,NIndex,1,NPairs). hash_index_filter([],_,_,[]). hash_index_filter([P|Ps],Index,N,NPairs) :- ( Index = [I|Is] -> NN is N + 1, ( I > N -> NPairs = [P|NPs], hash_index_filter(Ps,[I|Is],NN,NPs) ; I == N -> hash_index_filter(Ps,Is,NN,NPairs) ) ; NPairs = [P|Ps] ). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %------------------------------------------------------------------------------% %% assume_constraint_stores(+ConstraintSymbols) is det. % % Compute all constraint store types that are possible for the given % =ConstraintSymbols=. %------------------------------------------------------------------------------% assume_constraint_stores([]). assume_constraint_stores([C|Cs]) :- ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(C) ; chr_pp_flag(mixed_stores,on) ), is_stored(C), get_store_type(C,default) -> get_indexed_arguments(C,AllIndexedArgs), get_constraint_mode(C,Modes), findall(Index,(member(Index,AllIndexedArgs), nth(Index,Modes,+)),IndexedArgs), length(IndexedArgs,NbIndexedArgs), % Construct Index Combinations ( NbIndexedArgs > 10 -> findall([Index],member(Index,IndexedArgs),Indexes) ; findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes), predsort(longer_list,UnsortedIndexes,Indexes) ), % Choose Index Type ( get_functional_dependency(C,1,Pattern,Key), all_distinct_var_args(Pattern), Key == [] -> assumed_store_type(C,global_singleton) ; ( only_ground_indexed_arguments(C) ; NbIndexedArgs > 0 ) -> get_constraint_type_det(C,ArgTypes), partition_indexes(Indexes,ArgTypes,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes), ( IntHashIndexes = [] -> Stores = Stores1 ; Stores = [multi_inthash(IntHashIndexes)|Stores1] ), ( HashIndexes = [] -> Stores1 = Stores2 ; Stores1 = [multi_hash(HashIndexes)|Stores2] ), ( IdentifierIndexes = [] -> Stores2 = Stores3 ; maplist(wrap_in_functor(identifier_store),IdentifierIndexes,WrappedIdentifierIndexes), append(WrappedIdentifierIndexes,Stores3,Stores2) ), append(CompoundIdentifierIndexes,Stores4,Stores3), ( only_ground_indexed_arguments(C) -> Stores4 = [global_ground] ; Stores4 = [default] ), assumed_store_type(C,multi_store(Stores)) ; true ) ; true ), assume_constraint_stores(Cs). %------------------------------------------------------------------------------% %% partition_indexes(+Indexes,+Types, %% -HashIndexes,-IntHashIndexes,-IdentifierIndexes) is det. %------------------------------------------------------------------------------% partition_indexes([],_,[],[],[],[]). partition_indexes([Index|Indexes],Types,HashIndexes,IntHashIndexes,IdentifierIndexes,CompoundIdentifierIndexes) :- ( Index = [I], nth(I,Types,Type), unalias_type(Type,UnAliasedType), UnAliasedType == chr_identifier -> IdentifierIndexes = [I|RIdentifierIndexes], IntHashIndexes = RIntHashIndexes, HashIndexes = RHashIndexes, CompoundIdentifierIndexes = RCompoundIdentifierIndexes ; Index = [I], nth(I,Types,Type), unalias_type(Type,UnAliasedType), nonvar(UnAliasedType), UnAliasedType = chr_identifier(IndexType) -> CompoundIdentifierIndexes = [type_indexed_identifier_store(I,IndexType)|RCompoundIdentifierIndexes], IdentifierIndexes = RIdentifierIndexes, IntHashIndexes = RIntHashIndexes, HashIndexes = RHashIndexes ; Index = [I], nth(I,Types,Type), unalias_type(Type,UnAliasedType), UnAliasedType == dense_int -> IntHashIndexes = [Index|RIntHashIndexes], HashIndexes = RHashIndexes, IdentifierIndexes = RIdentifierIndexes, CompoundIdentifierIndexes = RCompoundIdentifierIndexes ; member(I,Index), nth(I,Types,Type), unalias_type(Type,UnAliasedType), nonvar(UnAliasedType), UnAliasedType = chr_identifier(_) -> % don't use chr_identifiers in hash indexes IntHashIndexes = RIntHashIndexes, HashIndexes = RHashIndexes, IdentifierIndexes = RIdentifierIndexes, CompoundIdentifierIndexes = RCompoundIdentifierIndexes ; IntHashIndexes = RIntHashIndexes, HashIndexes = [Index|RHashIndexes], IdentifierIndexes = RIdentifierIndexes, CompoundIdentifierIndexes = RCompoundIdentifierIndexes ), partition_indexes(Indexes,Types,RHashIndexes,RIntHashIndexes,RIdentifierIndexes,RCompoundIdentifierIndexes). longer_list(R,L1,L2) :- length(L1,N1), length(L2,N2), compare(Rt,N2,N1), ( Rt == (=) -> compare(R,L1,L2) ; R = Rt ). all_distinct_var_args(Term) :- Term =.. [_|Args], copy_term_nat(Args,NArgs), all_distinct_var_args_(NArgs). all_distinct_var_args_([]). all_distinct_var_args_([X|Xs]) :- var(X), X = t, all_distinct_var_args_(Xs). get_indexed_arguments(C,IndexedArgs) :- C = F/A, get_indexed_arguments(1,A,C,IndexedArgs). get_indexed_arguments(I,N,C,L) :- ( I > N -> L = [] ; ( is_indexed_argument(C,I) -> L = [I|T] ; L = T ), J is I + 1, get_indexed_arguments(J,N,C,T) ). validate_store_type_assumptions([]). validate_store_type_assumptions([C|Cs]) :- validate_store_type_assumption(C), validate_store_type_assumptions(Cs). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % new code generation universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :- Rule = rule(H1,_,Guard,Body), gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators), universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId), flatten(VarsAndSuspsList,VarsAndSusps), Vars = [ [] | VarsAndSusps], build_head(F,A,Id,Vars,Head), build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall), Clause = ( Head :- PredecessorCall), add_dummy_location(Clause,LocatedClause), L = [LocatedClause | T]. % ( H1 == [], % functor(CurrentHead,CF,CA), % check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) -> % L = T % ; % gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators), % universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId), % flatten(VarsAndSuspsList,VarsAndSusps), % Vars = [ [] | VarsAndSusps], % build_head(F,A,Id,Vars,Head), % build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall), % Clause = ( Head :- PredecessorCall), % L = [Clause | T] % ). % skips back intelligently over global_singleton lookups universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :- ( Id = [0|_] -> next_id(Id,PrevId), PrevVarsAndSusps = BaseCallArgs ; VarsAndSuspsList = [_|AllButFirstList], dec_id(Id,PrevId1), ( PrevHeads = [PrevHead|PrevHeads1], functor(PrevHead,F,A), check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) -> PrevIterators = [_|PrevIterators1], universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId) ; PrevId = PrevId1, flatten(AllButFirstList,AllButFirst), PrevIterators = [PrevIterator|_], PrevVarsAndSusps = [PrevIterator|AllButFirst] ) ). universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :- Rule = rule(_,_,Guard,Body), gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators), init(AllSusps,PreSusps), flatten(PreVarsAndSuspsList,PreVarsAndSusps), gen_var(OtherSusps), functor(CurrentHead,OtherF,OtherA), gen_vars(OtherA,OtherVars), head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs), get_constraint_mode(OtherF/OtherA,Mode), head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1), delay_phase_end(validate_store_type_assumptions, ( static_suspension_term(OtherF/OtherA,OtherSuspension), get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState), get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars) ) ), different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals), % create_get_mutable_ref(active,State,GetMutable), CurrentSuspTest = ( OtherSusp = OtherSuspension, GetState, DiffSuspGoals, FirstMatching ), add_heads_ground_variables([CurrentHead|PreHeads],[],GroundVars), lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,GroundVars,NextSuspGoal,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), ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) -> % iterator (OtherSusps) is empty at runtime universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId), RecursiveVars = PreVarsAndSusps1 ; RecursiveVars = [OtherSusps|PreVarsAndSusps], PrevId = Id ), build_head(F,A,PrevId,RecursiveVars,RecursiveHead), Clause = ( ClauseHead :- ( CurrentSuspTest, NextSuspGoal -> NestedHead ; RecursiveHead ) ), add_dummy_location(Clause,LocatedClause), L = [LocatedClause|T]. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Observation Analysis % % CLASSIFICATION % Enabled % % Analysis based on Abstract Interpretation paper. % % TODO: % stronger analysis domain [research] :- chr_constraint initial_call_pattern/1, call_pattern/1, call_pattern_worker/1, final_answer_pattern/2, abstract_constraints/1, depends_on/2, depends_on_ap/4, depends_on_goal/2, ai_observed_internal/2, % ai_observed/2, ai_not_observed_internal/2, ai_not_observed/2, ai_is_observed/2, depends_on_as/3, ai_observation_gather_results/0. :- chr_type abstract_domain ---> odom(program_point,list(constraint)). :- chr_type program_point == any. :- chr_option(mode,initial_call_pattern(+)). :- chr_option(type_declaration,call_pattern(abstract_domain)). :- chr_option(mode,call_pattern(+)). :- chr_option(type_declaration,call_pattern(abstract_domain)). :- chr_option(mode,call_pattern_worker(+)). :- chr_option(type_declaration,call_pattern_worker(abstract_domain)). :- chr_option(mode,final_answer_pattern(+,+)). :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)). :- chr_option(mode,abstract_constraints(+)). :- chr_option(type_declaration,abstract_constraints(list)). :- chr_option(mode,depends_on(+,+)). :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)). :- chr_option(mode,depends_on_as(+,+,+)). :- chr_option(mode,depends_on_ap(+,+,+,+)). :- chr_option(mode,depends_on_goal(+,+)). :- chr_option(mode,ai_is_observed(+,+)). :- chr_option(mode,ai_not_observed(+,+)). % :- chr_option(mode,ai_observed(+,+)). :- chr_option(mode,ai_not_observed_internal(+,+)). :- chr_option(mode,ai_observed_internal(+,+)). abstract_constraints_fd @ abstract_constraints(_) \ abstract_constraints(_) <=> true. ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true. ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true. ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true. ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail. ai_is_observed(_,_) <=> true. ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O). ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O). ai_observation_gather_results <=> true. %------------------------------------------------------------------------------% % Main Analysis Entry %------------------------------------------------------------------------------% ai_observation_analysis(ACs) :- ( chr_pp_flag(ai_observation_analysis,on), get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment -> list_to_ord_set(ACs,ACSet), abstract_constraints(ACSet), ai_observation_schedule_initial_calls(ACSet,ACSet), ai_observation_gather_results ; true ). ai_observation_schedule_initial_calls([],_). ai_observation_schedule_initial_calls([AC|RACs],ACs) :- ai_observation_schedule_initial_call(AC,ACs), ai_observation_schedule_initial_calls(RACs,ACs). ai_observation_schedule_initial_call(AC,ACs) :- ai_observation_top(AC,CallPattern), % ai_observation_bot(AC,ACs,CallPattern), initial_call_pattern(CallPattern). ai_observation_schedule_new_calls([],AP). ai_observation_schedule_new_calls([AC|ACs],AP) :- AP = odom(_,Set), initial_call_pattern(odom(AC,Set)), ai_observation_schedule_new_calls(ACs,AP). final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2) <=> ai_observation_leq(AP2,AP1) | true. initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true. initial_call_pattern(CP) ==> call_pattern(CP). initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3 ==> ai_observation_schedule_new_calls(ACs,AP) pragma passive(ID3). call_pattern(CP) \ call_pattern(CP) <=> true. depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==> final_answer_pattern(CP1,AP). %call_pattern(CP) ==> writeln(call_pattern(CP)). call_pattern(CP) ==> call_pattern_worker(CP). %------------------------------------------------------------------------------% % Abstract Goal %------------------------------------------------------------------------------% % AbstractGoala %call_pattern(odom([],Set)) ==> % final_answer_pattern(odom([],Set),odom([],Set)). call_pattern_worker(odom([],Set)) <=> % writeln(' - AbstractGoal'(odom([],Set))), final_answer_pattern(odom([],Set),odom([],Set)). % AbstractGoalb call_pattern_worker(odom([G|Gs],Set)) <=> % writeln(' - AbstractGoal'(odom([G|Gs],Set))), CP1 = odom(G,Set), depends_on_goal(odom([G|Gs],Set),CP1), call_pattern(CP1). depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID <=> true pragma passive(ID). depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) ==> CP1 = odom([_|Gs],_), AP2 = odom([],Set), CCP = odom(Gs,Set), call_pattern(CCP), depends_on(CP1,CCP). %------------------------------------------------------------------------------% % Abstract Disjunction %------------------------------------------------------------------------------% call_pattern_worker(odom((AG1;AG2),Set)) <=> CP = odom((AG1;AG2),Set), InitialAnswerApproximation = odom([],Set), final_answer_pattern(CP,InitialAnswerApproximation), CP1 = odom(AG1,Set), CP2 = odom(AG2,Set), call_pattern(CP1), call_pattern(CP2), depends_on_as(CP,CP1,CP2). %------------------------------------------------------------------------------% % Abstract Solve %------------------------------------------------------------------------------% call_pattern_worker(odom(builtin,Set)) <=> % writeln(' - AbstractSolve'(odom(builtin,Set))), ord_empty(EmptySet), final_answer_pattern(odom(builtin,Set),odom([],EmptySet)). %------------------------------------------------------------------------------% % Abstract Drop %------------------------------------------------------------------------------% max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) <=> O > MO | % writeln(' - AbstractDrop'(odom(occ(C,O),Set))), final_answer_pattern(odom(occ(C,O),Set),odom([],Set)) pragma passive(ID2). %------------------------------------------------------------------------------% % Abstract Activate %------------------------------------------------------------------------------% call_pattern_worker(odom(AC,Set)) <=> AC = _ / _ | % writeln(' - AbstractActivate'(odom(AC,Set))), CP = odom(occ(AC,1),Set), call_pattern(CP), depends_on(odom(AC,Set),CP). %------------------------------------------------------------------------------% % Abstract Passive %------------------------------------------------------------------------------% occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) <=> is_passive(RuleNb,ID) | % writeln(' - AbstractPassive'(odom(occ(C,O),Set))), % DEFAULT NO is O + 1, DCP = odom(occ(C,NO),Set), call_pattern(DCP), final_answer_pattern(odom(occ(C,O),Set),odom([],Set)), depends_on(odom(occ(C,O),Set),DCP) pragma passive(ID2). %------------------------------------------------------------------------------% % Abstract Simplify %------------------------------------------------------------------------------% % AbstractSimplify occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) <=> \+ is_passive(RuleNb,ID) | % writeln(' - AbstractPassive'(odom(occ(C,O),Set))), ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads), ai_observation_observe_set(Set,AbstractRestHeads,Set2), ai_observation_memo_abstract_goal(RuleNb,AG), call_pattern(odom(AG,Set2)), % DEFAULT NO is O + 1, DCP = odom(occ(C,NO),Set), call_pattern(DCP), depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP), % DEADLOCK AVOIDANCE final_answer_pattern(odom(occ(C,O),Set),odom([],Set)) pragma passive(ID2). depends_on_as(CP,CPS,CPD), final_answer_pattern(CPS,APS), final_answer_pattern(CPD,APD) ==> ai_observation_lub(APS,APD,AP), final_answer_pattern(CP,AP). :- chr_constraint ai_observation_memo_simplification_rest_heads/3, ai_observation_memoed_simplification_rest_heads/3. :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)). :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)). ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH) <=> QRH = RH. abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH) <=> Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_), once(select2(ID,_,IDs1,H1,_,RestH1)), ai_observation_abstract_constraints(RestH1,ACs,ARestHeads), ai_observation_abstract_constraints(H2,ACs,AH2), append(ARestHeads,AH2,AbstractHeads), sort(AbstractHeads,QRH), ai_observation_memoed_simplification_rest_heads(C,O,QRH) pragma passive(ID1), passive(ID2), passive(ID3). ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail. %------------------------------------------------------------------------------% % Abstract Propagate %------------------------------------------------------------------------------% % AbstractPropagate occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) <=> \+ is_passive(RuleNb,ID) | % writeln(' - AbstractPropagate'(odom(occ(C,O),Set))), % observe partners ai_observation_memo_propagation_rest_heads(C,O,AHs), ai_observation_observe_set(Set,AHs,Set2), ord_add_element(Set2,C,Set3), ai_observation_memo_abstract_goal(RuleNb,AG), call_pattern(odom(AG,Set3)), ( ord_memberchk(C,Set2) -> Delete = no ; Delete = yes ), % DEFAULT NO is O + 1, DCP = odom(occ(C,NO),Set), call_pattern(DCP), depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete) pragma passive(ID2). :- chr_constraint ai_observation_memo_propagation_rest_heads/3, ai_observation_memoed_propagation_rest_heads/3. :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)). :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)). ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH) <=> QRH = RH. abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH) <=> Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_), once(select2(ID,_,IDs2,H2,_,RestH2)), ai_observation_abstract_constraints(RestH2,ACs,ARestHeads), ai_observation_abstract_constraints(H1,ACs,AH1), append(ARestHeads,AH1,AbstractHeads), sort(AbstractHeads,QRH), ai_observation_memoed_propagation_rest_heads(C,O,QRH) pragma passive(ID1), passive(ID2), passive(ID3). ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail. depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==> final_answer_pattern(CP,APD). depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP), final_answer_pattern(CPD,APD) ==> true | CP = odom(occ(C,O),_), ( ai_observation_is_observed(APP,C) -> ai_observed_internal(C,O) ; ai_not_observed_internal(C,O) ), ( Delete == yes -> APP = odom([],Set0), ord_del_element(Set0,C,Set), NAPP = odom([],Set) ; NAPP = APP ), ai_observation_lub(NAPP,APD,AP), final_answer_pattern(CP,AP). %------------------------------------------------------------------------------% % Catch All %------------------------------------------------------------------------------% call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]). %------------------------------------------------------------------------------% % Auxiliary Predicates %------------------------------------------------------------------------------% ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :- ord_intersection(S1,S2,S3). ai_observation_bot(AG,AS,odom(AG,AS)). ai_observation_top(AG,odom(AG,EmptyS)) :- ord_empty(EmptyS). ai_observation_leq(odom(AG,S1),odom(AG,S2)) :- ord_subset(S2,S1). ai_observation_observe_set(S,ACSet,NS) :- ord_subtract(S,ACSet,NS). ai_observation_abstract_constraint(C,ACs,AC) :- functor(C,F,A), AC = F/A, memberchk(AC,ACs). ai_observation_abstract_constraints(Cs,ACs,NACs) :- findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs). %------------------------------------------------------------------------------% % Abstraction of Rule Bodies %------------------------------------------------------------------------------% :- chr_constraint ai_observation_memoed_abstract_goal/2, ai_observation_memo_abstract_goal/2. :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)). :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)). ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG) <=> QAG = AG pragma passive(ID1). rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG) <=> Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_), ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG), QAG = AG, ai_observation_memoed_abstract_goal(RuleNb,AG) pragma passive(ID1), passive(ID2). ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :- % also guard: e.g. b, c(X) ==> Y=X | p(Y). term_variables((H1,H2,Guard),HVars), append(H1,H2,Heads), % variables that are declared to be ground are safe, ground_vars(Heads,GroundVars), % so we remove them from the list of 'dangerous' head variables list_difference_eq(HVars,GroundVars,HV), ai_observation_abstract_goal(G,ACs,AG,[],HV),!. % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)). % HV are 'dangerous' variables, all others are fresh and safe ground_vars([],[]). ground_vars([H|Hs],GroundVars) :- functor(H,F,A), get_constraint_mode(F/A,Mode), head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs), head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1), ground_vars(Hs,GroundVars2), append(GroundVars1,GroundVars2,GroundVars). ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !, % conjunction ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV), ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV). ai_observation_abstract_goal((G1;G2),ACs,[(ABranch1;ABranch2)|Tail],Tail,HV) :- !, % disjunction ai_observation_abstract_goal(G1,ACs,ABranch1,[],HV), ai_observation_abstract_goal(G2,ACs,ABranch2,[],HV). ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !, % if-then ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV), ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV). ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :- ai_observation_abstract_constraint(C,ACs,AC), !. % CHR constraint ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !. ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !. % non-CHR constraint is safe if it only binds fresh variables ai_observation_abstract_goal(G,_,Tail,Tail,HV) :- builtin_binds_b(G,Vars), intersect_eq(Vars,HV,[]), !. ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :- AG = builtin. % default case if goal is not recognized/safe ai_observation_is_observed(odom(_,ACSet),AC) :- \+ ord_memberchk(AC,ACSet). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% unconditional_occurrence(C,O) :- get_occurrence(C,O,RuleNb,ID), get_rule(RuleNb,PRule), PRule = pragma(ORule,_,_,_,_), copy_term_nat(ORule,Rule), Rule = rule(H1,H2,Guard,_), % writeq(guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard)),nl, guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard), once(( H1 = [Head], H2 == [] ; H2 = [Head], H1 == [], \+ may_trigger(C) )), functor(Head,F,A), Head =.. [_|Args], unconditional_occurrence_args(Args). unconditional_occurrence_args([]). unconditional_occurrence_args([X|Xs]) :- var(X), X = x, unconditional_occurrence_args(Xs). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ % Partial wake analysis % % In a Var = Var unification do not wake up constraints of both variables, % but rather only those of one variable. %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ :- chr_constraint partial_wake_analysis/0. :- chr_constraint no_partial_wake/1. :- chr_option(mode,no_partial_wake(+)). :- chr_constraint wakes_partially/1. :- chr_option(mode,wakes_partially(+)). partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type), rule(RuleNb,Rule), constraint_mode(FA,ArgModes) ==> Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_), ( is_passive(RuleNb,ID) -> true ; Type == simplification -> select(H,H1,RestH1), H =.. [_|Args], term_variables(Guard,Vars), partial_wake_args(Args,ArgModes,Vars,FA) ; % Type == propagation -> select(H,H2,RestH2), H =.. [_|Args], term_variables(Guard,Vars), partial_wake_args(Args,ArgModes,Vars,FA) ). partial_wake_args([],_,_,_). partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :- ( Mode \== (+) -> ( nonvar(Arg) -> no_partial_wake(C) ; memberchk_eq(Arg,Vars) -> no_partial_wake(C) ; true ) ; true ), partial_wake_args(Args,Modes,Vars,C). no_partial_wake(C) \ no_partial_wake(C) <=> true. no_partial_wake(C) \ wakes_partially(C) <=> fail. wakes_partially(C) <=> true. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Generate rules that implement chr_show_store/1 functionality. % % CLASSIFICATION % Experimental % Unused % % Generates additional rules: % % $show, C1 # ID ==> writeln(C1) pragma passive(ID). % ... % $show, Cn # ID ==> writeln(Cn) pragma passive(ID). % $show <=> true. generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :- ( chr_pp_flag(show,on) -> Constraints = ['$show'/0|Constraints0], generate_show_rules(Constraints0,Rules,[Rule|Rules0]), inc_rule_count(RuleNb), Rule = pragma( rule(['$show'],[],true,true), ids([0],[]), [], no, RuleNb ) ; Constraints = Constraints0, Rules = Rules0 ). generate_show_rules([],Rules,Rules). generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :- functor(C,F,A), inc_rule_count(RuleNb), Rule = pragma( rule([],['$show',C],true,writeln(C)), ids([],[0,1]), [passive(1)], no, RuleNb ), generate_show_rules(Rest,Tail,Rules). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % Custom supension term layout static_suspension_term(F/A,Suspension) :- suspension_term_base(F/A,Base), Arity is Base + A, functor(Suspension,suspension,Arity). has_suspension_field(FA,Field) :- suspension_term_base_fields(FA,Fields), memberchk(Field,Fields). suspension_term_base(FA,Base) :- suspension_term_base_fields(FA,Fields), length(Fields,Base). suspension_term_base_fields(FA,Fields) :- ( chr_pp_flag(debugable,on) -> % 1. ID % 2. State % 3. Propagation History % 4. Generation Number % 5. Continuation Goal % 6. Functor Fields = [id,state,history,generation,continuation,functor] ; ( uses_history(FA) -> Fields = [id,state,history|Fields2] ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) -> Fields = [state|Fields2] ; Fields = [id,state|Fields2] ), ( only_ground_indexed_arguments(FA) -> get_store_type(FA,StoreType), basic_store_types(StoreType,BasicStoreTypes), ( memberchk(global_ground,BasicStoreTypes) -> % 1. ID % 2. State % 3. Propagation History % 4. Global List Prev Fields2 = [global_list_prev|Fields3] ; % 1. ID % 2. State % 3. Propagation History Fields2 = Fields3 ), ( chr_pp_flag(ht_removal,on) -> ht_prev_fields(BasicStoreTypes,Fields3) ; Fields3 = [] ) ; may_trigger(FA) -> % 1. ID % 2. State % 3. Propagation History ( uses_field(FA,generation) -> % 4. Generation Number % 5. Global List Prev Fields2 = [generation,global_list_prev|Fields3] ; Fields2 = [global_list_prev|Fields3] ), ( chr_pp_flag(mixed_stores,on), chr_pp_flag(ht_removal,on) -> get_store_type(FA,StoreType), basic_store_types(StoreType,BasicStoreTypes), ht_prev_fields(BasicStoreTypes,Fields3) ; Fields3 = [] ) ; % 1. ID % 2. State % 3. Propagation History % 4. Global List Prev Fields2 = [global_list_prev|Fields3], ( chr_pp_flag(mixed_stores,on), chr_pp_flag(ht_removal,on) -> get_store_type(FA,StoreType), basic_store_types(StoreType,BasicStoreTypes), ht_prev_fields(BasicStoreTypes,Fields3) ; Fields3 = [] ) ) ). ht_prev_fields(Stores,Prevs) :- ht_prev_fields_int(Stores,PrevsList), append(PrevsList,Prevs). ht_prev_fields_int([],[]). ht_prev_fields_int([H|T],Fields) :- ( H = multi_hash(Indexes) -> maplist(ht_prev_field,Indexes,FH), Fields = [FH|FT] ; Fields = FT ), ht_prev_fields_int(T,FT). ht_prev_field(Index,Field) :- ( integer(Index) -> atom_concat('multi_hash_prev-',Index,Field) ; Index = [_|_] -> concat_atom(['multi_hash_prev-'|Index],Field) ). get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :- suspension_term_base_fields(FA,Fields), nth(Index,Fields,FieldName), !, arg(Index,StaticSuspension,Field). get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !, suspension_term_base(FA,Base), StaticSuspension =.. [_|Args], drop(Base,Args,Field). get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :- chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]). get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :- suspension_term_base_fields(FA,Fields), nth(Index,Fields,FieldName), !, Goal = arg(Index,DynamicSuspension,Field). get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !, static_suspension_term(FA,StaticSuspension), get_static_suspension_term_field(arguments,FA,StaticSuspension,Field), Goal = (DynamicSuspension = StaticSuspension). get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !, suspension_term_base(FA,Base), Index is I + Base, Goal = arg(Index,DynamicSuspension,Field). get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :- chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]). set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :- suspension_term_base_fields(FA,Fields), nth(Index,Fields,FieldName), !, Goal = setarg(Index,DynamicSuspension,Field). set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :- chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]). basic_store_types(multi_store(Types),Types) :- !. basic_store_types(Type,[Type]). %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % :- chr_constraint phase_end/1, delay_phase_end/2. :- chr_option(mode,phase_end(+)). :- chr_option(mode,delay_phase_end(+,?)). phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal). % phase_end(Phase) <=> true. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% :- chr_constraint does_use_history/2, uses_history/1, novel_production_call/4. :- chr_option(mode,uses_history(+)). :- chr_option(mode,does_use_history(+,+)). :- chr_option(mode,novel_production_call(+,+,?,?)). does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true. does_use_history(FA,_) \ uses_history(FA) <=> true. uses_history(_FA) <=> fail. does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal. novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true. :- chr_constraint does_use_field/2, uses_field/2. :- chr_option(mode,uses_field(+,+)). :- chr_option(mode,does_use_field(+,+)). does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true. does_use_field(FA,Field) \ uses_field(FA,Field) <=> true. uses_field(_FA,_Field) <=> fail. :- chr_constraint uses_state/2, if_used_state/5, used_states_known/0. :- chr_option(mode,uses_state(+,+)). :- chr_option(mode,if_used_state(+,+,?,?,?)). % states ::= not_stored_yet | passive | active | triggered | removed % % allocate CREATES not_stored_yet % remove CHECKS not_stored_yet % activate CHECKS not_stored_yet % % ==> no allocate THEN no not_stored_yet % recurs CREATES inactive % lookup CHECKS inactive % insert CREATES active % activate CREATES active % lookup CHECKS active % recurs CHECKS active % runsusp CREATES triggered % lookup CHECKS triggered % % ==> no runsusp THEN no triggered % remove CREATES removed % runsusp CHECKS removed % lookup CHECKS removed % recurs CHECKS removed % % ==> no remove THEN no removed % ==> no allocate, no remove, no active/inactive distinction THEN no state at all... uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true. used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal) <=> ResultGoal = Used. used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal) <=> ResultGoal = NotUsed.