* Fix paths to runtex
[chr.git] / chr_translate.chr
blob69ca03ebccc8793a0e7d3b5ab8ee791bf1eb9cc7
1 /*  $Id$
3     Part of CHR (Constraint Handling Rules)
5     Author:        Tom Schrijvers
6     E-mail:        Tom.Schrijvers@cs.kuleuven.be
7     WWW:           http://www.swi-prolog.org
8     Copyright (C): 2003-2004, K.U. Leuven
10     This program is free software; you can redistribute it and/or
11     modify it under the terms of the GNU General Public License
12     as published by the Free Software Foundation; either version 2
13     of the License, or (at your option) any later version.
15     This program is distributed in the hope that it will be useful,
16     but WITHOUT ANY WARRANTY; without even the implied warranty of
17     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18     GNU General Public License for more details.
20     You should have received a copy of the GNU Lesser General Public
21     License along with this library; if not, write to the Free Software
22     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
24     As a special exception, if you link this library with other files,
25     compiled with a Free Software compiler, to produce an executable, this
26     library does not by itself cause the resulting executable to be covered
27     by the GNU General Public License. This exception does not however
28     invalidate any other reasons why the executable file might be covered by
29     the GNU General Public License.
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
34 %%   ____ _   _ ____     ____                      _ _
35 %%  / ___| | | |  _ \   / ___|___  _ __ ___  _ __ (_) | ___ _ __
36 %% | |   | |_| | |_) | | |   / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___|  _  |  _ <  | |__| (_) | | | | | | |_) | | |  __/ |
38 %%  \____|_| |_|_| \_\  \____\___/|_| |_| |_| .__/|_|_|\___|_|
39 %%                                          |_|
41 %% hProlog CHR compiler:
43 %%      * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
45 %%      * based on the SICStus CHR compilation by Christian Holzbaur
47 %% First working version: 6 June 2003
48 %% 
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
51 %% URGENTLY TODO
53 %%      * add groundness info to a.i.-based observation analysis
54 %%      * proper fd/index analysis
55 %%      * re-add generation checking
56 %%      * untangle CHR-level and traget source-level generation & optimization
57 %%      
58 %% AGGRESSIVE OPTIMISATION IDEAS
60 %%      * success continuation optimization
61 %%      * analyze history usage to determine whether/when 
62 %%        cheaper suspension is possible:
63 %%              don't use history when all partners are passive and self never triggers         
64 %%      * store constraint unconditionally for unconditional propagation rule,
65 %%        if first, i.e. without checking history and set trigger cont to next occ
66 %%      * get rid of suspension passing for never triggered constraints,
67 %%         up to allocation occurrence
68 %%      * get rid of call indirection for never triggered constraints
69 %%        up to first allocation occurrence.
70 %%      * get rid of unnecessary indirection if last active occurrence
71 %%        before unconditional removal is head2, e.g.
72 %%              a \ b <=> true.
73 %%              a <=> true.
74 %%      * Eliminate last clause of never stored constraint, if its body
75 %%        is fail.
76 %%      * Specialize lookup operations and indexes for functional dependencies.
78 %% MORE TODO
80 %%      * generate code to empty all constraint stores of a module (Bart Demoen)
81 %%      * map A \ B <=> true | true rules
82 %%        onto efficient code that empties the constraint stores of B
83 %%        in O(1) time for ground constraints where A and B do not share
84 %%        any variables
85 %%      * ground matching seems to be not optimized for compound terms
86 %%        in case of simpagation_head2 and propagation occurrences
87 %%      * Do not unnecessarily generate store operations.
88 %%      * analysis for storage delaying (see primes for case)
89 %%      * internal constraints declaration + analyses?
90 %%      * Do not store in global variable store if not necessary
91 %%              NOTE: affects show_store/1
92 %%      * multi-level store: variable - ground
93 %%      * Do not maintain/check unnecessary propagation history
94 %%              for reasons of anti-monotony 
95 %%      * Strengthen storage analysis for propagation rules
96 %%              reason about bodies of rules only containing constraints
97 %%              -> fixpoint with observation analysis
98 %%      * instantiation declarations
99 %%              VARIABLE (never bound) (-)
100 %%                      specialize via_1 and others to a compile time unification
101 %%              COMPOUND (bound to nonvar)
102 %%                      avoid nonvar tests
103 %%                      
104 %%      * make difference between cheap guards          for reordering
105 %%                            and non-binding guards    for lock removal
106 %%      * unqiue -> once/[] transformation for propagation
107 %%      * cheap guards interleaved with head retrieval + faster
108 %%        via-retrieval + non-empty checking for propagation rules
109 %%        redo for simpagation_head2 prelude
110 %%      * intelligent backtracking for simplification/simpagation rule
111 %%              generator_1(X),'_$savecp'(CP_1),
112 %%              ... 
113 %%              if( (
114 %%                      generator_n(Y), 
115 %%                      test(X,Y)
116 %%                  ),
117 %%                  true,
118 %%                  ('_$cutto'(CP_1), fail)
119 %%              ),
120 %%              ...
122 %%        or recently developped cascading-supported approach 
123 %%      * intelligent backtracking for propagation rule
124 %%          use additional boolean argument for each possible smart backtracking
125 %%          when boolean at end of list true  -> no smart backtracking
126 %%                                      false -> smart backtracking
127 %%          only works for rules with at least 3 constraints in the head
128 %%      * (set semantics + functional dependency) declaration + resolution
131 %%      * identify cases where prefixes of partner lookups for subsequent occurrences can be
132 %%        merged
134 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
135 :- module(chr_translate,
136           [ chr_translate/2             % +Decls, -TranslatedDecls
137           ]).
138 %% SWI begin
139 :- use_module(library(lists),[member/2, append/3,reverse/2,permutation/2,last/2]).
140 :- use_module(library(ordsets)).
141 %% SWI end
143 :- use_module(hprolog).
144 :- use_module(pairlist).
145 :- use_module(a_star).
146 :- use_module(listmap).
147 :- use_module(clean_code).
148 :- use_module(builtins).
149 :- use_module(find).
150 :- use_module(guard_entailment).
151 :- use_module(chr_compiler_options).
152 :- use_module(chr_compiler_utility).
153 :- use_module(chr_compiler_errors).
154 :- include(chr_op).
155 :- op(1150, fx, chr_type).
156 :- op(1130, xfx, --->).
157 :- op(980, fx, (+)).
158 :- op(980, fx, (-)).
159 :- op(980, fx, (?)).
160 :- op(1150, fx, constraints).
161 :- op(1150, fx, chr_constraint).
163 :- chr_option(debug,off).
164 :- chr_option(optimize,full).
166 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
167 :- chr_constraint 
168         target_module/1,                        % target_module(Module)
169         get_target_module/1,
171         indexed_argument/2,                     % argument instantiation may enable applicability of rule
172         is_indexed_argument/2,
174         constraint_mode/2,
175         get_constraint_mode/2,
177         may_trigger/1,
178         only_ground_indexed_arguments/1,
179         none_suspended_on_variables/0,
180         are_none_suspended_on_variables/0,
181         
182         store_type/2,
183         get_store_type/2,
184         update_store_type/2,
185         actual_store_types/2,
186         assumed_store_type/2,
187         validate_store_type_assumption/1,
189         rule_count/1,
190         inc_rule_count/1,
192         passive/2,
193         is_passive/2,
194         any_passive_head/1,
196         new_occurrence/4,
197         occurrence/5,
198         get_occurrence/4,
199         get_occurrence_from_id/4,
201         max_occurrence/2,
202         get_max_occurrence/2,
204         allocation_occurrence/2,
205         get_allocation_occurrence/2,
206         rule/2,
207         get_rule/2,
208         least_occurrence/2,
209         is_least_occurrence/1
210         . 
212 :- chr_option(check_guard_bindings,off).
214 :- chr_option(mode,target_module(+)).
215 :- chr_option(mode,indexed_argument(+,+)).
216 :- chr_option(mode,constraint_mode(+,+)).
217 :- chr_option(mode,may_trigger(+)).
218 :- chr_option(mode,store_type(+,+)).
219 :- chr_option(mode,actual_store_types(+,+)).
220 :- chr_option(mode,assumed_store_type(+,+)).
221 :- chr_option(mode,rule_count(+)).
222 :- chr_option(mode,passive(+,+)).
223 :- chr_option(mode,occurrence(+,+,+,+,+)).
224 :- chr_option(mode,max_occurrence(+,+)).
225 :- chr_option(mode,allocation_occurrence(+,+)).
226 :- chr_option(mode,rule(+,+)).
227 :- chr_option(mode,least_occurrence(+,+)).
228 :- chr_option(mode,is_least_occurrence(+)).
230 :- chr_option(type_definition,type(list,[ [], [any|list] ])).
231 :- chr_option(type_definition,type(constraint,[ any / any ])).
233 :- chr_option(type_declaration,constraint_mode(constraint,list)).
235 target_module(_) \ target_module(_) <=> true.
236 target_module(Mod) \ get_target_module(Query)
237         <=> Query = Mod .
238 get_target_module(Query)
239         <=> Query = user.
241 indexed_argument(FA,I) \ indexed_argument(FA,I) <=> true.
242 indexed_argument(FA,I) \ is_indexed_argument(FA,I) <=> true.
243 is_indexed_argument(_,_) <=> fail.
245 %%% C O N S T R A I N T   M O D E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
247 constraint_mode(FA,_) \ constraint_mode(FA,_) <=> true.
248 constraint_mode(FA,Mode) \ get_constraint_mode(FA,Q) <=>
249         Q = Mode.
250 get_constraint_mode(FA,Q) <=>
251         FA = _ / N,
252         replicate(N,(?),Q).
254 %%% M A Y   T R I G G E R %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
256 may_trigger(FA) <=> \+ has_active_occurrence(FA) | fail.
257 constraint_mode(FA,Mode), indexed_argument(FA,I) \ may_trigger(FA) <=> 
258   nth1(I,Mode,M),
259   M \== (+) |
260   is_stored(FA). 
261 may_trigger(FA) <=> chr_pp_flag(debugable,on).  % in debug mode, we assume everything can be triggered
263 constraint_mode(FA,Mode), indexed_argument(FA,I) \ only_ground_indexed_arguments(FA)
264         <=>
265                 nth1(I,Mode,M),
266                 M \== (+)
267         |
268                 fail.
269 only_ground_indexed_arguments(_) <=>
270         true.
272 none_suspended_on_variables \ none_suspended_on_variables <=> true.
273 none_suspended_on_variables \ are_none_suspended_on_variables <=> true.
274 are_none_suspended_on_variables <=> fail.
275 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
277 store_type(FA,atom_hash(Index)) <=> store_type(FA,multi_hash([Index])).
278 store_type(FA,Store) \ get_store_type(FA,Query)
279         <=> Query = Store.
280 assumed_store_type(FA,Store) \ get_store_type(FA,Query)
281         <=> Query = Store.
282 get_store_type(_,Query) 
283         <=> Query = default.
285 actual_store_types(C,STs) \ update_store_type(C,ST)
286         <=> member(ST,STs) | true.
287 update_store_type(C,ST), actual_store_types(C,STs)
288         <=> 
289                 actual_store_types(C,[ST|STs]).
290 update_store_type(C,ST)
291         <=> 
292                 actual_store_types(C,[ST]).
294 % refine store type assumption
295 validate_store_type_assumption(C), actual_store_types(C,STs), assumed_store_type(C,_)   % automatic assumption
296         <=> 
297                 store_type(C,multi_store(STs)).
298 validate_store_type_assumption(C), actual_store_types(C,STs), store_type(C,_)           % user assumption
299         <=> 
300                 store_type(C,multi_store(STs)).
301 validate_store_type_assumption(C), assumed_store_type(C,_)                              % no lookups on constraint in debug mode
302         <=>     
303                 chr_pp_flag(debugable,on)
304         |
305                 store_type(C,default).
306 validate_store_type_assumption(C), assumed_store_type(C,_)                              % no lookups on constraint
307         <=> store_type(C,global_ground).
308 validate_store_type_assumption(C) 
309         <=> true.
311 rule_count(C), inc_rule_count(NC)
312         <=> NC is C + 1, rule_count(NC).
313 inc_rule_count(NC)
314         <=> NC = 1, rule_count(NC).
316 %%% P A S S I V E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
317 passive(R,ID) \ passive(R,ID) <=> true.
319 passive(RuleNb,ID) \ is_passive(RuleNb,ID) <=> true.
320 is_passive(_,_) <=> fail.
322 passive(RuleNb,_) \ any_passive_head(RuleNb)
323         <=> true.
324 any_passive_head(_)
325         <=> fail.
326 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
328 max_occurrence(C,N) \ max_occurrence(C,M)
329         <=> N >= M | true.
331 max_occurrence(C,MO), new_occurrence(C,RuleNb,ID,Type) <=>
332         NO is MO + 1, 
333         occurrence(C,NO,RuleNb,ID,Type), 
334         max_occurrence(C,NO).
335 new_occurrence(C,RuleNb,ID,_) <=>
336         chr_error(internal,'new_occurrence: missing max_occurrence for ~w in rule ~w\n',[C,RuleNb]).
338 max_occurrence(C,MON) \ get_max_occurrence(C,Q)
339         <=> Q = MON.
340 get_max_occurrence(C,Q)
341         <=> chr_error(internal,'get_max_occurrence: missing max occurrence for ~w\n',[C]).
343 occurrence(C,ON,Rule,ID,_) \ get_occurrence(C,ON,QRule,QID)
344         <=> Rule = QRule, ID = QID.
345 get_occurrence(C,O,_,_)
346         <=> chr_error(internal,'get_occurrence: missing occurrence ~w:~w\n',[C,O]).
348 occurrence(C,ON,Rule,ID,_) \ get_occurrence_from_id(C,QON,Rule,ID)
349         <=> QON = ON.
350 get_occurrence_from_id(C,O,_,_)
351         <=> chr_error(internal,'get_occurrence_from_id: missing occurrence ~w:~w\n',[]).
353 % A L L O C C A T I O N   O C C U R R E N C E %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
355         % cannot store constraint at passive occurrence
356 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ allocation_occurrence(C,O)
357         <=> NO is O + 1, allocation_occurrence(C,NO). 
358         % need not store constraint that is removed
359 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_) \ allocation_occurrence(C,O)
360         <=> Rule = pragma(_,ids(IDs1,_),_,_,_), member(ID,IDs1) 
361         | NO is O + 1, allocation_occurrence(C,NO).
362         % need not store constraint when body is true
363 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_,_) \ allocation_occurrence(C,O)
364         <=> Rule = pragma(rule(_,_,_,true),_,_,_,_)
365         | NO is O + 1, allocation_occurrence(C,NO).
366         % need not store constraint if does not observe itself
367 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_,_) \ allocation_occurrence(C,O)
368         <=> Rule = pragma(rule([_|_],_,_,_),_,_,_,_), \+ is_observed(C,O)
369         | NO is O + 1, allocation_occurrence(C,NO).
370         % need not store constraint if does not observe itself and cannot trigger
371 rule(RuleNb,Rule), occurrence(C,O,RuleNb,_,_), least_occurrence(RuleNb,[])
372         \ allocation_occurrence(C,O)
373         <=> Rule = pragma(rule([],Heads,_,_),_,_,_,_), \+ is_observed(C,O)
374         | NO is O + 1, allocation_occurrence(C,NO).
376 rule(RuleNb,Rule), occurrence(C,O,RuleNb,ID,_), allocation_occurrence(C,AO)
377         \ least_occurrence(RuleNb,[ID|IDs]) 
378         <=> AO >= O, \+ may_trigger(C) |
379         least_occurrence(RuleNb,IDs).
380 rule(RuleNb,Rule), passive(RuleNb,ID)
381         \ least_occurrence(RuleNb,[ID|IDs]) 
382         <=> least_occurrence(RuleNb,IDs).
384 rule(RuleNb,Rule)
385         ==> Rule = pragma(rule([],_,_,_),ids([],IDs),_,_,_) |
386         least_occurrence(RuleNb,IDs).
387         
388 least_occurrence(RuleNb,[]) \ is_least_occurrence(RuleNb) 
389         <=> true.
390 is_least_occurrence(_)
391         <=> fail.
392         
393 allocation_occurrence(C,O) \ get_allocation_occurrence(C,Q)
394         <=> Q = O.
395 get_allocation_occurrence(_,Q)
396         <=> chr_pp_flag(late_allocation,off), Q=0.
397 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
399 rule(RuleNb,Rule) \ get_rule(RuleNb,Q)
400         <=> Q = Rule.
401 get_rule(_,_)
402         <=> fail.
404 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
406 %%% C O N S T R A I N T   I N D E X %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
407 :- chr_constraint
408         constraint_index/2,                     % constraint_index(F/A,DefaultStoreAndAttachedIndex)
409         get_constraint_index/2,                 
410         get_indexed_constraint/2,
411         max_constraint_index/1,                 % max_constraint_index(MaxDefaultStoreAndAttachedIndex)
412         get_max_constraint_index/1.
414 :- chr_option(mode,constraint_index(+,+)).
415 :- chr_option(mode,max_constraint_index(+)).
417 constraint_index(C,Index) \ get_constraint_index(C,Query)
418         <=> Query = Index.
419 get_constraint_index(C,Query)
420         <=> fail.
422 constraint_index(C,Index) \ get_indexed_constraint(Index,Q)
423         <=> Q = C.
424 get_indexed_constraint(Index,Q)
425         <=> fail.
427 max_constraint_index(Index) \ get_max_constraint_index(Query)
428         <=> Query = Index.
429 get_max_constraint_index(Query)
430         <=> Query = 0.
432 set_constraint_indices(Constraints) :-
433         set_constraint_indices(Constraints,1).
434 set_constraint_indices([],M) :-
435         N is M - 1,
436         max_constraint_index(N).
437 set_constraint_indices([C|Cs],N) :-
438         ( ( chr_pp_flag(debugable, on) ; \+ only_ground_indexed_arguments(C), is_stored(C) ;  is_stored(C), get_store_type(C,default)
439           ; get_store_type(C,var_assoc_store(_,_))) ->
440                 constraint_index(C,N),
441                 M is N + 1,
442                 set_constraint_indices(Cs,M)
443         ;
444                 set_constraint_indices(Cs,N)
445         ).
446         
447 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
452 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
454 %% Translation
456 chr_translate(Declarations,NewDeclarations) :-
457         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',[]),
458         init_chr_pp_flags,
459         partition_clauses(Declarations,Constraints0,Rules0,OtherClauses),
460         check_declared_constraints(Constraints0),
461         generate_show_constraint(Constraints0,Constraints,Rules0,Rules),
462         add_constraints(Constraints),
463         add_rules(Rules),
464         % start analysis
465         check_rules(Rules,Constraints),
466         static_type_check,
467         add_occurrences(Rules),
468         time(fd_analysis,chr_translate:functional_dependency_analysis(Rules)),
469         time(set_semantics_rules,chr_translate:set_semantics_rules(Rules)),
470         time(symmetry_analysis,chr_translate:symmetry_analysis(Rules)),
471         time(guard_simplification,chr_translate:guard_simplification),
472         time(storage_analysis,chr_translate:storage_analysis(Constraints)),
473         time(observation_analysis,chr_translate:observation_analysis(Constraints)),
474         time(ai_observation_analysis,chr_translate:ai_observation_analysis(Constraints)),
475         time(late_allocation_analysis,chr_translate:late_allocation_analysis(Constraints)),
476         partial_wake_analysis,
477         time(assume_constraint_stores,chr_translate:assume_constraint_stores(Constraints)),
478         time(set_constraint_indices,chr_translate:set_constraint_indices(Constraints)),
479         % end analysis
480         time(constraints_code,chr_translate:constraints_code(Constraints,ConstraintClauses)),
481         time(validate_store_type_assumptions,chr_translate:validate_store_type_assumptions(Constraints)),
482         phase_end(validate_store_type_assumptions),
483         used_states_known,      
484         time(store_management_preds,chr_translate:store_management_preds(Constraints,StoreClauses)),    % depends on actual code used
485         insert_declarations(OtherClauses, Clauses0),
486         chr_module_declaration(CHRModuleDeclaration),
487         append([StoreClauses,ConstraintClauses,CHRModuleDeclaration,[end_of_file]],StuffyGeneratedClauses),
488         clean_clauses(StuffyGeneratedClauses,GeneratedClauses),
489         append([Clauses0,GeneratedClauses], NewDeclarations).
491 store_management_preds(Constraints,Clauses) :-
492                 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
493                 generate_attr_unify_hook(AttrUnifyHookClauses),
494                 generate_attach_increment(AttachIncrementClauses),
495                 generate_extra_clauses(Constraints,ExtraClauses),
496                 generate_insert_delete_constraints(Constraints,DeleteClauses),
497                 generate_attach_code(Constraints,StoreClauses),
498                 generate_counter_code(CounterClauses),
499                 generate_dynamic_type_check_clauses(TypeCheckClauses),
500                 append([AttachAConstraintClauses
501                        ,IndexedClauses
502                        ,AttachIncrementClauses
503                        ,AttrUnifyHookClauses
504                        ,ExtraClauses
505                        ,DeleteClauses
506                        ,StoreClauses
507                        ,CounterClauses
508                        ,TypeCheckClauses
509                        ]
510                       ,Clauses).
513 insert_declarations(Clauses0, Clauses) :-
514         findall(:- use_module(chr(Module)),(auxiliary_module(Module), is_used_auxiliary_module(Module)),Decls),
515         append(Clauses0, [:- use_module(chr(chr_runtime))|Decls], Clauses).
517 auxiliary_module(chr_hashtable_store).
518 auxiliary_module(chr_integertable_store).
519 auxiliary_module(chr_assoc_store).
521 generate_counter_code(Clauses) :-
522         ( chr_pp_flag(store_counter,on) ->
523                 Clauses = [
524                         ('$counter_init'(N1) :- nb_setval(N1,0)) ,
525                         ('$counter'(N2,X1) :- nb_getval(N2,X1)),
526                         ('$counter_inc'(N) :- nb_getval(N,X), Y is X + 1, nb_setval(N,Y)),
527                         (:- '$counter_init'('$insert_counter')),
528                         (:- '$counter_init'('$delete_counter')),
529                         ('$insert_counter_inc' :- '$counter_inc'('$insert_counter')),
530                         ('$delete_counter_inc' :- '$counter_inc'('$delete_counter')),
531                         ( counter_stats(I,D) :- '$counter'('$insert_counter',I),'$counter'('$delete_counter',D))
532                 ]
533         ;
534                 Clauses = []
535         ).
537 % for systems with multifile declaration
538 chr_module_declaration(CHRModuleDeclaration) :-
539         get_target_module(Mod),
540         ( Mod \== chr_translate, chr_pp_flag(toplevel_show_store,on) ->
541                 CHRModuleDeclaration = [
542                         (:- multifile chr:'$chr_module'/1),
543                         chr:'$chr_module'(Mod)  
544                 ]
545         ;
546                 CHRModuleDeclaration = []
547         ).      
550 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
552 %% Partitioning of clauses into constraint declarations, chr rules and other 
553 %% clauses
555 partition_clauses([],[],[],[]).
556 partition_clauses([C|Cs],Ds,Rs,OCs) :-
557   (   parse_rule(C,R) ->
558       Ds = RDs,
559       Rs = [R | RRs], 
560       OCs = ROCs
561   ;   is_declaration(C,D) ->
562       append(D,RDs,Ds),
563       Rs = RRs,
564       OCs = ROCs
565   ;   is_module_declaration(C,Mod) ->
566       target_module(Mod),
567       Ds = RDs,
568       Rs = RRs,
569       OCs = [C|ROCs]
570   ;   is_type_definition(C) ->
571       Ds = RDs,
572       Rs = RRs,
573       OCs = ROCs
574   ;   C = (handler _) ->
575       chr_warning(deprecated(C),'Backward compatibility: ignoring handler/1 declaration.\n',[]),
576       Ds = RDs,
577       Rs = RRs,
578       OCs = ROCs
579   ;   C = (rules _) ->
580       chr_warning(deprecated(C),'Backward compatibility: ignoring rules/1 declaration.\n',[]),
581       Ds = RDs,
582       Rs = RRs,
583       OCs = ROCs
584   ;   C = option(OptionName,OptionValue) ->
585       chr_warning(deprecated(C),'Instead use :- chr_option(~w,~w).\n',[OptionName,OptionValue]),
586       handle_option(OptionName,OptionValue),
587       Ds = RDs,
588       Rs = RRs,
589       OCs = ROCs
590   ;   C = (:- chr_option(OptionName,OptionValue)) ->
591       handle_option(OptionName,OptionValue),
592       Ds = RDs,
593       Rs = RRs,
594       OCs = ROCs
595   ;   C = ('$chr_compiled_with_version'(_)) ->
596       Ds = RDs,
597       Rs = RRs,
598       OCs = ['$chr_compiled_with_version'(3)|ROCs]
599   ;   Ds = RDs,
600       Rs = RRs,
601       OCs = [C|ROCs]
602   ),
603   partition_clauses(Cs,RDs,RRs,ROCs).
605 '$chr_compiled_with_version'(2).
607 is_declaration(D, Constraints) :-               %% constraint declaration
608         ( D = (:- Decl), Decl =.. [F,Cs], F == (chr_constraint) ->
609                 conj2list(Cs,Constraints0)
610         ;
611                 ( D = (:- Decl) ->
612                         Decl =.. [constraints,Cs]
613                 ;
614                         D =.. [constraints,Cs]
615                 ),
616                 conj2list(Cs,Constraints0),
617                 chr_warning(deprecated(D),'Instead use :- chr_constraint ~w.\n',[Cs])
618         ),
619         extract_type_mode(Constraints0,Constraints).
621 extract_type_mode([],[]).
622 extract_type_mode([F/A|R],[F/A|R2]) :- !,extract_type_mode(R,R2).
623 extract_type_mode([C|R],[C2|R2]) :- 
624         functor(C,F,A),C2=F/A,
625         C =.. [_|Args],
626         extract_types_and_modes(Args,ArgTypes,ArgModes),
627         constraint_type(F/A,ArgTypes),
628         constraint_mode(F/A,ArgModes),
629         extract_type_mode(R,R2).
631 extract_types_and_modes([],[],[]).
632 extract_types_and_modes([X|R],[T|R2],[M|R3]) :-
633         extract_type_and_mode(X,T,M),
634         extract_types_and_modes(R,R2,R3).
636 extract_type_and_mode(+(T),T,(+)) :- !.
637 extract_type_and_mode(?(T),T,(?)) :- !.
638 extract_type_and_mode(-(T),T,(-)) :- !.
639 extract_type_and_mode((+),any,(+)) :- !.
640 extract_type_and_mode((?),any,(?)) :- !.
641 extract_type_and_mode((-),any,(-)) :- !.
642 extract_type_and_mode(Illegal,_,_) :- 
643     chr_error(syntax(Illegal),'Illegal mode/type declaration.\n\tCorrect syntax is +type, -type or ?type\n\tor +, - or ?.\n',[]).
645 is_type_definition(D) :-
646   ( D = (:- TDef) ->
647         true
648   ;
649         D = TDef
650   ),
651   TDef =.. [chr_type,TypeDef],
652   ( TypeDef = (Name ---> Def) ->
653         tdisj2list(Def,DefList),
654         type_definition(Name,DefList)
655   ; TypeDef = (Alias == Name) ->
656         type_alias(Alias,Name)
657   ;
658         chr_warning(syntax,'Illegal type definition "~w".\n\tIgnoring this malformed type definition.\n',[TypeDef])
659   ).
661 % no removal of fails, e.g. :- type bool --->  true ; fail.
662 tdisj2list(Conj,L) :-
663   tdisj2list(Conj,L,[]).
664 tdisj2list(Conj,L,T) :-
665   Conj = (G1;G2), !,
666   tdisj2list(G1,L,T1),
667   tdisj2list(G2,T1,T).
668 tdisj2list(G,[G | T],T).
671 %% Data Declaration
673 %% pragma_rule 
674 %%      -> pragma(
675 %%              rule,
676 %%              ids,
677 %%              list(pragma),
678 %%              yesno(string),          :: maybe rule nane
679 %%              int                     :: rule number
680 %%              )
682 %% ids  -> ids(
683 %%              list(int),
684 %%              list(int)
685 %%              )
686 %%              
687 %% rule -> rule(
688 %%              list(constraint),       :: constraints to be removed
689 %%              list(constraint),       :: surviving constraints
690 %%              goal,                   :: guard
691 %%              goal                    :: body
692 %%              )
694 parse_rule(RI,R) :-                             %% name @ rule
695         RI = (Name @ RI2), !,
696         rule(RI2,yes(Name),R).
697 parse_rule(RI,R) :-
698         rule(RI,no,R).
700 rule(RI,Name,R) :-
701         RI = (RI2 pragma P), !,                 %% pragmas
702         ( var(P) ->
703                 Ps = [_]                        % intercept variable
704         ;
705                 conj2list(P,Ps)
706         ),
707         inc_rule_count(RuleCount),
708         R = pragma(R1,IDs,Ps,Name,RuleCount),
709         is_rule(RI2,R1,IDs,R).
710 rule(RI,Name,R) :-
711         inc_rule_count(RuleCount),
712         R = pragma(R1,IDs,[],Name,RuleCount),
713         is_rule(RI,R1,IDs,R).
715 is_rule(RI,R,IDs,RC) :-                         %% propagation rule
716    RI = (H ==> B), !,
717    conj2list(H,Head2i),
718    get_ids(Head2i,IDs2,Head2,RC),
719    IDs = ids([],IDs2),
720    (   B = (G | RB) ->
721        R = rule([],Head2,G,RB)
722    ;
723        R = rule([],Head2,true,B)
724    ).
725 is_rule(RI,R,IDs,RC) :-                         %% simplification/simpagation rule
726    RI = (H <=> B), !,
727    (   B = (G | RB) ->
728        Guard = G,
729        Body  = RB
730    ;   Guard = true,
731        Body = B
732    ),
733    (   H = (H1 \ H2) ->
734        conj2list(H1,Head2i),
735        conj2list(H2,Head1i),
736        get_ids(Head2i,IDs2,Head2,0,N,RC),
737        get_ids(Head1i,IDs1,Head1,N,_,RC),
738        IDs = ids(IDs1,IDs2)
739    ;   conj2list(H,Head1i),
740        Head2 = [],
741        get_ids(Head1i,IDs1,Head1,RC),
742        IDs = ids(IDs1,[])
743    ),
744    R = rule(Head1,Head2,Guard,Body).
746 get_ids(Cs,IDs,NCs,RC) :-
747         get_ids(Cs,IDs,NCs,0,_,RC).
749 get_ids([],[],[],N,N,_).
750 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN,RC) :-
751         ( C = (NC # N1) ->
752                 (var(N1) ->
753                         N1 = N
754                 ;
755                         check_direct_pragma(N1,N,RC)
756                 )
757         ;       
758                 NC = C
759         ),
760         M is N + 1,
761         get_ids(Cs,IDs,NCs, M,NN,RC).
763 direct_pragma(passive).
764 check_direct_pragma(passive,N,R) :- 
765         R = pragma(_,ids(IDs1,IDs2),_,_,RuleNb), passive(RuleNb,N).
766 check_direct_pragma(Abbrev,N,RC) :- 
767         (direct_pragma(X),
768          atom_concat(Abbrev,Remainder,X) ->
769             chr_warning(problem_pragma(Abbrev,RC),'completed "~w" to "~w"\n',[Abbrev,X])
770         ;
771             chr_warning(unsupported_pragma(Abbrev,RC),'',[])
772         ).
774 is_module_declaration((:- module(Mod)),Mod).
775 is_module_declaration((:- module(Mod,_)),Mod).
777 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
779 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
780 % Add constraints
781 add_constraints([]).
782 add_constraints([C|Cs]) :-
783         max_occurrence(C,0),
784         C = _/A,
785         length(Mode,A), 
786         set_elems(Mode,?),
787         constraint_mode(C,Mode),
788         add_constraints(Cs).
790 % Add rules
791 add_rules([]).
792 add_rules([Rule|Rules]) :-
793         Rule = pragma(_,_,_,_,RuleNb),
794         rule(RuleNb,Rule),
795         add_rules(Rules).
797 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
799 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
800 %% Some input verification:
802 check_declared_constraints(Constraints) :-
803         check_declared_constraints(Constraints,[]).
805 check_declared_constraints([],_).
806 check_declared_constraints([C|Cs],Acc) :-
807         ( memberchk_eq(C,Acc) ->
808                 chr_error(syntax(C),'Constraint multiply defined: ~w.\n\tRemove redundant declaration!\n',[C])
809         ;
810                 true
811         ),
812         check_declared_constraints(Cs,[C|Acc]).
814 %%  - all constraints in heads are declared constraints
815 %%  - all passive pragmas refer to actual head constraints
817 check_rules([],_).
818 check_rules([PragmaRule|Rest],Decls) :-
819         check_rule(PragmaRule,Decls),
820         check_rules(Rest,Decls).
822 check_rule(PragmaRule,Decls) :-
823         check_rule_indexing(PragmaRule),
824         check_trivial_propagation_rule(PragmaRule),
825         PragmaRule = pragma(Rule,_IDs,Pragmas,_Name,_N),
826         Rule = rule(H1,H2,_,_),
827         append(H1,H2,HeadConstraints),
828         check_head_constraints(HeadConstraints,Decls,PragmaRule),
829         check_pragmas(Pragmas,PragmaRule).
831         % Make all heads passive in trivial propagation rule
832         %       ... ==> ... | true.
833 check_trivial_propagation_rule(PragmaRule) :-
834         PragmaRule = pragma(Rule,IDs,Pragmas,Name,RuleNb),
835         ( Rule = rule([],_,_,true) ->
836                 chr_warning(weird_program,'Ignoring propagation rule with empty body: ~@.\n\t\n',[format_rule(PragmaRule)]),
837                 set_all_passive(RuleNb)
838         ;
839                 true
840         ).
842 check_head_constraints([],_,_).
843 check_head_constraints([Constr|Rest],Decls,PragmaRule) :-
844         functor(Constr,F,A),
845         ( member(F/A,Decls) ->
846                 check_head_constraints(Rest,Decls,PragmaRule)
847         ;
848                 chr_error(syntax(Constr),'Undeclared constraint ~w in head of ~@.\n\tConstraint should be one of ~w.\n', [F/A,format_rule(PragmaRule),Decls])   ).
850 check_pragmas([],_).
851 check_pragmas([Pragma|Pragmas],PragmaRule) :-
852         check_pragma(Pragma,PragmaRule),
853         check_pragmas(Pragmas,PragmaRule).
855 check_pragma(Pragma,PragmaRule) :-
856         var(Pragma), !,
857         chr_error(syntax(Pragma),'Invalid pragma ~w in ~@.\n\tPragma should not be a variable!\n',[Pragma,format_rule(PragmaRule)]).
858 check_pragma(passive(ID), PragmaRule) :-
859         !,
860         PragmaRule = pragma(_,ids(IDs1,IDs2),_,_,RuleNb),
861         ( memberchk_eq(ID,IDs1) ->
862                 true
863         ; memberchk_eq(ID,IDs2) ->
864                 true
865         ;
866                 chr_error(syntax(ID),'Invalid identifier ~w in pragma passive in ~@.\n', [ID,format_rule(PragmaRule)])
867         ),
868         passive(RuleNb,ID).
870 check_pragma(Pragma, PragmaRule) :-
871         Pragma = already_in_heads,
872         !,
873         chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
875 check_pragma(Pragma, PragmaRule) :-
876         Pragma = already_in_head(_),
877         !,
878         chr_warning(unsupported_pragma(Pragma,PragmaRule),'Termination and correctness may be affected.\n',[]).
879         
880 check_pragma(Pragma, PragmaRule) :-
881         Pragma = no_history,
882         !,
883         chr_warning(experimental,'Experimental pragma no_history. Use with care!\n',[]),
884         PragmaRule = pragma(_,_,_,_,N),
885         no_history(N).
887 check_pragma(Pragma,PragmaRule) :-
888         chr_error(syntax(Pragma),'Unknown pragma ~w in ~@.\n', [Pragma,format_rule(PragmaRule)]).
890 :- chr_constraint
891         no_history/1,
892         has_no_history/1.
894 :- chr_option(mode,no_history(+)).
896 no_history(RuleNb) \ has_no_history(RuleNb) <=> true.
897 has_no_history(_) <=> fail.
899 format_rule(PragmaRule) :-
900         PragmaRule = pragma(_,_,_,MaybeName,N),
901         ( MaybeName = yes(Name) ->
902                 write('rule '), write(Name)
903         ;
904                 write('rule number '), write(N)
905         ).
907 check_rule_indexing(PragmaRule) :-
908         PragmaRule = pragma(Rule,_,_,_,_),
909         Rule = rule(H1,H2,G,_),
910         term_variables(H1-H2,HeadVars),
911         remove_anti_monotonic_guards(G,HeadVars,NG),
912         check_indexing(H1,NG-H2),
913         check_indexing(H2,NG-H1),
914         % EXPERIMENT
915         ( chr_pp_flag(term_indexing,on) -> 
916                 term_variables(NG,GuardVariables),
917                 append(H1,H2,Heads),
918                 check_specs_indexing(Heads,GuardVariables,Specs)
919         ;
920                 true
921         ).
923 :- chr_constraint
924         indexing_spec/2,
925         get_indexing_spec/2.
927 :- chr_option(mode,indexing_spec(+,+)).
929 indexing_spec(FA,Spec) \ get_indexing_spec(FA,R) <=> R = Spec.
930 get_indexing_spec(_,Spec) <=> Spec = [].
932 indexing_spec(FA,Specs1), indexing_spec(FA,Specs2)
933         <=>
934                 append(Specs1,Specs2,Specs),
935                 indexing_spec(FA,Specs).
937 remove_anti_monotonic_guards(G,Vars,NG) :-
938         conj2list(G,GL),
939         remove_anti_monotonic_guard_list(GL,Vars,NGL),
940         list2conj(NGL,NG).
942 remove_anti_monotonic_guard_list([],_,[]).
943 remove_anti_monotonic_guard_list([G|Gs],Vars,NGs) :-
944         ( G = var(X), memberchk_eq(X,Vars) ->
945                 NGs = RGs
946 % TODO: this is not correct
947 %       ; G = functor(Term,Functor,Arity),                      % isotonic
948 %         \+ memberchk_eq(Functor,Vars), \+ memberchk_eq(Arity,Vars) ->
949 %               NGs = RGs
950         ;
951                 NGs = [G|RGs]
952         ),
953         remove_anti_monotonic_guard_list(Gs,Vars,RGs).
955 check_indexing([],_).
956 check_indexing([Head|Heads],Other) :-
957         functor(Head,F,A),
958         Head =.. [_|Args],
959         term_variables(Heads-Other,OtherVars),
960         check_indexing(Args,1,F/A,OtherVars),
961         check_indexing(Heads,[Head|Other]).     
963 check_indexing([],_,_,_).
964 check_indexing([Arg|Args],I,FA,OtherVars) :-
965         ( is_indexed_argument(FA,I) ->
966                 true
967         ; nonvar(Arg) ->
968                 indexed_argument(FA,I)
969         ; % var(Arg) ->
970                 term_variables(Args,ArgsVars),
971                 append(ArgsVars,OtherVars,RestVars),
972                 ( memberchk_eq(Arg,RestVars) ->
973                         indexed_argument(FA,I)
974                 ;
975                         true
976                 )
977         ),
978         J is I + 1,
979         term_variables(Arg,NVars),
980         append(NVars,OtherVars,NOtherVars),
981         check_indexing(Args,J,FA,NOtherVars).   
983 check_specs_indexing([],_,[]).
984 check_specs_indexing([Head|Heads],Variables,Specs) :-
985         Specs = [Spec|RSpecs],
986         term_variables(Heads,OtherVariables,Variables),
987         check_spec_indexing(Head,OtherVariables,Spec),
988         term_variables(Head,NVariables,Variables),
989         check_specs_indexing(Heads,NVariables,RSpecs).
991 check_spec_indexing(Head,OtherVariables,Spec) :-
992         functor(Head,F,A),
993         Spec = spec(F,A,ArgSpecs),
994         Head =.. [_|Args],
995         check_args_spec_indexing(Args,1,OtherVariables,ArgSpecs),
996         indexing_spec(F/A,[ArgSpecs]).
998 check_args_spec_indexing([],_,_,[]).
999 check_args_spec_indexing([Arg|Args],I,OtherVariables,ArgSpecs) :-
1000         term_variables(Args,Variables,OtherVariables),
1001         ( check_arg_spec_indexing(Arg,I,Variables,ArgSpec) ->
1002                 ArgSpecs = [ArgSpec|RArgSpecs]
1003         ;
1004                 ArgSpecs = RArgSpecs
1005         ),
1006         J is I + 1,
1007         term_variables(Arg,NOtherVariables,OtherVariables),
1008         check_args_spec_indexing(Args,J,NOtherVariables,RArgSpecs).
1010 check_arg_spec_indexing(Arg,I,Variables,ArgSpec) :-
1011         ( var(Arg) ->
1012                 memberchk_eq(Arg,Variables),
1013                 ArgSpec = specinfo(I,any,[])
1014         ;
1015                 functor(Arg,F,A),
1016                 ArgSpec = specinfo(I,F/A,[ArgSpecs]),
1017                 Arg =.. [_|Args],
1018                 check_args_spec_indexing(Args,1,Variables,ArgSpecs)
1019         ).
1021 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1023 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1024 % Occurrences
1026 add_occurrences([]).
1027 add_occurrences([Rule|Rules]) :-
1028         Rule = pragma(rule(H1,H2,_,_),ids(IDs1,IDs2),_,_,Nb),
1029         add_occurrences(H1,IDs1,simplification,Nb),
1030         add_occurrences(H2,IDs2,propagation,Nb),
1031         add_occurrences(Rules).
1033 add_occurrences([],[],_,_).
1034 add_occurrences([H|Hs],[ID|IDs],Type,RuleNb) :-
1035         functor(H,F,A),
1036         FA = F/A,
1037         new_occurrence(FA,RuleNb,ID,Type),
1038         add_occurrences(Hs,IDs,Type,RuleNb).
1040 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1042 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1043 % Observation Analysis
1045 % CLASSIFICATION
1046 %   Legacy
1048 %  - approximative: should make decision in late allocation analysis per body
1049 %  TODO:
1050 %    remove
1052 is_observed(C,O) :-
1053         is_self_observer(C),
1054         ai_is_observed(C,O).
1056 :- chr_constraint
1057         observes/2,
1058         spawns_observer/2,
1059         observes_indirectly/2,
1060         is_self_observer/1
1061         .
1063 :- chr_option(mode,observes(+,+)).
1064 :- chr_option(mode,spawns_observer(+,+)).
1065 :- chr_option(mode,observes_indirectly(+,+)).
1067 spawns_observer(C1,C2) \ spawns_observer(C1,C2) <=> true.
1068 observes(C1,C2) \ observes(C1,C2) <=> true.
1070 observes_indirectly(C1,C2) \ observes_indirectly(C1,C2) <=> true.
1072 spawns_observer(C1,C2), observes(C2,C3) ==> observes_indirectly(C1,C3).
1073 spawns_observer(C1,C2), observes_indirectly(C2,C3) ==> observes_indirectly(C1,C3).
1075 observes_indirectly(C,C) \ is_self_observer(C) <=>  true.
1076 is_self_observer(_) <=> chr_pp_flag(observation_analysis,off). 
1077         % true if analysis has not been run,
1078         % false if analysis has been run
1080 observation_analysis(Cs) :-
1081     ( chr_pp_flag(observation_analysis,on) ->
1082         observation_analysis(Cs,Cs)
1083     ;
1084         true
1085     ).
1087 observation_analysis([],_).
1088 observation_analysis([C|Cs],Constraints) :-
1089         get_max_occurrence(C,MO),
1090         observation_analysis_occurrences(C,1,MO,Constraints),
1091         observation_analysis(Cs,Constraints).
1093 observation_analysis_occurrences(C,O,MO,Cs) :-
1094         ( O > MO ->
1095                 true
1096         ;
1097                 observation_analysis_occurrence(C,O,Cs),
1098                 NO is O + 1,
1099                 observation_analysis_occurrences(C,NO,MO,Cs)
1100         ).
1102 observation_analysis_occurrence(C,O,Cs) :-
1103         get_occurrence(C,O,RuleNb,ID),
1104         ( is_passive(RuleNb,ID) ->
1105                 true
1106         ;
1107                 get_rule(RuleNb,PragmaRule),
1108                 PragmaRule = pragma(rule(Heads1,Heads2,_,Body),ids(IDs1,IDs2),_,_,_),   
1109                 ( select2(ID,_Head,IDs1,Heads1,_RIDs1,RHeads1) ->
1110                         append(RHeads1,Heads2,OtherHeads)
1111                 ; select2(ID,_Head,IDs2,Heads2,_RIDs2,RHeads2) ->
1112                         append(RHeads2,Heads1,OtherHeads)
1113                 ),
1114                 observe_heads(C,OtherHeads),
1115                 observe_body(C,Body,Cs) 
1116         ).
1118 observe_heads(C,Heads) :-
1119         findall(F/A,(member(H,Heads),functor(H,F,A)),Cs),
1120         observe_all(C,Cs).
1122 observe_all(C,Cs) :-
1123         ( Cs = [C1|Cr] ->
1124                 observes(C,C1),
1125                 observe_all(C,Cr)
1126         ;
1127                 true
1128         ).
1130 spawn_all(C,Cs) :-
1131         ( Cs = [C1|Cr] ->
1132                 spawns_observer(C,C1),
1133                 spawn_all(C,Cr)
1134         ;
1135                 true
1136         ).
1137 spawn_all_triggers(C,Cs) :-
1138         ( Cs = [C1|Cr] ->
1139                 ( may_trigger(C1) ->
1140                         spawns_observer(C,C1)
1141                 ;
1142                         true
1143                 ),
1144                 spawn_all_triggers(C,Cr)
1145         ;
1146                 true
1147         ).
1149 observe_body(C,Body,Cs) :-
1150         ( var(Body) ->
1151                 spawn_all(C,Cs)
1152         ; Body = true ->
1153                 true
1154         ; Body = fail ->
1155                 true
1156         ; Body = (B1,B2) ->
1157                 observe_body(C,B1,Cs),
1158                 observe_body(C,B2,Cs)
1159         ; Body = (B1;B2) ->
1160                 observe_body(C,B1,Cs),
1161                 observe_body(C,B2,Cs)
1162         ; Body = (B1->B2) ->
1163                 observe_body(C,B1,Cs),
1164                 observe_body(C,B2,Cs)
1165         ; functor(Body,F,A), member(F/A,Cs) ->
1166                 spawns_observer(C,F/A)
1167         ; Body = (_ = _) ->
1168                 spawn_all_triggers(C,Cs)
1169         ; Body = (_ is _) ->
1170                 spawn_all_triggers(C,Cs)
1171         ; builtin_binds_b(Body,Vars) ->
1172                 (  Vars == [] ->
1173                         true
1174                 ;
1175                         spawn_all_triggers(C,Cs)
1176                 )
1177         ;
1178                 spawn_all(C,Cs)
1179         ).
1181 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1183 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1184 % Late allocation
1186 late_allocation_analysis(Cs) :-
1187         ( chr_pp_flag(late_allocation,on) ->
1188                 late_allocation(Cs)
1189         ;
1190                 true
1191         ).
1193 late_allocation([]).
1194 late_allocation([C|Cs]) :-
1195         allocation_occurrence(C,1),
1196         late_allocation(Cs).
1197 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1200 %% Generated predicates
1201 %%      attach_$CONSTRAINT
1202 %%      attach_increment
1203 %%      detach_$CONSTRAINT
1204 %%      attr_unify_hook
1206 %%      attach_$CONSTRAINT
1207 generate_attach_detach_a_constraint_all([],[]).
1208 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
1209         ( ( chr_pp_flag(debugable,on) ; is_stored(Constraint), \+ only_ground_indexed_arguments(Constraint), \+ get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1210                 generate_attach_a_constraint(Constraint,Clauses1),
1211                 generate_detach_a_constraint(Constraint,Clauses2)
1212         ;
1213                 Clauses1 = [],
1214                 Clauses2 = []
1215         ),      
1216         generate_attach_detach_a_constraint_all(Constraints,Clauses3),
1217         append([Clauses1,Clauses2,Clauses3],Clauses).
1219 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
1220         generate_attach_a_constraint_nil(Constraint,Clause1),
1221         generate_attach_a_constraint_cons(Constraint,Clause2).
1223 attach_constraint_atom(FA,Vars,Susp,Atom) :-
1224         make_name('attach_',FA,Name),
1225         Atom =.. [Name,Vars,Susp].
1227 generate_attach_a_constraint_nil(FA,Clause) :-
1228         Clause = (Head :- true),
1229         attach_constraint_atom(FA,[],_,Head).
1231 generate_attach_a_constraint_cons(FA,Clause) :-
1232         Clause = (Head :- Body),
1233         attach_constraint_atom(FA,[Var|Vars],Susp,Head),
1234         attach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1235         Body = ( AttachBody, Subscribe, RecursiveCall ),
1236         get_max_constraint_index(N),
1237         ( N == 1 ->
1238                 generate_attach_body_1(FA,Var,Susp,AttachBody)
1239         ;
1240                 generate_attach_body_n(FA,Var,Susp,AttachBody)
1241         ),
1242         % SWI-Prolog specific code
1243         chr_pp_flag(solver_events,NMod),
1244         ( NMod \== none ->
1245                 Args = [[Var|_],Susp],
1246                 get_target_module(Mod),
1247                 use_auxiliary_predicate(run_suspensions),
1248                 Subscribe = clp_events:subscribe(Var,NMod,Mod,Mod:'$run_suspensions'([Susp]))
1249         ;
1250                 Subscribe = true
1251         ).
1253 generate_attach_body_1(FA,Var,Susp,Body) :-
1254         get_target_module(Mod),
1255         Body =
1256         (   get_attr(Var, Mod, Susps) ->
1257             put_attr(Var, Mod, [Susp|Susps])
1258         ;   
1259             put_attr(Var, Mod, [Susp])
1260         ).
1262 generate_attach_body_n(F/A,Var,Susp,Body) :-
1263         get_constraint_index(F/A,Position),
1264         or_pattern(Position,Pattern),
1265         get_max_constraint_index(Total),
1266         make_attr(Total,Mask,SuspsList,Attr),
1267         nth1(Position,SuspsList,Susps),
1268         substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
1269         make_attr(Total,Mask,SuspsList1,NewAttr1),
1270         substitute(Susps,SuspsList,[Susp],SuspsList2),
1271         make_attr(Total,NewMask,SuspsList2,NewAttr2),
1272         copy_term(SuspsList,SuspsList3),
1273         nth1(Position,SuspsList3,[Susp]),
1274         chr_delete(SuspsList3,[Susp],RestSuspsList),
1275         set_elems(RestSuspsList,[]),
1276         make_attr(Total,Pattern,SuspsList3,NewAttr3),
1277         get_target_module(Mod),
1278         Body =
1279         ( get_attr(Var,Mod,TAttr) ->
1280                 TAttr = Attr,
1281                 ( Mask /\ Pattern =:= Pattern ->
1282                         put_attr(Var, Mod, NewAttr1)
1283                 ;
1284                         NewMask is Mask \/ Pattern,
1285                         put_attr(Var, Mod, NewAttr2)
1286                 )
1287         ;
1288                 put_attr(Var,Mod,NewAttr3)
1289         ).
1291 %%      detach_$CONSTRAINT
1292 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
1293         generate_detach_a_constraint_nil(Constraint,Clause1),
1294         generate_detach_a_constraint_cons(Constraint,Clause2).
1296 detach_constraint_atom(FA,Vars,Susp,Atom) :-
1297         make_name('detach_',FA,Name),
1298         Atom =.. [Name,Vars,Susp].
1300 generate_detach_a_constraint_nil(FA,Clause) :-
1301         Clause = ( Head :- true),
1302         detach_constraint_atom(FA,[],_,Head).
1304 generate_detach_a_constraint_cons(FA,Clause) :-
1305         Clause = (Head :- Body),
1306         detach_constraint_atom(FA,[Var|Vars],Susp,Head),
1307         detach_constraint_atom(FA,Vars,Susp,RecursiveCall),
1308         Body = ( DetachBody, RecursiveCall ),
1309         get_max_constraint_index(N),
1310         ( N == 1 ->
1311                 generate_detach_body_1(FA,Var,Susp,DetachBody)
1312         ;
1313                 generate_detach_body_n(FA,Var,Susp,DetachBody)
1314         ).
1316 generate_detach_body_1(FA,Var,Susp,Body) :-
1317         get_target_module(Mod),
1318         Body =
1319         ( get_attr(Var,Mod,Susps) ->
1320                 'chr sbag_del_element'(Susps,Susp,NewSusps),
1321                 ( NewSusps == [] ->
1322                         del_attr(Var,Mod)
1323                 ;
1324                         put_attr(Var,Mod,NewSusps)
1325                 )
1326         ;
1327                 true
1328         ).
1330 generate_detach_body_n(F/A,Var,Susp,Body) :-
1331         get_constraint_index(F/A,Position),
1332         or_pattern(Position,Pattern),
1333         and_pattern(Position,DelPattern),
1334         get_max_constraint_index(Total),
1335         make_attr(Total,Mask,SuspsList,Attr),
1336         nth1(Position,SuspsList,Susps),
1337         substitute(Susps,SuspsList,[],SuspsList1),
1338         make_attr(Total,NewMask,SuspsList1,Attr1),
1339         substitute(Susps,SuspsList,NewSusps,SuspsList2),
1340         make_attr(Total,Mask,SuspsList2,Attr2),
1341         get_target_module(Mod),
1342         Body =
1343         ( get_attr(Var,Mod,TAttr) ->
1344                 TAttr = Attr,
1345                 ( Mask /\ Pattern =:= Pattern ->
1346                         'chr sbag_del_element'(Susps,Susp,NewSusps),
1347                         ( NewSusps == [] ->
1348                                 NewMask is Mask /\ DelPattern,
1349                                 ( NewMask == 0 ->
1350                                         del_attr(Var,Mod)
1351                                 ;
1352                                         put_attr(Var,Mod,Attr1)
1353                                 )
1354                         ;
1355                                 put_attr(Var,Mod,Attr2)
1356                         )
1357                 ;
1358                         true
1359                 )
1360         ;
1361                 true
1362         ).
1364 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1365 :- chr_constraint generate_indexed_variables_body/4.
1366 :- chr_option(mode,generate_indexed_variables_body(+,?,+,?)).
1367 %-------------------------------------------------------------------------------
1368 constraint_mode(F/A,ArgModes) \ generate_indexed_variables_body(F/A,Args,Body,Vars) <=>
1369         get_indexing_spec(F/A,Specs),
1370         ( chr_pp_flag(term_indexing,on) ->
1371                 spectermvars(Specs,Args,F,A,Body,Vars)
1372         ;
1373                 create_indexed_variables_body(Args,ArgModes,Vars,1,F/A,MaybeBody,N),
1374                 ( MaybeBody == empty ->
1375                         Body = true,
1376                         Vars = []
1377                 ; N == 0 ->
1378                         Term =.. [term|Args],
1379                         Body = term_variables(Term,Vars)
1380                 ; 
1381                         MaybeBody = Body
1382                 )
1383         ).
1384 generate_indexed_variables_body(FA,_,_,_) <=>
1385         chr_error(internal,'generate_indexed_variables_body: missing mode info for ~w.\n',[FA]).
1386 %===============================================================================
1388 create_indexed_variables_body([],[],_,_,_,empty,0).
1389 create_indexed_variables_body([V|Vs],[Mode|Modes],Vars,I,FA,Body,N) :-
1390         J is I + 1,
1391         create_indexed_variables_body(Vs,Modes,Tail,J,FA,RBody,M),
1392         ( Mode == (?),
1393           is_indexed_argument(FA,I) ->
1394                 ( RBody == empty ->
1395                         Body = term_variables(V,Vars)
1396                 ;
1397                         Body = (term_variables(V,Vars,Tail),RBody)
1398                 ),
1399                 N = M
1400         ; Mode == (-), is_indexed_argument(FA,I) ->
1401                 ( RBody == empty ->
1402                         Body = (Vars = [V])
1403                 ;
1404                         Body = (Vars = [V|Tail],RBody)
1405                 ),
1406                 N is M + 1
1407         ; 
1408                 Vars = Tail,
1409                 Body = RBody,
1410                 N is M + 1
1411         ).
1412 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1413 % EXPERIMENTAL
1414 spectermvars(Specs,Args,F,A,Goal,Vars) :-
1415         spectermvars(Args,1,Specs,F,A,Vars,[],Goal).    
1417 spectermvars([],B,_,_,A,L,L,true) :- B > A, !.
1418 spectermvars([Arg|Args],I,Specs,F,A,L,T,Goal) :-
1419         Goal = (ArgGoal,RGoal),
1420         argspecs(Specs,I,TempArgSpecs,RSpecs),
1421         merge_argspecs(TempArgSpecs,ArgSpecs),
1422         arggoal(ArgSpecs,Arg,ArgGoal,L,L1),
1423         J is I + 1,
1424         spectermvars(Args,J,RSpecs,F,A,L1,T,RGoal).
1426 argspecs([],_,[],[]).
1427 argspecs([[]|Rest],I,ArgSpecs,RestSpecs) :-
1428         argspecs(Rest,I,ArgSpecs,RestSpecs).
1429 argspecs([[specinfo(J,Spec,Args)|Specs]|Rest],I,ArgSpecs,RestSpecs) :-
1430         ( I == J ->
1431                 ArgSpecs = [specinfo(J,Spec,Args)|RArgSpecs],
1432                 ( Specs = [] -> 
1433                         RRestSpecs = RestSpecs
1434                 ;
1435                         RestSpecs = [Specs|RRestSpecs]
1436                 )
1437         ;
1438                 ArgSpecs = RArgSpecs,
1439                 RestSpecs = [[specinfo(J,Spec,Args)|Specs]|RRestSpecs]
1440         ),
1441         argspecs(Rest,I,RArgSpecs,RRestSpecs).
1443 merge_argspecs(In,Out) :-
1444         sort(In,Sorted),
1445         merge_argspecs_(Sorted,Out).
1446         
1447 merge_argspecs_([],[]).
1448 merge_argspecs_([X],R) :- !, R = [X].
1449 merge_argspecs_([specinfo(I,F1,A1),specinfo(I,F2,A2)|Rest],R) :-
1450         ( (F1 == any ; F2 == any) ->
1451                 merge_argspecs_([specinfo(I,any,[])|Rest],R)    
1452         ; F1 == F2 ->
1453                 append(A1,A2,A),
1454                 merge_argspecs_([specinfo(I,F1,A)|Rest],R)      
1455         ;
1456                 R = [specinfo(I,F1,A1)|RR],
1457                 merge_argspecs_([specinfo(I,F2,A2)|Rest],RR)
1458         ).
1460 arggoal(List,Arg,Goal,L,T) :-
1461         ( List == [] ->
1462                 L = T,
1463                 Goal = true
1464         ; List = [specinfo(_,any,_)] ->
1465                 Goal = term_variables(Arg,L,T)
1466         ;
1467                 Goal =
1468                 ( var(Arg) ->
1469                         L = [Arg|T]
1470                 ;
1471                         Cases
1472                 ),
1473                 arggoal_cases(List,Arg,L,T,Cases)
1474         ).
1476 arggoal_cases([],_,L,T,L=T).
1477 arggoal_cases([specinfo(_,FA,ArgSpecs)|Rest],Arg,L,T,Cases) :-
1478         ( ArgSpecs == [] ->
1479                 Cases = RCases
1480         ; ArgSpecs == [[]] ->
1481                 Cases = RCases
1482         ; FA = F/A ->
1483                 Cases = (Case ; RCases),
1484                 functor(Term,F,A),
1485                 Term =.. [_|Args],
1486                 Case = (Arg = Term -> ArgsGoal),
1487                 spectermvars(Args,1,ArgSpecs,F,A,L,T,ArgsGoal)
1488         ),
1489         arggoal_cases(Rest,Arg,L,T,RCases).
1490 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1492 generate_extra_clauses(Constraints,List) :-
1493         generate_activate_clauses(Constraints,List,Tail0),
1494         generate_remove_clauses(Constraints,Tail0,Tail1),
1495         generate_allocate_clauses(Constraints,Tail1,Tail2),
1496         generate_insert_constraint_internal_clauses(Constraints,Tail2,Tail3),
1497         generate_novel_production(Tail3,Tail4),
1498         generate_extend_history(Tail4,Tail5),
1499         generate_run_suspensions_clauses(Constraints,Tail5,Tail6),
1500         Tail6 = [].
1502 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1503 % remove_constraint_internal/[1/3]
1505 generate_remove_clauses([],List,List).
1506 generate_remove_clauses([C|Cs],List,Tail) :-
1507         generate_remove_clause(C,List,List1),
1508         generate_remove_clauses(Cs,List1,Tail).
1510 remove_constraint_goal(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Goal) :-
1511         uses_state(Constraint,removed),
1512         ( chr_pp_flag(inline_insertremove,off) ->
1513                 use_auxiliary_predicate(remove_constraint_internal,Constraint),
1514                 Goal = ( DeleteGoal, ( Delete == yes -> DeleteYes ; DeleteNo) ),
1515                 remove_constraint_atom(Constraint,Susp,Agenda,Delete,DeleteGoal)
1516         ;
1517                 delay_phase_end(validate_store_type_assumptions,
1518                         generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,Goal)
1519                 )
1520         ).
1522 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Goal) :-
1523         make_name('$remove_constraint_internal_',Constraint,Name),
1524         ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)) ) ->
1525                 Goal =.. [Name, Susp,Delete]
1526         ;
1527                 Goal =.. [Name,Susp,Agenda,Delete]
1528         ).
1529         
1530 generate_remove_clause(Constraint,List,Tail) :-
1531         ( is_used_auxiliary_predicate(remove_constraint_internal,Constraint) ->
1532                 List = [RemoveClause|Tail],
1533                 RemoveClause = (Head :- RemoveBody),
1534                 remove_constraint_atom(Constraint,Susp,Agenda,Delete,Head),
1535                 generate_remove_body(Constraint,Susp,Agenda,Delete = no,Delete = yes,RemoveBody)
1536         ;
1537                 List = Tail
1538         ).
1539         
1540 generate_remove_body(Constraint,Susp,Agenda,DeleteNo,DeleteYes,RemoveBody) :-
1541         ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
1542                 get_update_suspension_field(Constraint,Susp,state,State,removed,GetState,GetStateValue0,UpdateState),
1543                 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
1544                 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> DeleteNo ; DeleteYes),DeleteYes,MaybeDelete),
1545                 RemoveBody = 
1546                 (
1547                         GetState,
1548                         GetStateValue,
1549                         UpdateState,
1550                         MaybeDelete
1551                 )
1552         ;
1553                 static_suspension_term(Constraint,Susp2),
1554                 get_static_suspension_term_field(arguments,Constraint,Susp2,Args),
1555                 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Agenda),
1556                 ( chr_pp_flag(debugable,on) ->
1557                         Constraint = Functor / _,
1558                         get_static_suspension_term_field(functor,Constraint,Susp2,Functor)
1559                 ;
1560                         true
1561                 ),
1562                 get_update_static_suspension_field(Constraint,Susp,Susp2,state,State,removed,GetStateValue0,UpdateState),
1563                 if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
1564                 if_used_state(Constraint,not_stored_yet,(State == not_stored_yet -> Agenda = [], DeleteNo ; IndexedVariablesBody, DeleteYes),(IndexedVariablesBody,DeleteYes),MaybeDelete),
1565                 RemoveBody = 
1566                 (
1567                         Susp = Susp2,
1568                         GetStateValue,
1569                         UpdateState,
1570                         MaybeDelete
1571                 )
1572         ).
1574 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1575 % activate_constraint/4
1577 generate_activate_clauses([],List,List).
1578 generate_activate_clauses([C|Cs],List,Tail) :-
1579         generate_activate_clause(C,List,List1),
1580         generate_activate_clauses(Cs,List1,Tail).
1582 activate_constraint_goal(Constraint,StoreAction,Vars,Susp,Generation,Goal) :-
1583         ( chr_pp_flag(inline_insertremove,off) ->
1584                 use_auxiliary_predicate(activate_constraint,Constraint),
1585                 Goal = ( ActivateGoal , (Store == yes -> StoreAction ; true) ),
1586                 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,ActivateGoal)
1587         ;
1588                 delay_phase_end(validate_store_type_assumptions,
1589                         activate_constraint_body(Constraint,StoreAction,true,Vars,Susp,Generation,Goal)
1590                 )
1591         ).
1593 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Goal) :-
1594         make_name('$activate_constraint_',Constraint,Name),
1595         ( chr_pp_flag(debugable,off), only_ground_indexed_arguments(Constraint) ->
1596                 Goal =.. [Name,Store, Susp]
1597         ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
1598                 Goal =.. [Name,Store, Susp, Generation]
1599         ; chr_pp_flag(debugable,off), may_trigger(Constraint), get_store_type(Constraint,var_assoc_store(_,_)) ->
1600                 Goal =.. [Name,Store, Vars, Susp, Generation]
1601         ; 
1602                 Goal =.. [Name,Store, Vars, Susp]
1603         ).
1604         
1605 generate_activate_clause(Constraint,List,Tail) :-
1606         ( is_used_auxiliary_predicate(activate_constraint,Constraint) ->
1607                 List = [Clause|Tail],
1608                 Clause = (Head :- Body),
1609                 activate_constraint_atom(Constraint,Store,Vars,Susp,Generation,Head),
1610                 activate_constraint_body(Constraint,Store = yes, Store = no,Vars,Susp,Generation,Body)
1611         ;       
1612                 List = Tail
1613         ).
1615 activate_constraint_body(Constraint,StoreYes,StoreNo,Vars,Susp,Generation,Body) :-
1616         ( chr_pp_flag(debugable,off), may_trigger(Constraint), uses_field(Constraint,generation) ->
1617                 get_update_suspension_field(Constraint,Susp,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
1618                 GenerationHandling = (GetGeneration, GetGenerationValue, Generation is Gen+1, UpdateGeneration)
1619         ;
1620                 GenerationHandling = true
1621         ),
1622         get_update_suspension_field(Constraint,Susp,state,State,active,GetState,GetStateValue0,UpdateState),
1623         if_used_state(Constraint,not_stored_yet,GetStateValue0,true,GetStateValue),
1624         ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_))) ->
1625                 if_used_state(Constraint,not_stored_yet,( State == not_stored_yet -> StoreYes ; StoreNo ),StoreNo,StoreVarsGoal)
1626         ;
1627                 get_dynamic_suspension_term_field(arguments,Constraint,Susp,Arguments,ArgumentsGoal),
1628                 generate_indexed_variables_body(Constraint,Arguments,IndexedVariablesBody,Vars),
1629                 ( chr_pp_flag(guard_locks,off) ->
1630                         NoneLocked = true
1631                 ;
1632                         NoneLocked = 'chr none_locked'( Vars)
1633                 ),
1634                 if_used_state(Constraint,not_stored_yet,
1635                                           ( State == not_stored_yet ->
1636                                                   ArgumentsGoal,
1637                                                     IndexedVariablesBody, 
1638                                                     NoneLocked,    
1639                                                     StoreYes
1640                                                 ;
1641                                                     Vars = [],
1642                                                     StoreNo
1643                                                 ),
1644                                 (Vars = [],StoreNo),StoreVarsGoal)
1645         ),
1646         Body =  
1647         (
1648                 GetState,
1649                 GetStateValue,
1650                 UpdateState,
1651                 GenerationHandling,
1652                 StoreVarsGoal
1653         ).
1654 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1655 % allocate_constraint/4
1657 generate_allocate_clauses([],List,List).
1658 generate_allocate_clauses([C|Cs],List,Tail) :-
1659         generate_allocate_clause(C,List,List1),
1660         generate_allocate_clauses(Cs,List1,Tail).
1662 allocate_constraint_goal(Constraint,Susp,Args,Goal) :-
1663         uses_state(Constraint,not_stored_yet),
1664         ( chr_pp_flag(inline_insertremove,off) ->
1665                 use_auxiliary_predicate(allocate_constraint,Constraint),
1666                 allocate_constraint_atom(Constraint,Susp,Args,Goal)
1667         ;
1668                 Goal = (Susp = Suspension, Goal0),
1669                 delay_phase_end(validate_store_type_assumptions,
1670                         allocate_constraint_body(Constraint,Suspension,Args,Goal0)
1671                 )
1672         ).
1674 allocate_constraint_atom(Constraint, Susp, Args,Goal) :-
1675         make_name('$allocate_constraint_',Constraint,Name),
1676         Goal =.. [Name,Susp|Args].
1678 generate_allocate_clause(Constraint,List,Tail) :-
1679         ( is_used_auxiliary_predicate(allocate_constraint,Constraint) ->
1680                 List = [Clause|Tail],
1681                 Clause = (Head :- Body),        
1682                 Constraint = _/A,
1683                 length(Args,A),
1684                 allocate_constraint_atom(Constraint,Susp,Args,Head),
1685                 allocate_constraint_body(Constraint,Susp,Args,Body)
1686         ;
1687                 List = Tail
1688         ).
1690 allocate_constraint_body(Constraint,Susp,Args,Body) :-
1691         static_suspension_term(Constraint,Suspension),
1692         get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
1693         ( chr_pp_flag(debugable,on) ->
1694                 Constraint = Functor / _,
1695                 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
1696         ;
1697                 true
1698         ),
1699         ( chr_pp_flag(debugable,on) ->
1700                 ( may_trigger(Constraint) ->
1701                         append(Args,[Susp],VarsSusp),
1702                         build_head(F,A,[0],VarsSusp, ContinuationGoal),
1703                         get_target_module(Mod),
1704                         Continuation = Mod : ContinuationGoal
1705                 ;
1706                         Continuation = true
1707                 ),      
1708                 Init = (Susp = Suspension),
1709                 create_static_suspension_field(Constraint,Suspension,continuation,Continuation,CreateContinuation),
1710                 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
1711         ; may_trigger(Constraint), uses_field(Constraint,generation) ->
1712                 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration),
1713                 Susp = Suspension, Init = true, CreateContinuation = true
1714         ;
1715                 CreateGeneration = true, Susp = Suspension, Init = true, CreateContinuation = true
1716         ),
1717         ( uses_history(Constraint) ->
1718                 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
1719         ;
1720                 CreateHistory = true
1721         ),
1722         create_static_suspension_field(Constraint,Suspension,state,not_stored_yet,CreateState),
1723         ( has_suspension_field(Constraint,id) ->
1724                 get_static_suspension_term_field(id,Constraint,Suspension,Id),
1725                 GenID = 'chr gen_id'(Id)
1726         ;
1727                 GenID = true
1728         ),
1729         Body = 
1730         (
1731                 Init,
1732                 CreateContinuation,
1733                 CreateGeneration,
1734                 CreateHistory,
1735                 CreateState,
1736                 GenID
1737         ).
1739 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1740 % insert_constraint_internal
1742 generate_insert_constraint_internal_clauses([],List,List).
1743 generate_insert_constraint_internal_clauses([C|Cs],List,Tail) :-
1744         generate_insert_constraint_internal_clause(C,List,List1),
1745         generate_insert_constraint_internal_clauses(Cs,List1,Tail).
1747 insert_constraint_internal_constraint_goal(Constraint, Vars, Suspension, Continuation, Args,Goal) :-
1748         ( chr_pp_flag(inline_insertremove,off) -> 
1749                 use_auxiliary_predicate(remove_constraint_internal,Constraint),
1750                 insert_constraint_internal_constraint_atom(Constraint,Vars,Suspension,Continuation,Args,Goal)
1751         ;
1752                 delay_phase_end(validate_store_type_assumptions,
1753                         generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Goal)
1754                 )
1755         ).
1756         
1758 insert_constraint_internal_constraint_atom(Constraint,Vars,Self,Closure,Args,Goal) :-
1759         insert_constraint_internal_constraint_name(Constraint,Name),
1760         ( chr_pp_flag(debugable,on) -> 
1761                 Goal =.. [Name, Vars, Self, Closure | Args]
1762         ; ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
1763                 Goal =.. [Name,Self | Args]
1764         ;
1765                 Goal =.. [Name,Vars, Self | Args]
1766         ).
1767         
1768 insert_constraint_internal_constraint_name(Constraint,Name) :-
1769         make_name('$insert_constraint_internal_',Constraint,Name).
1771 generate_insert_constraint_internal_clause(Constraint,List,Tail) :-
1772         ( is_used_auxiliary_predicate(insert_constraint_internal,Constraint) ->
1773                 List = [Clause|Tail],
1774                 Clause = (Head :- Body),
1775                 Constraint = _/A,
1776                 length(Args,A),
1777                 insert_constraint_internal_constraint_atom(Constraint, Vars, Suspension, Continuation,Args,Head),
1778                 generate_insert_constraint_internal_body(Constraint,Suspension,Continuation,Args,Vars,Body)
1779         ;
1780                 List = Tail
1781         ).
1784 generate_insert_constraint_internal_body(Constraint,Susp,Continuation,Args,Vars,Body) :-
1785         static_suspension_term(Constraint,Suspension),
1786         create_static_suspension_field(Constraint,Suspension,state,active,CreateState),
1787         ( chr_pp_flag(debugable,on) ->
1788                 get_static_suspension_term_field(continuation,Constraint,Suspension,Continuation),
1789                 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
1790         ; may_trigger(Constraint), uses_field(Constraint,generation) ->
1791                 create_static_suspension_field(Constraint,Suspension,generation,0,CreateGeneration)
1792         ;
1793                 CreateGeneration = true
1794         ),
1795         ( chr_pp_flag(debugable,on) ->
1796                 Constraint = Functor / _,
1797                 get_static_suspension_term_field(functor,Constraint,Suspension,Functor)
1798         ;
1799                 true
1800         ),
1801         ( uses_history(Constraint) ->
1802                 create_static_suspension_field(Constraint,Suspension,history,t,CreateHistory)
1803         ;
1804                 CreateHistory = true
1805         ),
1806         get_static_suspension_term_field(arguments,Constraint,Suspension,Args),
1807         List = [Clause|Tail],
1808         ( chr_pp_flag(debugable,off), ( only_ground_indexed_arguments(Constraint) ; get_store_type(Constraint,var_assoc_store(_,_)))->
1809                 suspension_term_base_fields(Constraint,BaseFields),
1810                 ( has_suspension_field(Constraint,id) ->
1811                         get_static_suspension_term_field(id,Constraint,Suspension,Id),
1812                         GenID = 'chr gen_id'(Id)
1813                 ;
1814                         GenID = true
1815                 ),
1816                 Body =
1817                     (
1818                         Susp = Suspension,
1819                         CreateState,
1820                         CreateGeneration,
1821                         CreateHistory,
1822                         GenID           
1823                     )
1824         ;
1825                 ( has_suspension_field(Constraint,id) ->
1826                         get_static_suspension_term_field(id,Constraint,Suspension,Id),
1827                         GenID = 'chr gen_id'(Id)
1828                 ;
1829                         GenID = true
1830                 ),
1831                 generate_indexed_variables_body(Constraint,Args,IndexedVariablesBody,Vars),
1832                 ( chr_pp_flag(guard_locks,off) ->
1833                         NoneLocked = true
1834                 ;
1835                         NoneLocked = 'chr none_locked'( Vars)
1836                 ),
1837                 Body =
1838                 (
1839                         Susp = Suspension,
1840                         IndexedVariablesBody,
1841                         NoneLocked,
1842                         CreateState,
1843                         CreateGeneration,
1844                         CreateHistory,
1845                         GenID
1846                 )
1847         ).
1849 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1850 % novel_production/2
1852 generate_novel_production(List,Tail) :-
1853         ( is_used_auxiliary_predicate(novel_production) ->
1854                 List = [Clause|Tail],
1855                 Clause =
1856                 (
1857                         '$novel_production'( Self, Tuple) :-
1858                                 % arg( 3, Self, Ref), % ARGXXX
1859                                 % 'chr get_mutable'( History, Ref),
1860                                 arg( 3, Self, History), % ARGXXX
1861                                 ( hprolog:get_ds( Tuple, History, _) ->
1862                                         fail
1863                                 ;
1864                                         true
1865                                 )
1866                 )
1867         ;
1868                 List = Tail
1869         ).
1871 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1872 % extend_history/2
1874 generate_extend_history(List,Tail) :-
1875         ( is_used_auxiliary_predicate(extend_history) ->
1876                 List = [Clause|Tail],
1877                 Clause =
1878                 (
1879                         '$extend_history'( Self, Tuple) :-
1880                                 % arg( 3, Self, Ref), % ARGXXX
1881                                 % 'chr get_mutable'( History, Ref),
1882                                 arg( 3, Self, History), % ARGXXX
1883                                 hprolog:put_ds( Tuple, History, x, NewHistory),
1884                                 setarg( 3, Self, NewHistory) % ARGXXX
1885                 )
1886         ;
1887                 List = Tail
1888         ).
1890 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1891 % run_suspensions/2
1893 generate_run_suspensions_clauses([],List,List).
1894 generate_run_suspensions_clauses([C|Cs],List,Tail) :-
1895         generate_run_suspensions_clause(C,List,List1),
1896         generate_run_suspensions_clauses(Cs,List1,Tail).
1898 run_suspensions_goal(Constraint,Suspensions,Goal) :-
1899         make_name('$run_suspensions_',Constraint,Name),
1900         Goal =.. [Name,Suspensions].
1901         
1902 generate_run_suspensions_clause(Constraint,List,Tail) :-
1903         ( is_used_auxiliary_predicate(run_suspensions,Constraint) ->
1904                 List = [Clause1,Clause2|Tail],
1905                 run_suspensions_goal(Constraint,[],Clause1),
1906                 ( chr_pp_flag(debugable,on) ->
1907                         run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
1908                         get_update_suspension_field(Constraint,Suspension,state,State,triggered,GetState,GetStateValue,UpdateState),
1909                         get_update_suspension_field(Constraint,Suspension,state,Post,active,GetPost,GetPostValue,UpdatePost),
1910                         get_update_suspension_field(Constraint,Suspension,generation,Gen,Generation,GetGeneration,GetGenerationValue,UpdateGeneration),
1911                         get_dynamic_suspension_term_field(continuation,Constraint,Suspension,Continuation,GetContinuation),
1912                         run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
1913                         Clause2 =
1914                         (
1915                                 Clause2Head :-
1916                                         GetState,
1917                                         GetStateValue,
1918                                         ( State==active ->
1919                                             UpdateState,
1920                                             GetGeneration,
1921                                             GetGenerationValue,
1922                                             Generation is Gen+1,
1923                                             UpdateGeneration,
1924                                             GetContinuation,
1925                                             ( 
1926                                                 'chr debug_event'(wake(Suspension)),
1927                                                 call(Continuation)
1928                                             ;
1929                                                 'chr debug_event'(fail(Suspension)), !,
1930                                                 fail
1931                                             ),
1932                                             (
1933                                                 'chr debug_event'(exit(Suspension))
1934                                             ;
1935                                                 'chr debug_event'(redo(Suspension)),
1936                                                 fail
1937                                             ),  
1938                                             GetPost,
1939                                             GetPostValue,
1940                                             ( Post==triggered ->
1941                                                 UpdatePost   % catching constraints that did not do anything
1942                                             ;
1943                                                 true
1944                                             )
1945                                         ;
1946                                             true
1947                                         ),
1948                                         Clause2Recursion
1949                         )
1950                 ;
1951                         run_suspensions_goal(Constraint,[Suspension|Suspensions],Clause2Head),
1952                         static_suspension_term(Constraint,SuspensionTerm),
1953                         get_static_suspension_term_field(arguments,Constraint,SuspensionTerm,Arguments),
1954                         append(Arguments,[Suspension],VarsSusp),
1955                         make_suspension_continuation_goal(Constraint,VarsSusp,Continuation),
1956                         run_suspensions_goal(Constraint,Suspensions,Clause2Recursion),
1957                         ( uses_field(Constraint,generation) ->
1958                                 get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,generation,Gen,Generation,GetGeneration,UpdateGeneration),
1959                                 GenerationHandling = ( GetGeneration, Generation is Gen+1, UpdateGeneration)
1960                         ;
1961                                 GenerationHandling = true
1962                         ),
1963                         get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,State,triggered,GetState,UpdateState),
1964                         get_update_static_suspension_field(Constraint,Suspension,SuspensionTerm,state,Post,active,GetPostState,UpdatePostState),
1965                         if_used_state(Constraint,removed,
1966                                 ( GetState,
1967                                         ( State==active 
1968                                         -> ReactivateConstraint 
1969                                         ;  true)        
1970                                 ),ReactivateConstraint,CondReactivate),
1971                         ReactivateConstraint =
1972                         (
1973                                 UpdateState,
1974                                 GenerationHandling,
1975                                 Continuation,
1976                                 GetPostState,
1977                                 ( Post==triggered ->
1978                                     UpdatePostState     % catching constraints that did not do anything
1979                                 ;
1980                                     true
1981                                 )
1982                         ),
1983                         Clause2 =
1984                         (
1985                                 Clause2Head :-
1986                                         Suspension = SuspensionTerm,
1987                                         CondReactivate,
1988                                         Clause2Recursion
1989                         )
1990                 )
1991         ;
1992                 List = Tail
1993         ).
1995 %~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
1997 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1998 generate_attach_increment(Clauses) :-
1999         get_max_constraint_index(N),
2000         ( is_used_auxiliary_predicate(attach_increment), N > 0 ->
2001                 Clauses = [Clause1,Clause2],
2002                 generate_attach_increment_empty(Clause1),
2003                 ( N == 1 ->
2004                         generate_attach_increment_one(Clause2)
2005                 ;
2006                         generate_attach_increment_many(N,Clause2)
2007                 )
2008         ;
2009                 Clauses = []
2010         ).
2012 generate_attach_increment_empty((attach_increment([],_) :- true)).
2014 generate_attach_increment_one(Clause) :-
2015         Head = attach_increment([Var|Vars],Susps),
2016         get_target_module(Mod),
2017         ( chr_pp_flag(guard_locks,off) ->
2018                 NotLocked = true
2019         ;
2020                 NotLocked = 'chr not_locked'( Var)
2021         ),
2022         Body =
2023         (
2024                 NotLocked,
2025                 ( get_attr(Var,Mod,VarSusps) ->
2026                         sort(VarSusps,SortedVarSusps),
2027                         'chr merge_attributes'(Susps,SortedVarSusps,MergedSusps),
2028                         put_attr(Var,Mod,MergedSusps)
2029                 ;
2030                         put_attr(Var,Mod,Susps)
2031                 ),
2032                 attach_increment(Vars,Susps)
2033         ), 
2034         Clause = (Head :- Body).
2036 generate_attach_increment_many(N,Clause) :-
2037         make_attr(N,Mask,SuspsList,Attr),
2038         make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
2039         Head = attach_increment([Var|Vars],Attr),
2040         bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
2041         list2conj(Gs,SortGoals),
2042         bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
2043         make_attr(N,MergedMask,MergedSuspsList,NewAttr),
2044         get_target_module(Mod),
2045         ( chr_pp_flag(guard_locks,off) ->
2046                 NotLocked = true
2047         ;
2048                 NotLocked = 'chr not_locked'( Var)
2049         ),
2050         Body =  
2051         (
2052                 NotLocked,
2053                 ( get_attr(Var,Mod,TOtherAttr) ->
2054                         TOtherAttr = OtherAttr,
2055                         SortGoals,
2056                         MergedMask is Mask \/ OtherMask,
2057                         put_attr(Var,Mod,NewAttr)
2058                 ;
2059                         put_attr(Var,Mod,Attr)
2060                 ),
2061                 attach_increment(Vars,Attr)
2062         ),
2063         Clause = (Head :- Body).
2065 %%      attr_unify_hook
2066 generate_attr_unify_hook(Clauses) :-
2067         get_max_constraint_index(N),
2068         ( N == 0 ->
2069                 Clauses = []
2070         ; 
2071                 Clauses = [Clause],
2072                 ( N == 1 ->
2073                         generate_attr_unify_hook_one(Clause)
2074                 ;
2075                         generate_attr_unify_hook_many(N,Clause)
2076                 )
2077         ).
2079 generate_attr_unify_hook_one(Clause) :-
2080         Head = attr_unify_hook(Susps,Other),
2081         get_target_module(Mod),
2082         get_indexed_constraint(1,C),
2083         ( get_store_type(C,default) ->
2084                 make_run_suspensions(NewSusps,SortedSusps,WakeNewSusps),
2085                 make_run_suspensions(SortedSusps,SortedSusps,WakeSusps),
2086                 ( atomic_types_suspended_constraint(C) ->
2087                         SortGoal1   = true,
2088                         SortedSusps = Susps,
2089                         SortGoal2   = true,
2090                         SortedOtherSusps = OtherSusps,
2091                         MergeGoal = (append(Susps,OtherSusps,List), sort(List,NewSusps)),
2092                         NonvarBody = true       
2093                 ;
2094                         SortGoal1 = sort(Susps, SortedSusps),   
2095                         SortGoal2 = sort(OtherSusps,SortedOtherSusps), 
2096                         MergeGoal = 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
2097                         use_auxiliary_predicate(attach_increment),
2098                         NonvarBody =
2099                                 ( compound(Other) ->
2100                                         term_variables(Other,OtherVars),
2101                                         attach_increment(OtherVars, SortedSusps)
2102                                 ;
2103                                         true
2104                                 )
2105                 ),      
2106                 Body = 
2107                 (
2108                         SortGoal1,
2109                         ( var(Other) ->
2110                                 ( get_attr(Other,Mod,OtherSusps) ->
2111                                         SortGoal2,
2112                                         MergeGoal,
2113                                         put_attr(Other,Mod,NewSusps),
2114                                         WakeNewSusps
2115                                 ;
2116                                         put_attr(Other,Mod,SortedSusps),
2117                                         WakeSusps
2118                                 )
2119                         ;
2120                                 NonvarBody,
2121                                 WakeSusps
2122                         )
2123                 ),
2124                 Clause = (Head :- Body)
2125         ; get_store_type(C,var_assoc_store(VarIndex,KeyIndex)) ->
2126                 make_run_suspensions(List,List,WakeNewSusps),
2127                 MergeGoal = (merge_into_assoc_store(Susps,OtherSusps,List)),
2128                 Body = 
2129                         ( get_attr(Other,Mod,OtherSusps) ->
2130                                 MergeGoal,
2131                                 WakeNewSusps
2132                         ;
2133                                 put_attr(Other,Mod,Susps)
2134                         ),
2135                 Clause = (Head :- Body)
2136         ).
2139 generate_attr_unify_hook_many(N,Clause) :-
2140         make_attr(N,Mask,SuspsList,Attr),
2141         make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
2142         bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
2143         list2conj(SortGoalList,SortGoals),
2144         bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
2145         bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
2146                                   C = (sort(E,F),
2147                                        'chr merge_attributes'(D,F,G)) ), 
2148               SortMergeGoalList),
2149         bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
2150         list2conj(SortMergeGoalList,SortMergeGoals),
2151         make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
2152         make_attr(N,Mask,SortedSuspsList,SortedAttr),
2153         Head = attr_unify_hook(Attr,Other),
2154         get_target_module(Mod),
2155         make_run_suspensions_loop(MergedSuspsList,SortedSuspsList,WakeMergedSusps),
2156         make_run_suspensions_loop(SortedSuspsList,SortedSuspsList,WakeSortedSusps),
2157         ( forall((between(1,N,Index), get_indexed_constraint(Index,Constraint)),atomic_types_suspended_constraint(Constraint)) ->
2158                 NonvarBody = true       
2159         ;
2160                 use_auxiliary_predicate(attach_increment),
2161                 NonvarBody =
2162                         ( compound(Other) ->
2163                                 term_variables(Other,OtherVars),
2164                                 attach_increment(OtherVars,SortedAttr)
2165                         ;
2166                                 true
2167                         )
2168         ),      
2169         Body =
2170         (
2171                 SortGoals,
2172                 ( var(Other) ->
2173                         ( get_attr(Other,Mod,TOtherAttr) ->
2174                                 TOtherAttr = OtherAttr,
2175                                 SortMergeGoals,
2176                                 MergedMask is Mask \/ OtherMask,
2177                                 put_attr(Other,Mod,MergedAttr),
2178                                 WakeMergedSusps
2179                         ;
2180                                 put_attr(Other,Mod,SortedAttr),
2181                                 WakeSortedSusps
2182                         )
2183                 ;
2184                         NonvarBody,
2185                         WakeSortedSusps
2186                 )       
2187         ),      
2188         Clause = (Head :- Body).
2190 make_run_suspensions(AllSusps,OneSusps,Goal) :-
2191         make_run_suspensions(1,AllSusps,OneSusps,Goal).
2193 make_run_suspensions(Index,AllSusps,OneSusps,Goal) :-
2194         ( get_indexed_constraint(Index,C), may_trigger(C) ->
2195                 use_auxiliary_predicate(run_suspensions,C),
2196                 ( wakes_partially(C) ->
2197                         run_suspensions_goal(C,OneSusps,Goal)
2198                 ;
2199                         run_suspensions_goal(C,AllSusps,Goal)
2200                 )
2201         ;
2202                 Goal = true
2203         ).
2205 make_run_suspensions_loop(AllSuspsList,OneSuspsList,Goal) :-
2206         make_run_suspensions_loop(AllSuspsList,OneSuspsList,1,Goal).
2208 make_run_suspensions_loop([],[],_,true).
2209 make_run_suspensions_loop([AllSusps|AllSuspsList],[OneSusps|OneSuspsList],I,(Goal,Goals)) :-
2210         make_run_suspensions(I,AllSusps,OneSusps,Goal),
2211         J is I + 1,
2212         make_run_suspensions_loop(AllSuspsList,OneSuspsList,J,Goals).
2213         
2214 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2215 % $insert_in_store_F/A
2216 % $delete_from_store_F/A
2218 generate_insert_delete_constraints([],[]). 
2219 generate_insert_delete_constraints([FA|Rest],Clauses) :-
2220         ( is_stored(FA) ->
2221                 generate_insert_delete_constraint(FA,Clauses,RestClauses)
2222         ;
2223                 Clauses = RestClauses
2224         ),
2225         generate_insert_delete_constraints(Rest,RestClauses).
2226                         
2227 generate_insert_delete_constraint(FA,Clauses,RestClauses) :-
2228         insert_constraint_clause(FA,Clauses,RestClauses1),
2229         RestClauses1 = [DClause|RestClauses],
2230         get_store_type(FA,StoreType),
2231         generate_delete_constraint(StoreType,FA,DClause).
2233 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2234 % insert_in_store
2236 insert_constraint_goal(FA,Susp,Vars,Goal) :-    
2237         ( chr_pp_flag(inline_insertremove,off) ->
2238                 use_auxiliary_predicate(insert_in_store,FA),
2239                 insert_constraint_atom(FA,Susp,Goal)
2240         ;
2241                 delay_phase_end(validate_store_type_assumptions,
2242                         ( insert_constraint_body(FA,Susp,UsedVars,Goal),
2243                           insert_constraint_direct_used_vars(UsedVars,Vars)
2244                         )  
2245                 )
2246         ).
2248 insert_constraint_direct_used_vars([],_).
2249 insert_constraint_direct_used_vars([Index-Var|Rest],Vars) :-
2250         nth1(Index,Vars,Var),
2251         insert_constraint_direct_used_vars(Rest,Vars).
2253 insert_constraint_atom(FA,Susp,Call) :-
2254         make_name('$insert_in_store_',FA,Functor),
2255         Call =.. [Functor,Susp]. 
2257 insert_constraint_clause(C,Clauses,RestClauses) :-
2258         ( is_used_auxiliary_predicate(insert_in_store,C) ->
2259                 Clauses = [Clause|RestClauses],
2260                 Clause = (Head :- InsertCounterInc,VarsBody,Body),      
2261                 insert_constraint_atom(C,Susp,Head),
2262                 insert_constraint_body(C,Susp,UsedVars,Body),
2263                 insert_constraint_used_vars(UsedVars,C,Susp,VarsBody),
2264                 ( chr_pp_flag(store_counter,on) ->
2265                         InsertCounterInc = '$insert_counter_inc'
2266                 ;
2267                         InsertCounterInc = true 
2268                 )
2269         ;
2270                 Clauses = RestClauses
2271         ).
2273 insert_constraint_used_vars([],_,_,true).
2274 insert_constraint_used_vars([Index-Var|Rest],C,Susp,(Goal,Goals)) :-
2275         get_dynamic_suspension_term_field(argument(Index),C,Susp,Var,Goal),
2276         insert_constraint_used_vars(Rest,C,Susp,Goals).
2278 insert_constraint_body(C,Susp,UsedVars,Body) :-
2279         get_store_type(C,StoreType),
2280         insert_constraint_body(StoreType,C,Susp,UsedVars,Body).
2282 insert_constraint_body(default,C,Susp,[],Body) :-
2283         global_list_store_name(C,StoreName),
2284         make_get_store_goal(StoreName,Store,GetStoreGoal),
2285         make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2286         ( chr_pp_flag(debugable,on) ->
2287                 Cell = [Susp|Store],
2288                 Body =
2289                 (
2290                         GetStoreGoal,
2291                         UpdateStoreGoal
2292                 )
2293         ;
2294                 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),    
2295                 Body =
2296                 (
2297                         GetStoreGoal, 
2298                         Cell = [Susp|Store],
2299                         UpdateStoreGoal, 
2300                         ( Store = [NextSusp|_] ->
2301                                 SetGoal
2302                         ;
2303                                 true
2304                         )
2305                 )
2306         ).
2307 %       get_target_module(Mod),
2308 %       get_max_constraint_index(Total),
2309 %       ( Total == 1 ->
2310 %               generate_attach_body_1(C,Store,Susp,AttachBody)
2311 %       ;
2312 %               generate_attach_body_n(C,Store,Susp,AttachBody)
2313 %       ),
2314 %       Body =
2315 %       (
2316 %               'chr default_store'(Store),
2317 %               AttachBody
2318 %       ).
2319 insert_constraint_body(multi_inthash(Indexes),C,Susp,[],Body) :-
2320         generate_multi_inthash_insert_constraint_bodies(Indexes,C,Susp,Body).
2321 insert_constraint_body(multi_hash(Indexes),C,Susp,MixedUsedVars,Body) :-
2322         generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body,MixedUsedVars),
2323         sort_out_used_vars(MixedUsedVars,UsedVars).
2324 insert_constraint_body(global_ground,C,Susp,[],Body) :-
2325         global_ground_store_name(C,StoreName),
2326         make_get_store_goal(StoreName,Store,GetStoreGoal),
2327         make_update_store_goal(StoreName,Cell,UpdateStoreGoal),
2328         ( chr_pp_flag(debugable,on) ->
2329                 Cell = [Susp|Store],
2330                 Body =
2331                 (
2332                         GetStoreGoal,    
2333                         UpdateStoreGoal  
2334                 )
2335         ;
2336                 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,Cell,SetGoal),    
2337                 Body =
2338                 (
2339                         GetStoreGoal,    
2340                         Cell = [Susp|Store],
2341                         UpdateStoreGoal, 
2342                         ( Store = [NextSusp|_] ->
2343                                 SetGoal
2344                         ;
2345                                 true
2346                         )
2347                 )
2348         ).
2349 %       global_ground_store_name(C,StoreName),
2350 %       make_get_store_goal(StoreName,Store,GetStoreGoal),
2351 %       make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
2352 %       Body =
2353 %       (
2354 %               GetStoreGoal,    % nb_getval(StoreName,Store),
2355 %               UpdateStoreGoal  % b_setval(StoreName,[Susp|Store])
2356 %       ).
2357 insert_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,[VarIndex-Variable,AssocIndex-Key],Body) :-
2358         % TODO: generalize to more than one !!!
2359         get_target_module(Module),
2360         Body = ( get_attr(Variable,Module,AssocStore) ->
2361                         insert_assoc_store(AssocStore,Key,Susp)
2362                 ;
2363                         new_assoc_store(AssocStore),
2364                         put_attr(Variable,Module,AssocStore),
2365                         insert_assoc_store(AssocStore,Key,Susp)
2366                 ).
2368 insert_constraint_body(global_singleton,C,Susp,[],Body) :-
2369         global_singleton_store_name(C,StoreName),
2370         make_update_store_goal(StoreName,Susp,UpdateStoreGoal),
2371         Body =
2372         (
2373                 UpdateStoreGoal 
2374         ).
2375 insert_constraint_body(multi_store(StoreTypes),C,Susp,UsedVars,Body) :-
2376         find_with_var_identity(
2377                 B-UV,
2378                 [Susp],
2379                 ( 
2380                         member(ST,StoreTypes),
2381                         chr_translate:insert_constraint_body(ST,C,Susp,UV,B)
2382                 ),
2383                 BodiesUsedVars
2384                 ),
2385         once(pairup(Bodies,NestedUsedVars,BodiesUsedVars)),
2386         list2conj(Bodies,Body),
2387         sort_out_used_vars(NestedUsedVars,UsedVars).
2390 sort_out_used_vars(NestedUsedVars,UsedVars) :-
2391         flatten(NestedUsedVars,FlatUsedVars),
2392         sort(FlatUsedVars,SortedFlatUsedVars),
2393         sort_out_used_vars1(SortedFlatUsedVars,UsedVars).
2395 sort_out_used_vars1([],[]).
2396 sort_out_used_vars1([I-V],L) :- !, L = [I-V].
2397 sort_out_used_vars1([I-X,J-Y|R],L) :-
2398         ( I == J ->
2399                 X = Y,
2400                 sort_out_used_vars1([I-X|R],L)
2401         ;
2402                 L = [I-X|T],
2403                 sort_out_used_vars1([J-Y|R],T)
2404         ).
2406 generate_multi_inthash_insert_constraint_bodies([],_,_,true).
2407 generate_multi_inthash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2408         multi_hash_store_name(FA,Index,StoreName),
2409         multi_hash_key(FA,Index,Susp,KeyBody,Key),
2410         Body =
2411         (
2412                 KeyBody,
2413                 nb_getval(StoreName,Store),
2414                 insert_iht(Store,Key,Susp)
2415         ),
2416         generate_multi_inthash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
2418 generate_multi_hash_insert_constraint_bodies([],_,_,true,[]).
2419 generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies),[UsedVars|MoreUsedVars]) :-
2420         multi_hash_store_name(FA,Index,StoreName),
2421         multi_hash_key_direct(FA,Index,Susp,Key,UsedVars),
2422         make_get_store_goal(StoreName,Store,GetStoreGoal),
2423         Body =
2424         (
2425                 GetStoreGoal, 
2426                 insert_ht(Store,Key,Susp)
2427         ),
2428         generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies,MoreUsedVars).
2430 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~%
2431 % Delete
2433 generate_delete_constraint(StoreType,FA,Clause) :-
2434         generate_delete_constraint_call(FA,Susp,Head),
2435         generate_delete_constraint_body(StoreType,FA,Susp,Body),
2436         ( chr_pp_flag(store_counter,on) ->
2437                 DeleteCounterInc = '$delete_counter_inc'
2438         ;
2439                 DeleteCounterInc = true 
2440         ),
2441         Clause = (Head :- DeleteCounterInc, Body).
2443 generate_delete_constraint_body(default,C,Susp,Body) :-
2444         ( chr_pp_flag(debugable,on) ->
2445                 global_list_store_name(C,StoreName),
2446                 make_get_store_goal(StoreName,Store,GetStoreGoal),
2447                 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
2448                 Body =
2449                 (
2450                         GetStoreGoal, % nb_getval(StoreName,Store),
2451                         'chr sbag_del_element'(Store,Susp,NStore),
2452                         UpdateStoreGoal % b_setval(StoreName,NStore)
2453                 )
2454         ;
2455                 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
2456                 global_list_store_name(C,StoreName),
2457                 make_get_store_goal(StoreName,Store,GetStoreGoal),
2458                 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
2459                 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),      
2460                 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),       
2461                 Body =
2462                 (
2463                         GetGoal,
2464                         ( var(PredCell) ->
2465                                 GetStoreGoal, % nb_getval(StoreName,Store),
2466                                 Store = [_|Tail],
2467                                 UpdateStoreGoal,
2468                                 ( Tail = [NextSusp|_] ->
2469                                         SetGoal1
2470                                 ;
2471                                         true
2472                                 )       
2473                         ;
2474                                 PredCell = [_,_|Tail],
2475                                 setarg(2,PredCell,Tail),
2476                                 ( Tail = [NextSusp|_] ->
2477                                         SetGoal2
2478                                 ;
2479                                         true
2480                                 )       
2481                         )
2482                 )
2483         ).
2484 %       get_target_module(Mod),
2485 %       get_max_constraint_index(Total),
2486 %       ( Total == 1 ->
2487 %               generate_detach_body_1(C,Store,Susp,DetachBody),
2488 %               Body =
2489 %               (
2490 %                       'chr default_store'(Store),
2491 %                       DetachBody
2492 %               )
2493 %       ;
2494 %               generate_detach_body_n(C,Store,Susp,DetachBody),
2495 %               Body =
2496 %               (
2497 %                       'chr default_store'(Store),
2498 %                       DetachBody
2499 %               )
2500 %       ).
2501 generate_delete_constraint_body(multi_inthash(Indexes),C,Susp,Body) :-
2502         generate_multi_inthash_delete_constraint_bodies(Indexes,C,Susp,Body).
2503 generate_delete_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
2504         generate_multi_hash_delete_constraint_bodies(Indexes,C,Susp,Body).
2505 generate_delete_constraint_body(global_ground,C,Susp,Body) :-
2506         ( chr_pp_flag(debugable,on) ->
2507                 global_ground_store_name(C,StoreName),
2508                 make_get_store_goal(StoreName,Store,GetStoreGoal),
2509                 make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
2510                 Body =
2511                 (
2512                         GetStoreGoal, % nb_getval(StoreName,Store),
2513                         'chr sbag_del_element'(Store,Susp,NStore),
2514                         UpdateStoreGoal % b_setval(StoreName,NStore)
2515                 )
2516         ;
2517                 get_dynamic_suspension_term_field(global_list_prev,C,Susp,PredCell,GetGoal),
2518                 global_ground_store_name(C,StoreName),
2519                 make_get_store_goal(StoreName,Store,GetStoreGoal),
2520                 make_update_store_goal(StoreName,Tail,UpdateStoreGoal),
2521                 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,_,SetGoal1),      
2522                 set_dynamic_suspension_term_field(global_list_prev,C,NextSusp,PredCell,SetGoal2),       
2523                 Body =
2524                 (
2525                         GetGoal,
2526                         ( var(PredCell) ->
2527                                 GetStoreGoal, % nb_getval(StoreName,Store),
2528                                 Store = [_|Tail],
2529                                 UpdateStoreGoal,
2530                                 ( Tail = [NextSusp|_] ->
2531                                         SetGoal1
2532                                 ;
2533                                         true
2534                                 )       
2535                         ;
2536                                 PredCell = [_,_|Tail],
2537                                 setarg(2,PredCell,Tail),
2538                                 ( Tail = [NextSusp|_] ->
2539                                         SetGoal2
2540                                 ;
2541                                         true
2542                                 )       
2543                         )
2544                 )
2545         ).
2546 %       global_ground_store_name(C,StoreName),
2547 %       make_get_store_goal(StoreName,Store,GetStoreGoal),
2548 %       make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
2549 %       Body =
2550 %       (
2551 %               GetStoreGoal, % nb_getval(StoreName,Store),
2552 %               'chr sbag_del_element'(Store,Susp,NStore),
2553 %               UpdateStoreGoal % b_setval(StoreName,NStore)
2554 %       ).
2555 generate_delete_constraint_body(var_assoc_store(VarIndex,AssocIndex),C,Susp,Body) :-
2556         get_target_module(Module),
2557         get_dynamic_suspension_term_field(argument(VarIndex),C,Susp,Variable,VariableGoal),
2558         get_dynamic_suspension_term_field(argument(AssocIndex),C,Susp,Key,KeyGoal),
2559         Body = ( 
2560                 VariableGoal,
2561                 get_attr(Variable,Module,AssocStore),
2562                 KeyGoal,
2563                 delete_assoc_store(AssocStore,Key,Susp)
2564         ).
2565 generate_delete_constraint_body(global_singleton,C,_Susp,Body) :-
2566         global_singleton_store_name(C,StoreName),
2567         make_update_store_goal(StoreName,[],UpdateStoreGoal),
2568         Body =
2569         (
2570                 UpdateStoreGoal  % b_setval(StoreName,[])
2571         ).
2572 generate_delete_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
2573         find_with_var_identity(
2574                 B,
2575                 [Susp],
2576                 (
2577                         member(ST,StoreTypes),
2578                         chr_translate:generate_delete_constraint_body(ST,C,Susp,B)
2579                 ),
2580                 Bodies
2581         ),
2582         list2conj(Bodies,Body).
2584 generate_multi_inthash_delete_constraint_bodies([],_,_,true).
2585 generate_multi_inthash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2586         multi_hash_store_name(FA,Index,StoreName),
2587         multi_hash_key(FA,Index,Susp,KeyBody,Key),
2588         Body =
2589         (
2590                 KeyBody,
2591                 nb_getval(StoreName,Store),
2592                 delete_iht(Store,Key,Susp)
2593         ),
2594         generate_multi_inthash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
2595 generate_multi_hash_delete_constraint_bodies([],_,_,true).
2596 generate_multi_hash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
2597         multi_hash_store_name(FA,Index,StoreName),
2598         multi_hash_key(FA,Index,Susp,KeyBody,Key),
2599         make_get_store_goal(StoreName,Store,GetStoreGoal),
2600         Body =
2601         (
2602                 KeyBody,
2603                 GetStoreGoal, % nb_getval(StoreName,Store),
2604                 delete_ht(Store,Key,Susp)
2605         ),
2606         generate_multi_hash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
2608 generate_delete_constraint_call(FA,Susp,Call) :-
2609         make_name('$delete_from_store_',FA,Functor),
2610         Call =.. [Functor,Susp]. 
2612 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2614 :- chr_constraint 
2615         module_initializer/1,
2616         module_initializers/1.
2618 module_initializers(G), module_initializer(Initializer) <=>
2619         G = (Initializer,Initializers),
2620         module_initializers(Initializers).
2622 module_initializers(G) <=>
2623         G = true.
2625 generate_attach_code(Constraints,[Enumerate|L]) :-
2626         enumerate_stores_code(Constraints,Enumerate),
2627         generate_attach_code(Constraints,L,T),
2628         module_initializers(Initializers),
2629         prolog_global_variables_code(PrologGlobalVariables),
2630         T = [('$chr_initialization' :- Initializers),(:- '$chr_initialization')|PrologGlobalVariables].
2632 generate_attach_code([],L,L).
2633 generate_attach_code([C|Cs],L,T) :-
2634         get_store_type(C,StoreType),
2635         generate_attach_code(StoreType,C,L,L1),
2636         generate_attach_code(Cs,L1,T). 
2638 generate_attach_code(default,C,L,T) :-
2639         global_list_store_initialisation(C,L,T).
2640 generate_attach_code(multi_inthash(Indexes),C,L,T) :-
2641         multi_inthash_store_initialisations(Indexes,C,L,L1),
2642         multi_inthash_via_lookups(Indexes,C,L1,T).
2643 generate_attach_code(multi_hash(Indexes),C,L,T) :-
2644         multi_hash_store_initialisations(Indexes,C,L,L1),
2645         multi_hash_via_lookups(Indexes,C,L1,T).
2646 generate_attach_code(global_ground,C,L,T) :-
2647         global_ground_store_initialisation(C,L,T).
2648 generate_attach_code(var_assoc_store(_,_),_,L,L) :-
2649         use_auxiliary_module(chr_assoc_store).
2650 generate_attach_code(global_singleton,C,L,T) :-
2651         global_singleton_store_initialisation(C,L,T).
2652 generate_attach_code(multi_store(StoreTypes),C,L,T) :-
2653         multi_store_generate_attach_code(StoreTypes,C,L,T).
2655 multi_store_generate_attach_code([],_,L,L).
2656 multi_store_generate_attach_code([ST|STs],C,L,T) :-
2657         generate_attach_code(ST,C,L,L1),
2658         multi_store_generate_attach_code(STs,C,L1,T).   
2660 multi_inthash_store_initialisations([],_,L,L).
2661 multi_inthash_store_initialisations([Index|Indexes],FA,L,T) :-
2662         use_auxiliary_module(chr_integertable_store),
2663         multi_hash_store_name(FA,Index,StoreName),
2664         module_initializer((new_iht(HT),nb_setval(StoreName,HT))),
2665         % L = [(:- (chr_integertable_store:new_ht(HT),nb_setval(StoreName,HT)) )|L1],
2666         L1 = L,
2667         multi_inthash_store_initialisations(Indexes,FA,L1,T).
2668 multi_hash_store_initialisations([],_,L,L).
2669 multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
2670         use_auxiliary_module(chr_hashtable_store),
2671         multi_hash_store_name(FA,Index,StoreName),
2672         prolog_global_variable(StoreName),
2673         make_init_store_goal(StoreName,HT,InitStoreGoal),
2674         module_initializer((new_ht(HT),InitStoreGoal)),
2675         L1 = L,
2676         multi_hash_store_initialisations(Indexes,FA,L1,T).
2678 global_list_store_initialisation(C,L,T) :-
2679         global_list_store_name(C,StoreName),
2680         prolog_global_variable(StoreName),
2681         make_init_store_goal(StoreName,[],InitStoreGoal),
2682         module_initializer(InitStoreGoal),
2683         L = T.
2684 global_ground_store_initialisation(C,L,T) :-
2685         global_ground_store_name(C,StoreName),
2686         prolog_global_variable(StoreName),
2687         make_init_store_goal(StoreName,[],InitStoreGoal),
2688         module_initializer(InitStoreGoal),
2689         L = T.
2690 global_singleton_store_initialisation(C,L,T) :-
2691         global_singleton_store_name(C,StoreName),
2692         prolog_global_variable(StoreName),
2693         make_init_store_goal(StoreName,[],InitStoreGoal),
2694         module_initializer(InitStoreGoal),
2695         L = T.
2697 multi_inthash_via_lookups([],_,L,L).
2698 multi_inthash_via_lookups([Index|Indexes],C,L,T) :-
2699         multi_hash_via_lookup_name(C,Index,PredName),
2700         Head =.. [PredName,Key,SuspsList],
2701         multi_hash_store_name(C,Index,StoreName),
2702         Body = 
2703         (
2704                 nb_getval(StoreName,HT),
2705                 lookup_iht(HT,Key,SuspsList)
2706         ),
2707         L = [(Head :- Body)|L1],
2708         multi_inthash_via_lookups(Indexes,C,L1,T).
2709 multi_hash_via_lookups([],_,L,L).
2710 multi_hash_via_lookups([Index|Indexes],C,L,T) :-
2711         multi_hash_via_lookup_name(C,Index,PredName),
2712         Head =.. [PredName,Key,SuspsList],
2713         multi_hash_store_name(C,Index,StoreName),
2714         make_get_store_goal(StoreName,HT,GetStoreGoal),
2715         Body = 
2716         (
2717                 GetStoreGoal, % nb_getval(StoreName,HT),
2718                 lookup_ht(HT,Key,SuspsList)
2719         ),
2720         L = [(Head :- Body)|L1],
2721         multi_hash_via_lookups(Indexes,C,L1,T).
2723 multi_hash_via_lookup_name(F/A,Index,Name) :-
2724         ( integer(Index) ->
2725                 IndexName = Index
2726         ; is_list(Index) ->
2727                 atom_concat_list(Index,IndexName)
2728         ),
2729         atom_concat_list(['$via1_multi_hash_',F,(/),A,'-',IndexName],Name).
2731 multi_hash_store_name(F/A,Index,Name) :-
2732         get_target_module(Mod),         
2733         ( integer(Index) ->
2734                 IndexName = Index
2735         ; is_list(Index) ->
2736                 atom_concat_list(Index,IndexName)
2737         ),
2738         atom_concat_list(['$chr_store_multi_hash_',Mod,(:),F,(/),A,'-',IndexName],Name).
2740 multi_hash_key(FA,Index,Susp,KeyBody,Key) :-
2741         ( ( integer(Index) ->
2742                 I = Index
2743           ; 
2744                 Index = [I]
2745           ) ->
2746                 get_dynamic_suspension_term_field(argument(I),FA,Susp,Key,KeyBody)
2747         ; is_list(Index) ->
2748                 sort(Index,Indexes),
2749                 find_with_var_identity(Goal-KeyI,[Susp],(member(I,Indexes),get_dynamic_suspension_term_field(argument(I),FA,Susp,KeyI,Goal)),ArgKeyPairs), 
2750                 once(pairup(Bodies,Keys,ArgKeyPairs)),
2751                 Key =.. [k|Keys],
2752                 list2conj(Bodies,KeyBody)
2753         ).
2755 multi_hash_key_direct(FA,Index,Susp,Key,UsedVars) :-
2756         ( ( integer(Index) ->
2757                 I = Index
2758           ; 
2759                 Index = [I]
2760           ) ->
2761                 UsedVars = [I-Key]
2762         ; is_list(Index) ->
2763                 sort(Index,Indexes),
2764                 pairup(Indexes,Keys,UsedVars),
2765                 Key =.. [k|Keys]
2766         ).
2768 multi_hash_key_args(Index,Head,KeyArgs) :-
2769         ( integer(Index) ->
2770                 arg(Index,Head,Arg),
2771                 KeyArgs = [Arg]
2772         ; is_list(Index) ->
2773                 sort(Index,Indexes),
2774                 term_variables(Head,Vars),
2775                 find_with_var_identity(Arg,Vars,(member(I,Indexes), arg(I,Head,Arg)),KeyArgs)
2776         ).
2777                 
2778 global_list_store_name(F/A,Name) :-
2779         get_target_module(Mod),         
2780         atom_concat_list(['$chr_store_global_list_',Mod,(:),F,(/),A],Name).
2781 global_ground_store_name(F/A,Name) :-
2782         get_target_module(Mod),         
2783         atom_concat_list(['$chr_store_global_ground_',Mod,(:),F,(/),A],Name).
2784 global_singleton_store_name(F/A,Name) :-
2785         get_target_module(Mod),         
2786         atom_concat_list(['$chr_store_global_singleton_',Mod,(:),F,(/),A],Name).
2788 :- chr_constraint
2789         prolog_global_variable/1,
2790         prolog_global_variables/1.
2792 :- chr_option(mode,prolog_global_variable(+)).
2793 :- chr_option(mode,prolog_global_variable(2)).
2795 prolog_global_variable(Name) \ prolog_global_variable(Name) <=> true.
2797 prolog_global_variables(List), prolog_global_variable(Name) <=> 
2798         List = [Name|Tail],
2799         prolog_global_variables(Tail).
2800 prolog_global_variables(List) <=> List = [].
2802 %% SWI begin
2803 prolog_global_variables_code(Code) :-
2804         prolog_global_variables(Names),
2805         ( Names == [] ->
2806                 Code = []
2807         ;
2808                 findall('$chr_prolog_global_variable'(Name),member(Name,Names),NameDeclarations),
2809                 Code = [(:- dynamic user:exception/3),
2810                         (:- multifile user:exception/3),
2811                         (user:exception(undefined_global_variable,Name,retry) :-
2812                                 (
2813                                 '$chr_prolog_global_variable'(Name),
2814                                 '$chr_initialization'
2815                                 )
2816                         )
2817                         |
2818                         NameDeclarations
2819                         ]
2820         ).
2821 %% SWI end
2822 %% SICStus begin
2823 prolog_global_variables_code([]).
2824 %% SICStus end
2825 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2826 %sbag_member_call(S,L,sysh:mem(S,L)).
2827 sbag_member_call(S,L,'chr sbag_member'(S,L)).
2828 %sbag_member_call(S,L,member(S,L)).
2829 update_mutable_call(A,B,'chr update_mutable'( A, B)).
2830 %update_mutable_call(A,B,setarg(1, B, A)).
2831 create_mutable_call(Value,Mutable,true) :- Mutable = mutable(Value).
2832 % create_mutable_call(Value,Mutable,'chr create_mutable'(Value,Mutable)).
2834 % get_suspension_field(Constraint,Susp,FieldName,Value,(Get0,Get1)) :-
2835 %       get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
2836 %       create_get_mutable(Value,Field,Get1).
2838 % update_suspension_field(Constraint,Susp,FieldName,NewValue,(Get,Set)) :-
2839 %       get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get),
2840 %         update_mutable_call(NewValue,Field,Set).
2842 % get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,Get0,Get1,Set) :-
2843 %       get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Field,Get0),
2844 %       create_get_mutable_ref(Value,Field,Get1),
2845 %         update_mutable_call(NewValue,Field,Set).
2847 % create_static_suspension_field(Constraint,Susp,FieldName,Value,Create) :-
2848 %       get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
2849 %       create_mutable_call(Value,Field,Create).
2851 % get_static_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
2852 %       get_static_suspension_term_field(FieldName,Constraint,Susp,Field),
2853 %       create_get_mutable(Value,Field,Get).
2855 % get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,Get,Set) :-
2856 %       get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Field),
2857 %       create_get_mutable_ref(Value,Field,Get),
2858 %       update_mutable_call(NewValue,Field,Set).
2860 get_suspension_field(Constraint,Susp,FieldName,Value,Get) :-
2861         get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get).
2863 update_suspension_field(Constraint,Susp,FieldName,NewValue,Set) :-
2864         set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
2866 get_update_suspension_field(Constraint,Susp,FieldName,Value,NewValue,true,Get,Set) :-
2867         get_dynamic_suspension_term_field(FieldName,Constraint,Susp,Value,Get),
2868         set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
2870 create_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
2871         get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
2873 get_static_suspension_field(Constraint,Susp,FieldName,Value,true) :-
2874         get_static_suspension_term_field(FieldName,Constraint,Susp,Value).
2876 get_update_static_suspension_field(Constraint,Susp,SuspTerm,FieldName,Value,NewValue,true,Set) :-
2877         get_static_suspension_term_field(FieldName,Constraint,SuspTerm,Value),
2878         set_dynamic_suspension_term_field(FieldName,Constraint,Susp,NewValue,Set).
2880 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2882 enumerate_stores_code(Constraints,Clause) :-
2883         Head = '$enumerate_constraints'(Constraint),
2884         enumerate_store_bodies(Constraints,Constraint,Bodies),
2885         list2disj(Bodies,Body),
2886         Clause = (Head :- Body).        
2888 enumerate_store_bodies([],_,[]).
2889 enumerate_store_bodies([C|Cs],Constraint,L) :-
2890         ( is_stored(C) ->
2891                 get_store_type(C,StoreType),
2892                 enumerate_store_body(StoreType,C,Suspension,SuspensionBody),
2893                 get_dynamic_suspension_term_field(arguments,C,Suspension,Arguments,DynamicGoal),
2894                 C = F/_,
2895                 Constraint0 =.. [F|Arguments],
2896                 Body = (SuspensionBody, DynamicGoal, Constraint = Constraint0),
2897                 L = [Body|T]
2898         ;
2899                 L = T
2900         ),
2901         enumerate_store_bodies(Cs,Constraint,T).
2903 enumerate_store_body(default,C,Susp,Body) :-
2904         global_list_store_name(C,StoreName),
2905         sbag_member_call(Susp,List,Sbag),
2906         make_get_store_goal(StoreName,List,GetStoreGoal),
2907         Body =
2908         (
2909                 GetStoreGoal, % nb_getval(StoreName,List),
2910                 Sbag
2911         ).
2912 %       get_constraint_index(C,Index),
2913 %       get_target_module(Mod),
2914 %       get_max_constraint_index(MaxIndex),
2915 %       Body1 = 
2916 %       (
2917 %               'chr default_store'(GlobalStore),
2918 %               get_attr(GlobalStore,Mod,Attr)
2919 %       ),
2920 %       ( MaxIndex > 1 ->
2921 %               NIndex is Index + 1,
2922 %               sbag_member_call(Susp,List,Sbag),
2923 %               Body2 = 
2924 %               (
2925 %                       arg(NIndex,Attr,List),
2926 %                       Sbag
2927 %               )
2928 %       ;
2929 %               sbag_member_call(Susp,Attr,Sbag),
2930 %               Body2 = Sbag
2931 %       ),
2932 %       Body = (Body1,Body2).
2933 enumerate_store_body(multi_inthash([Index|_]),C,Susp,Body) :-
2934         multi_inthash_enumerate_store_body(Index,C,Susp,Body).
2935 enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
2936         multi_hash_enumerate_store_body(Index,C,Susp,Body).
2937 enumerate_store_body(global_ground,C,Susp,Body) :-
2938         global_ground_store_name(C,StoreName),
2939         sbag_member_call(Susp,List,Sbag),
2940         make_get_store_goal(StoreName,List,GetStoreGoal),
2941         Body =
2942         (
2943                 GetStoreGoal, % nb_getval(StoreName,List),
2944                 Sbag
2945         ).
2946 enumerate_store_body(var_assoc_store(_,_),C,_,Body) :-
2947         Body = fail.
2948 enumerate_store_body(global_singleton,C,Susp,Body) :-
2949         global_singleton_store_name(C,StoreName),
2950         make_get_store_goal(StoreName,Susp,GetStoreGoal),
2951         Body =
2952         (
2953                 GetStoreGoal, % nb_getval(StoreName,Susp),
2954                 Susp \== []
2955         ).
2956 enumerate_store_body(multi_store(STs),C,Susp,Body) :-
2957         once((
2958                 member(ST,STs),
2959                 enumerate_store_body(ST,C,Susp,Body)
2960         )).
2962 multi_inthash_enumerate_store_body(I,C,Susp,B) :-
2963         multi_hash_store_name(C,I,StoreName),
2964         B =
2965         (
2966                 nb_getval(StoreName,HT),
2967                 value_iht(HT,Susp)      
2968         ).
2969 multi_hash_enumerate_store_body(I,C,Susp,B) :-
2970         multi_hash_store_name(C,I,StoreName),
2971         make_get_store_goal(StoreName,HT,GetStoreGoal),
2972         B =
2973         (
2974                 GetStoreGoal, % nb_getval(StoreName,HT),
2975                 value_ht(HT,Susp)       
2976         ).
2978 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2981 :- chr_constraint
2982         prev_guard_list/7,
2983         simplify_guards/1,
2984         set_all_passive/1.
2986 :- chr_option(mode,prev_guard_list(+,+,+,+,+,+,+)).
2987 :- chr_option(mode,simplify_guards(+)).
2988 :- chr_option(mode,set_all_passive(+)).
2989         
2990 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2991 %    GUARD SIMPLIFICATION
2992 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2993 % If the negation of the guards of earlier rules entails (part of)
2994 % the current guard, the current guard can be simplified. We can only
2995 % use earlier rules with a head that matches if the head of the current
2996 % rule does, and which make it impossible for the current rule to match
2997 % if they fire (i.e. they shouldn't be propagation rules and their
2998 % head constraints must be subsets of those of the current rule).
2999 % At this point, we know for sure that the negation of the guard
3000 % of such a rule has to be true (otherwise the earlier rule would have
3001 % fired, because of the refined operational semantics), so we can use
3002 % that information to simplify the guard by replacing all entailed
3003 % conditions by true/0. As a consequence, the never-stored analysis
3004 % (in a further phase) will detect more cases of never-stored constraints.
3006 % e.g.      c(X),d(Y) <=> X > 0 | ...
3007 %           e(X) <=> X < 0 | ...
3008 %           c(X) \ d(Y),e(Z) <=> X =< 0, Z >= 0, ... | ...  
3009 %                                \____________/
3010 %                                    true
3012 guard_simplification :- 
3013     ( chr_pp_flag(guard_simplification,on) ->
3014         multiple_occ_constraints_checked([]),
3015         simplify_guards(1)
3016     ;
3017         true
3018     ).
3020 % for every rule, we create a prev_guard_list where the last argument
3021 % eventually is a list of the negations of earlier guards
3022 rule(RuleNb,Rule) \ simplify_guards(RuleNb) <=> 
3023     Rule = pragma(rule(Head1,Head2,G,_B),_Ids,_Pragmas,_Name,RuleNb),
3024     append(Head1,Head2,Heads),
3025     make_head_matchings_explicit_not_negated(Heads,UniqueVarsHeads,Matchings),
3026     add_guard_to_head(Heads,G,GHeads),
3027     PrevRule is RuleNb-1,
3028     prev_guard_list(RuleNb,PrevRule,UniqueVarsHeads,G,[],Matchings,[GHeads]),
3029     multiple_occ_constraints_checked([]),
3030     NextRule is RuleNb+1, simplify_guards(NextRule).
3032 simplify_guards(_) <=> true.
3034 % the negation of the guard of a non-propagation rule is added
3035 % if its kept head constraints are a subset of the kept constraints of
3036 % the rule we're working on, and its removed head constraints (at least one)
3037 % are a subset of the removed constraints
3038 rule(N,Rule) \ prev_guard_list(RuleNb,N,H,G,GuardList,M,GH) <=>
3039     Rule = pragma(rule(H1,H2,G2,_B),_Ids,_Pragmas,_Name,N),
3040     H1 \== [], 
3041     append(H1,H2,Heads),
3042     make_head_matchings_explicit(Heads,UniqueVarsHeads,Matchings),
3043     setof(Renaming,chr_translate:head_subset(UniqueVarsHeads,H,Renaming),Renamings),
3044     Renamings \= []
3045     |
3046     compute_derived_info(Matchings,Renamings,UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo,GH_New1),
3047     append(GuardList,DerivedInfo,GL1),
3048     list2conj(GL1,GL_),
3049     conj2list(GL_,GL),
3050     append(GH_New1,GH,GH1),
3051     list2conj(GH1,GH_),
3052     conj2list(GH_,GH_New),
3053     N1 is N-1,
3054     prev_guard_list(RuleNb,N1,H,G,GL,M,GH_New).
3057 % if this isn't the case, we skip this one and try the next rule
3058 prev_guard_list(RuleNb,N,H,G,GuardList,M,GH) <=> N > 0 |
3059     N1 is N-1, prev_guard_list(RuleNb,N1,H,G,GuardList,M,GH).
3061 prev_guard_list(RuleNb,0,H,G,GuardList,M,GH) <=>
3062     GH \== [] |
3063     add_type_information_(H,GH,TypeInfo),
3064     conj2list(TypeInfo,TI),
3065     term_variables(H,HeadVars),    
3066     append([chr_pp_headvariables(HeadVars)|TI],GuardList,Info),
3067     list2conj(Info,InfoC),
3068     conj2list(InfoC,InfoL),
3069     prev_guard_list(RuleNb,0,H,G,InfoL,M,[]).
3071 add_type_information_(H,[],true) :- !.
3072 add_type_information_(H,[GH|GHs],TI) :- !,
3073     add_type_information(H,GH,TI1),
3074     TI = (TI1, TI2),
3075     add_type_information_(H,GHs,TI2).
3077 % when all earlier guards are added or skipped, we simplify the guard.
3078 % if it's different from the original one, we change the rule
3079 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]), rule(RuleNb,Rule) <=> 
3080     Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
3081     G \== true,         % let's not try to simplify this ;)
3082     append(M,GuardList,Info),
3083     simplify_guard(G,B,Info,SimpleGuard,NB),
3084     G \== SimpleGuard     |
3085     rule(RuleNb,pragma(rule(Head1,Head2,SimpleGuard,NB),Ids,Pragmas,Name,RuleNb)),
3086     prev_guard_list(RuleNb,0,H,SimpleGuard,GuardList,M,[]).
3089 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3090 %    AUXILIARY PREDICATES       (GUARD SIMPLIFICATION)
3091 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3093 compute_derived_info(Matchings,[],UniqueVarsHeads,Heads,G2,M,H,GH,[],[]) :- !.
3095 compute_derived_info(Matchings,[Renaming1|RR],UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo,GH_New) :- !,
3096     copy_term(Matchings-G2,FreshMatchings),
3097     variable_replacement(Matchings-G2,FreshMatchings,ExtraRenaming),
3098     append(Renaming1,ExtraRenaming,Renaming2),  
3099     list2conj(Matchings,Match),
3100     negate_b(Match,HeadsDontMatch),
3101     make_head_matchings_explicit_not_negated2(Heads,UniqueVarsHeads,HeadsMatch),
3102     list2conj(HeadsMatch,HeadsMatchBut),
3103     term_variables(Renaming2,RenVars),
3104     term_variables(Matchings-G2-HeadsMatch,MGVars),
3105     new_vars(MGVars,RenVars,ExtraRenaming2),
3106     append(Renaming2,ExtraRenaming2,Renaming),
3107     negate_b(G2,TheGuardFailed),
3108     ( G2 == true ->             % true can't fail
3109         Info_ = HeadsDontMatch
3110     ;
3111         Info_ = (HeadsDontMatch ; (HeadsMatchBut, TheGuardFailed))
3112     ),
3113     copy_with_variable_replacement(Info_,DerivedInfo1,Renaming),
3114     copy_with_variable_replacement(G2,RenamedG2,Renaming),
3115     copy_with_variable_replacement(Matchings,RenamedMatchings_,Renaming),
3116     list2conj(RenamedMatchings_,RenamedMatchings),
3117     add_guard_to_head(H,RenamedG2,GH2),
3118     add_guard_to_head(GH2,RenamedMatchings,GH3),
3119     compute_derived_info(Matchings,RR,UniqueVarsHeads,Heads,G2,M,H,GH,DerivedInfo2,GH_New2),
3120     append([DerivedInfo1],DerivedInfo2,DerivedInfo),
3121     append([GH3],GH_New2,GH_New).
3124 simplify_guard(G,B,Info,SG,NB) :-
3125     conj2list(G,LG),
3126     guard_entailment:simplify_guards(Info,B,LG,SGL,NB),
3127     list2conj(SGL,SG).
3130 new_vars([],_,[]).
3131 new_vars([A|As],RV,ER) :-
3132     ( memberchk_eq(A,RV) ->
3133         new_vars(As,RV,ER)
3134     ;
3135         ER = [A-NewA,NewA-A|ER2],
3136         new_vars(As,RV,ER2)
3137     ).
3138     
3139 % check if a list of constraints is a subset of another list of constraints
3140 % (multiset-subset), meanwhile computing a variable renaming to convert
3141 % one into the other.
3142 head_subset(H,Head,Renaming) :-
3143     head_subset(H,Head,Renaming,[],_).
3145 % empty list is a subset of everything    
3146 head_subset([],Head,Renaming,Cumul,Headleft) :- !,
3147     Renaming = Cumul,
3148     Headleft = Head.
3150 % first constraint has to be in the list, the rest has to be a subset
3151 % of the list with one occurrence of the first constraint removed
3152 % (has to be multiset-subset)
3153 head_subset([A|B],Head,Renaming,Cumul,Headleft) :- !,
3154     head_subset(A,Head,R1,Cumul,Headleft1),
3155     head_subset(B,Headleft1,R2,R1,Headleft2),
3156     Renaming = R2,
3157     Headleft = Headleft2.
3159 % check if A is in the list, remove it from Headleft
3160 head_subset(A,[X|Y],Renaming,Cumul,Headleft) :- !,
3161     ( head_subset(A,X,R1,Cumul,HL1),
3162         Renaming = R1,
3163         Headleft = Y
3164     ;
3165         head_subset(A,Y,R2,Cumul,HL2),
3166         Renaming = R2,
3167         Headleft = [X|HL2]
3168     ).
3170 % A is X if there's a variable renaming to make them identical
3171 head_subset(A,X,Renaming,Cumul,Headleft) :-
3172     variable_replacement(A,X,Cumul,Renaming),
3173     Headleft = [].
3175 make_head_matchings_explicit(Heads,UniqueVarsHeads,Matchings) :-
3176     extract_variables(Heads,VH1),
3177     make_matchings_explicit(VH1,H1_,[],[],_,Matchings),
3178     insert_variables(H1_,Heads,UniqueVarsHeads).
3180 make_head_matchings_explicit_not_negated(Heads,UniqueVarsHeads,Matchings) :-
3181     extract_variables(Heads,VH1),
3182     make_matchings_explicit_not_negated(VH1,H1_,[],Matchings),
3183     insert_variables(H1_,Heads,UniqueVarsHeads).
3185 make_head_matchings_explicit_not_negated2(Heads,UniqueVarsHeads,Matchings) :-
3186     extract_variables(Heads,VH1),
3187     extract_variables(UniqueVarsHeads,UV),
3188     make_matchings_explicit_not_negated(VH1,UV,[],Matchings).
3191 extract_variables([],[]).
3192 extract_variables([X|R],V) :-
3193     X =.. [_|Args],
3194     extract_variables(R,V2),
3195     append(Args,V2,V).
3197 insert_variables([],[],[]) :- !.
3198 insert_variables(Vars,[C|R],[C2|R2]) :-
3199     C =.. [F | Args],
3200     length(Args,N),
3201     take_first_N(Vars,N,Args2,RestVars),
3202     C2 =.. [F | Args2],
3203     insert_variables(RestVars,R,R2).
3205 take_first_N(Vars,0,[],Vars) :- !.
3206 take_first_N([X|R],N,[X|R2],RestVars) :-
3207     N1 is N-1,
3208     take_first_N(R,N1,R2,RestVars).
3210 make_matchings_explicit([],[],_,MC,MC,[]).
3211 make_matchings_explicit([X|R],[NewVar|R2],C,MC,MCO,M) :-
3212     ( var(X) ->
3213         ( memberchk_eq(X,C) ->
3214             list2disj(MC,MC_disj),
3215             M = [(MC_disj ; NewVar == X)|M2],           % or only =    ??
3216             C2 = C
3217         ;
3218             M = M2,
3219             NewVar = X,
3220             C2 = [X|C]
3221         ),
3222         MC2 = MC
3223     ;
3224         functor(X,F,A),
3225         X =.. [F|Args],
3226         make_matchings_explicit(Args,NewArgs,C,MC,MC_,ArgM),
3227         X_ =.. [F|NewArgs],
3228         (ArgM == [] ->
3229             M = [functor(NewVar,F,A) |M2]
3230         ;
3231             list2conj(ArgM,ArgM_conj),
3232             list2disj(MC,MC_disj),
3233             ArgM_ = (NewVar \= X_ ; MC_disj ; ArgM_conj),
3234             M = [ functor(NewVar,F,A) , ArgM_|M2]
3235         ),
3236         MC2 = [ NewVar \= X_ |MC_],
3237         term_variables(Args,ArgVars),
3238         append(C,ArgVars,C2)
3239     ),
3240     make_matchings_explicit(R,R2,C2,MC2,MCO,M2).
3241     
3243 make_matchings_explicit_not_negated([],[],_,[]).
3244 make_matchings_explicit_not_negated([X|R],[NewVar|R2],C,M) :-
3245     M = [NewVar = X|M2],
3246     C2 = C,
3247     make_matchings_explicit_not_negated(R,R2,C2,M2).
3250 add_guard_to_head([],G,[]).
3251 add_guard_to_head([H|RH],G,[GH|RGH]) :-
3252     (var(H) ->
3253         find_guard_info_for_var(H,G,GH)
3254     ;
3255         functor(H,F,A),
3256         H =.. [F|HArgs],
3257         add_guard_to_head(HArgs,G,NewHArgs),
3258         GH =.. [F|NewHArgs]
3259     ),
3260     add_guard_to_head(RH,G,RGH).
3262 find_guard_info_for_var(H,(G1,G2),GH) :- !,
3263     find_guard_info_for_var(H,G1,GH1),
3264     find_guard_info_for_var(GH1,G2,GH).
3265     
3266 find_guard_info_for_var(H,G,GH) :-
3267     (G = (H1 = A), H == H1 ->
3268         GH = A
3269     ;
3270         (G = functor(H2,HF,HA), H == H2, ground(HF), ground(HA) ->
3271             length(GHArg,HA),
3272             GH =.. [HF|GHArg]
3273         ;
3274             GH = H
3275         )
3276     ).
3278 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3279 %    ALWAYS FAILING HEADS
3280 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3282 rule(RuleNb,Rule) \ prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) <=> 
3283     chr_pp_flag(check_impossible_rules,on),
3284     Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
3285     append(M,GuardList,Info),
3286     guard_entailment:entails_guard(Info,fail) |
3287     chr_warning(weird_program,'Heads will never match in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
3288     set_all_passive(RuleNb).
3290 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3291 %    HEAD SIMPLIFICATION
3292 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3294 % now we check the head matchings  (guard may have been simplified meanwhile)
3295 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]) \ rule(RuleNb,Rule) <=> 
3296     Rule = pragma(rule(Head1,Head2,G,B),Ids,Pragmas,Name,RuleNb),
3297     simplify_heads(M,GuardList,G,B,NewM,NewB),
3298     NewM \== [],
3299     extract_variables(Head1,VH1),
3300     extract_variables(Head2,VH2),
3301     extract_variables(H,VH),
3302     replace_some_heads(VH1,VH2,VH,NewM,H1,H2,G,B,NewB_),
3303     insert_variables(H1,Head1,NewH1),
3304     insert_variables(H2,Head2,NewH2),
3305     append(NewB,NewB_,NewBody),
3306     list2conj(NewBody,BodyMatchings),
3307     NewRule = pragma(rule(NewH1,NewH2,G,(BodyMatchings,B)),Ids,Pragmas,Name,RuleNb),
3308     (Head1 \== NewH1 ; Head2 \== NewH2 )    
3309     |
3310     rule(RuleNb,NewRule).    
3314 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3315 %    AUXILIARY PREDICATES       (HEAD SIMPLIFICATION)
3316 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3318 replace_some_heads(H1,H2,NH,[],H1,H2,G,Body,[]) :- !.
3319 replace_some_heads([],[H2|RH2],[NH|RNH],[M|RM],[],[H2_|RH2_],G,Body,NewB) :- !,
3320     ( NH == M ->
3321         H2_ = M,
3322         replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB)
3323     ;
3324         (M = functor(X,F,A), NH == X ->
3325             length(A_args,A),
3326             (var(H2) ->
3327                 NewB1 = [],
3328                 H2_ =.. [F|A_args]
3329             ;
3330                 H2 =.. [F|OrigArgs],
3331                 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
3332                 H2_ =.. [F|A_args_]
3333             ),
3334             replace_some_heads([],RH2,RNH,RM,[],RH2_,G,Body,NewB2),
3335             append(NewB1,NewB2,NewB)    
3336         ;
3337             H2_ = H2,
3338             replace_some_heads([],RH2,RNH,[M|RM],[],RH2_,G,Body,NewB)
3339         )
3340     ).
3342 replace_some_heads([H1|RH1],H2,[NH|RNH],[M|RM],[H1_|RH1_],H2_,G,Body,NewB) :- !,
3343     ( NH == M ->
3344         H1_ = M,
3345         replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB)
3346     ;
3347         (M = functor(X,F,A), NH == X ->
3348             length(A_args,A),
3349             (var(H1) ->
3350                 NewB1 = [],
3351                 H1_ =.. [F|A_args]
3352             ;
3353                 H1 =.. [F|OrigArgs],
3354                 use_same_args(OrigArgs,A_args,A_args_,G,Body,NewB1),
3355                 H1_ =.. [F|A_args_]
3356             ),
3357             replace_some_heads(RH1,H2,RNH,RM,RH1_,H2_,G,Body,NewB2),
3358             append(NewB1,NewB2,NewB)
3359         ;
3360             H1_ = H1,
3361             replace_some_heads(RH1,H2,RNH,[M|RM],RH1_,H2_,G,Body,NewB)
3362         )
3363     ).
3365 use_same_args([],[],[],_,_,[]).
3366 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
3367     var(OA),!,
3368     Out = OA,
3369     use_same_args(ROA,RNA,ROut,G,Body,NewB).
3370 use_same_args([OA|ROA],[NA|RNA],[Out|ROut],G,Body,NewB) :-
3371     nonvar(OA),!,
3372     ( vars_occur_in(OA,Body) ->
3373         NewB = [NA = OA|NextB]
3374     ;
3375         NewB = NextB
3376     ),
3377     Out = NA,
3378     use_same_args(ROA,RNA,ROut,G,Body,NextB).
3380     
3381 simplify_heads([],_GuardList,_G,_Body,[],[]).
3382 simplify_heads([M|RM],GuardList,G,Body,NewM,NewB) :-
3383     M = (A = B),
3384     ( (nonvar(B) ; vars_occur_in(B,RM-GuardList)),
3385         guard_entailment:entails_guard(GuardList,(A=B)) ->
3386         ( vars_occur_in(B,G-RM-GuardList) ->
3387             NewB = NextB,
3388             NewM = NextM
3389         ;
3390             ( vars_occur_in(B,Body) ->
3391                 NewB = [A = B|NextB]
3392             ;
3393                 NewB = NextB
3394             ),
3395             NewM = [A|NextM]
3396         )
3397     ;
3398         ( nonvar(B), functor(B,BFu,BAr),
3399           guard_entailment:entails_guard([functor(A,BFu,BAr)|GuardList],(A=B)) ->
3400             NewB = NextB,
3401             ( vars_occur_in(B,G-RM-GuardList) ->
3402                 NewM = NextM
3403             ;
3404                 NewM = [functor(A,BFu,BAr)|NextM]
3405             )
3406         ;
3407             NewM = NextM,
3408             NewB = NextB
3409         )
3410     ),
3411     simplify_heads(RM,[M|GuardList],G,Body,NextM,NextB).
3413 vars_occur_in(B,G) :-
3414     term_variables(B,BVars),
3415     term_variables(G,GVars),
3416     intersect_eq(BVars,GVars,L),
3417     L \== [].
3420 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3421 %    ALWAYS FAILING GUARDS
3422 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3424 set_all_passive(RuleNb), occurrence(_,_,RuleNb,ID,_) ==> passive(RuleNb,ID).
3425 set_all_passive(_) <=> true.
3427 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),rule(RuleNb,Rule) ==> 
3428     chr_pp_flag(check_impossible_rules,on),
3429     Rule = pragma(rule(_,_,G,_),_Ids,_Pragmas,_Name,RuleNb),
3430     conj2list(G,GL),
3431     guard_entailment:entails_guard(GL,fail) |
3432     chr_warning(weird_program,'Guard will always fail in ~@.\n\tThis rule will never fire!\n',[format_rule(Rule)]),
3433     set_all_passive(RuleNb).
3437 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3438 %    OCCURRENCE SUBSUMPTION
3439 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3441 :- chr_constraint
3442         first_occ_in_rule/4,
3443         next_occ_in_rule/6,
3444         multiple_occ_constraints_checked/1.
3446 :- chr_option(mode,first_occ_in_rule(+,+,+,+)).
3447 :- chr_option(mode,next_occ_in_rule(+,+,+,+,+,+)).
3448 :- chr_option(mode,multiple_occ_constraints_checked(+)).
3452 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
3453 occurrence(C,O,RuleNb,ID,_), occurrence(C,O2,RuleNb,ID2,_), rule(RuleNb,Rule)
3454 \ multiple_occ_constraints_checked(Done) <=>
3455     O < O2, 
3456     chr_pp_flag(occurrence_subsumption,on),
3457     Rule = pragma(rule(H1,H2,_G,_B),_Ids,_Pragmas,_Name,RuleNb),
3458     H1 \== [],
3459     \+ memberchk_eq(C,Done) |
3460     first_occ_in_rule(RuleNb,C,O,ID),
3461     multiple_occ_constraints_checked([C|Done]).
3464 occurrence(C,O,RuleNb,ID,_) \ first_occ_in_rule(RuleNb,C,O2,_) <=> O < O2 | 
3465     first_occ_in_rule(RuleNb,C,O,ID).
3467 first_occ_in_rule(RuleNb,C,O,ID_o1) <=> 
3468     C = F/A,
3469     functor(FreshHead,F,A),
3470     next_occ_in_rule(RuleNb,C,O,ID_o1,[],FreshHead).
3472 passive(RuleNb,ID_o2), occurrence(C,O2,RuleNb,ID_o2,_)
3473 \ next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=> O2 is O+1 |
3474     next_occ_in_rule(RuleNb,C,O2,ID_o1,NewCond,FH).
3477 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
3478 occurrence(C,O2,RuleNb,ID_o2,_), rule(RuleNb,Rule) \ 
3479 next_occ_in_rule(RuleNb,C,O,ID_o1,Cond,FH) <=>
3480     O2 is O+1,
3481     Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb)
3482     |
3483     append(H1,H2,Heads),
3484     add_failing_occ(Rule,Heads,H,ID_o1,ExtraCond,FH,M,C,Repl),
3485     ( ExtraCond == [chr_pp_void_info] ->
3486         next_occ_in_rule(RuleNb,C,O2,ID_o2,Cond,FH)
3487     ;
3488         append(ExtraCond,Cond,NewCond),
3489         add_failing_occ(Rule,Heads,H,ID_o2,CheckCond,FH,M,C,Repl2),
3490         copy_term(GuardList,FGuardList),
3491         variable_replacement(GuardList,FGuardList,GLRepl),
3492         copy_with_variable_replacement(GuardList,GuardList2,Repl),
3493         copy_with_variable_replacement(GuardList,GuardList3_,Repl2),
3494         copy_with_variable_replacement(GuardList3_,GuardList3,GLRepl),
3495         append(NewCond,GuardList2,BigCond),
3496         append(BigCond,GuardList3,BigCond2),
3497         copy_with_variable_replacement(M,M2,Repl),
3498         copy_with_variable_replacement(M,M3,Repl2),
3499         append(M3,BigCond2,BigCond3),
3500         append([chr_pp_active_constraint(FH)|M2],BigCond3,Info),
3501         list2conj(CheckCond,OccSubsum),
3502         copy_term((NewCond,BigCond2,Info,OccSubsum,FH),(NewCond2,BigCond2_,Info2,OccSubsum2,FH2)),
3503         term_variables(NewCond2-FH2,InfoVars),
3504         flatten_stuff(Info2,Info3),
3505         flatten_stuff(OccSubsum2,OccSubsum3),
3506         ( OccSubsum \= chr_pp_void_info, 
3507         unify_stuff(InfoVars,Info3,OccSubsum3), !,
3508         ( guard_entailment:entails_guard(Info2,OccSubsum2) ->
3509             passive(RuleNb,ID_o2)
3510         ; 
3511             true
3512         )
3513         ; true 
3514         ),!,
3515         next_occ_in_rule(RuleNb,C,O2,ID_o2,NewCond,FH)
3516     ).
3519 next_occ_in_rule(RuleNb,C,O,ID,Cond,Args) <=> true.
3520 prev_guard_list(RuleNb,0,H,G,GuardList,M,[]),
3521 multiple_occ_constraints_checked(Done) <=> true.
3523 flatten_stuff([A|B],C) :- !,
3524     flatten_stuff(A,C1),
3525     flatten_stuff(B,C2),
3526     append(C1,C2,C).
3527 flatten_stuff((A;B),C) :- !,
3528     flatten_stuff(A,C1),
3529     flatten_stuff(B,C2),
3530     append(C1,C2,C).
3531 flatten_stuff((A,B),C) :- !,
3532     flatten_stuff(A,C1),
3533     flatten_stuff(B,C2),
3534     append(C1,C2,C).
3535     
3536 flatten_stuff(chr_pp_not_in_store(A),[A]) :- !.
3537 flatten_stuff(X,[]).
3539 unify_stuff(AllInfo,[],[]).
3541 unify_stuff(AllInfo,[H|RInfo],[I|ROS]) :- 
3542     H \== I,
3543     term_variables(H,HVars),
3544     term_variables(I,IVars),
3545     intersect_eq(HVars,IVars,SharedVars),
3546     check_safe_unif(H,I,SharedVars),
3547     variable_replacement(H,I,Repl),
3548     check_replacement(Repl),
3549     term_variables(Repl,ReplVars),
3550     list_difference_eq(ReplVars,HVars,LDiff),
3551     intersect_eq(AllInfo,LDiff,LDiff2),
3552     LDiff2 == [],
3553     H = I,
3554     unify_stuff(AllInfo,RInfo,ROS),!.
3555     
3556 unify_stuff(AllInfo,X,[Y|ROS]) :-
3557     unify_stuff(AllInfo,X,ROS).
3559 unify_stuff(AllInfo,[Y|RInfo],X) :-
3560     unify_stuff(AllInfo,RInfo,X).
3562 check_safe_unif(H,I,SV) :- var(H), !, var(I),
3563     ( (memberchk_eq(H,SV);memberchk_eq(I,SV)) ->
3564         H == I
3565     ;
3566         true
3567     ).
3569 check_safe_unif([],[],SV) :- !.
3570 check_safe_unif([H|Hs],[I|Is],SV) :-  !,
3571     check_safe_unif(H,I,SV),!,
3572     check_safe_unif(Hs,Is,SV).
3573     
3574 check_safe_unif(H,I,SV) :-
3575     nonvar(H),!,nonvar(I),
3576     H =.. [F|HA],
3577     I =.. [F|IA],
3578     check_safe_unif(HA,IA,SV).
3580 check_safe_unif2(H,I) :- var(H), !.
3582 check_safe_unif2([],[]) :- !.
3583 check_safe_unif2([H|Hs],[I|Is]) :-  !,
3584     check_safe_unif2(H,I),!,
3585     check_safe_unif2(Hs,Is).
3586     
3587 check_safe_unif2(H,I) :-
3588     nonvar(H),!,nonvar(I),
3589     H =.. [F|HA],
3590     I =.. [F|IA],
3591     check_safe_unif2(HA,IA).
3594 check_replacement(Repl) :- 
3595     check_replacement(Repl,FirstVars),
3596     sort(FirstVars,Sorted),
3597     length(Sorted,L),!,
3598     length(FirstVars,L).
3600 check_replacement([],[]).
3601 check_replacement([A-B|R],[A|RC]) :- check_replacement(R,RC).
3604 add_failing_occ(Rule,Heads,NH,ID_o1,FailCond,FH,M,C,Repl) :-
3605     Rule = pragma(rule(H1,H2,G,B),ids(ID1,ID2),_Pragmas,_Name,RuleNb),
3606     append(ID2,ID1,IDs),
3607     missing_partner_cond(Heads,NH,IDs,ID_o1,MPCond,H,C),
3608     copy_term((H,Heads,NH),(FH2,FHeads,NH2)),
3609     variable_replacement((H,Heads,NH),(FH2,FHeads,NH2),Repl),
3610     copy_with_variable_replacement(G,FG,Repl),
3611     extract_explicit_matchings(FG,FG2),
3612     negate_b(FG2,NotFG),
3613     copy_with_variable_replacement(MPCond,FMPCond,Repl),
3614     ( check_safe_unif2(FH,FH2),    FH=FH2 ->
3615         FailCond = [(NotFG;FMPCond)]
3616     ;
3617         % in this case, not much can be done
3618         % e.g.    c(f(...)), c(g(...)) <=> ...
3619         FailCond = [chr_pp_void_info]
3620     ).
3624 missing_partner_cond([],[],[],ID_o1,fail,H2,C).
3625 missing_partner_cond([H|Hs],[H2|H2s],[ID_o1|IDs],ID_o1,Cond,H,C) :- !,
3626     missing_partner_cond(Hs,H2s,IDs,ID_o1,Cond,H,C).
3627 missing_partner_cond([H|Hs],[NH|NHs],[ID|IDs],ID_o1,Cond,H2,F/A) :-
3628     Cond = (chr_pp_not_in_store(H);Cond1),
3629     missing_partner_cond(Hs,NHs,IDs,ID_o1,Cond1,H2,F/A).
3632 extract_explicit_matchings(A=B) :-
3633     var(A), var(B), !, A=B.
3634 extract_explicit_matchings(A==B) :-
3635     var(A), var(B), !, A=B.
3637 extract_explicit_matchings((A,B),D) :- !,
3638     ( extract_explicit_matchings(A) ->
3639         extract_explicit_matchings(B,D)
3640     ;
3641         D = (A,E),
3642         extract_explicit_matchings(B,E)
3643     ).
3644 extract_explicit_matchings(A,D) :- !,
3645     ( extract_explicit_matchings(A) ->
3646         D = true
3647     ;
3648         D = A
3649     ).
3654 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3655 %    TYPE INFORMATION
3656 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
3658 :- chr_constraint
3659         type_definition/2,
3660         type_alias/2,
3661         constraint_type/2,
3662         get_type_definition/2,
3663         get_constraint_type/2,
3664         add_type_information/3.
3667 :- chr_option(mode,type_definition(?,?)).
3668 :- chr_option(mode,type_alias(?,?)).
3669 :- chr_option(mode,constraint_type(+,+)).
3670 :- chr_option(mode,add_type_information(+,+,?)).
3671 :- chr_option(type_declaration,add_type_information(list,list,any)).
3673 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3674 % Consistency checks of type aliases
3676 type_alias(T,T2) <=>
3677    nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
3678    copy_term((T,T2),(X,Y)),oneway_unification(Y,X) |
3679    chr_error(type_error,'Cyclic alias definition: "~w".\n',[(T == T2)]).
3681 type_alias(T1,A1), type_alias(T2,A2) <=>
3682    nonvar(T1),nonvar(T2),functor(T1,F,A),functor(T2,F,A),
3683    \+ (T1\=T2) |
3684    copy_term_nat(T1,T1_),
3685    copy_term_nat(T2,T2_),
3686    T1_ = T2_,
3687    chr_error(type_error,
3688    '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_]).
3690 type_alias(T,B) \ type_alias(X,T2) <=> 
3691         nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
3692         copy_term_nat((X,T2,T,B),(X2,T3,T1,D1)),oneway_unification(T3,T1) |
3693         chr_info(type_information,'Inferring `~w\' from `~w\' and `~w\'.\n',[X2==D1,X==T2,T==B]),
3694         type_alias(X2,D1).
3696 oneway_unification(X,Y) :-
3697         term_variables(X,XVars),
3698         chr_runtime:lockv(XVars),
3699         X=Y,
3700         chr_runtime:unlockv(XVars).
3702 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3703 % Consistency checks of type definitions
3705 type_definition(T1,_), type_definition(T2,_) 
3706         <=>
3707                 functor(T1,F,A), functor(T2,F,A)
3708         |
3709                 chr_error(type_error,'Multiple definitions for type: ~w/~w.\n',[F,A]).
3711 type_definition(T1,_), type_alias(T2,_) 
3712         <=>
3713                 functor(T1,F,A), functor(T2,F,A)
3714         |
3715                 chr_error(type_error,'Multiple definitions for type, once in a type definition and once as a type alias: ~w/~w.\n',[F,A]).
3717 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3718 % get_type_definition
3720 get_type_definition(T,Def) <=> \+ ground(T) |
3721    chr_error(type_error,'Non-ground type in constraint definition: "~w".\n',[T]).
3723 type_alias(T,D) \ get_type_definition(T2,Def) <=> 
3724         nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
3725         copy_term_nat((T,D),(T1,D1)),T1=T2 | 
3726         (get_type_definition(D1,Def) ->
3727                 true
3728         ;
3729                 chr_error(type_error,'Could not find type definition for "~w" (accessed via alias "~w").\n',[D1,T1]), fail
3730         ).
3732 type_definition(T,D) \ get_type_definition(T2,Def) <=> 
3733         nonvar(T),nonvar(T2),functor(T,F,A),functor(T2,F,A),
3734         copy_term_nat((T,D),(T1,D1)),T1=T2 | Def = D1.
3735 get_type_definition(T2,Def) <=> 
3736         builtin_type(T2,_,_) | Def = [T2].
3737 get_type_definition(X,Y) <=> fail.
3739 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3740 % get_constraint_type
3742 constraint_type(C,T) \ get_constraint_type(C,Type) <=> Type = T.
3743 get_constraint_type(_,_) <=> fail.
3745 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3746 % add_type_information
3748 add_type_information([],[],T) <=> T=true.
3750 constraint_mode(F/A,Modes) 
3751 \ add_type_information([Head|R],[RealHead|RRH],TypeInfo) <=>
3752     functor(Head,F,A) |
3753     Head =.. [_|Args],
3754     RealHead =.. [_|RealArgs],
3755     add_mode_info(Modes,Args,ModeInfo),
3756     TypeInfo = (ModeInfo, TI),
3757     (get_constraint_type(F/A,Types) ->
3758         types2condition(Types,Args,RealArgs,Modes,TI2),
3759         list2conj(TI2,ConjTI),
3760         TI = (ConjTI,RTI),
3761         add_type_information(R,RRH,RTI)
3762     ;
3763         add_type_information(R,RRH,TI)
3764     ).
3767 add_type_information([Head|R],_,TypeInfo) <=>
3768     functor(Head,F,A),
3769     chr_error(internal,'Mode information missing for ~w.\n',[F/A]).
3772 add_mode_info([],[],true).
3773 add_mode_info([(+)|Modes],[A|Args],MI) :- !,
3774     MI = (ground(A), ModeInfo),
3775     add_mode_info(Modes,Args,ModeInfo).
3776 add_mode_info([M|Modes],[A|Args],MI) :-
3777     add_mode_info(Modes,Args,MI).
3780 types2condition([],[],[],[],[]).
3781 types2condition([Type|Types],[Arg|Args],[RealArg|RAs],[Mode|Modes],TI) :-
3782     ( get_type_definition(Type,Def) ->
3783         type2condition(Def,Arg,RealArg,TC),
3784         ( Mode \== (+) ->
3785             TC_ = [(\+ ground(Arg))|TC]
3786         ;
3787             TC_ = TC
3788         ),
3789         list2disj(TC_,DisjTC),
3790         TI = [DisjTC|RTI],
3791         types2condition(Types,Args,RAs,Modes,RTI)
3792     ;
3793         chr_error(internal,'Could not find type definition for ~w.\n',[Type])
3794         
3795     ).
3797 type2condition([],Arg,_,[]).
3798 type2condition([Def|Defs],Arg,RealArg,TC) :-
3799     ( builtin_type(Def,Arg,C) ->
3800         true
3801     ;
3802         real_type(Def,Arg,RealArg,C)
3803     ),
3804     item2list(C,LC),
3805     type2condition(Defs,Arg,RealArg,RTC),
3806     append(LC,RTC,TC).
3808 item2list([],[]) :- !.
3809 item2list([X|Y],[X|Y]) :- !.
3810 item2list(N,L) :- L = [N].
3812 builtin_type(X,Arg,true) :- var(X),!.
3813 builtin_type(X,Arg,Goal) :- builtin_type_nonvar(X,Arg,Goal).
3815 builtin_type_nonvar(any,Arg,true).
3816 builtin_type_nonvar(dense_int,Arg,(integer(Arg),Arg>=0)).
3817 builtin_type_nonvar(int,Arg,integer(Arg)).
3818 builtin_type_nonvar(number,Arg,number(Arg)).
3819 builtin_type_nonvar(float,Arg,float(Arg)).
3820 builtin_type_nonvar(natural,Arg,(integer(Arg),Arg>=0)).
3822 real_type(Def,Arg,RealArg,C) :-
3823     ( nonvar(Def) ->
3824         functor(Def,F,A),
3825         ( A == 0 ->
3826             C = (Arg = F)
3827         ;
3828             Def =.. [_|TArgs],
3829             length(AA,A),
3830             Def2 =.. [F|AA],
3831             ( var(RealArg) ->
3832                 C = functor(Arg,F,A)
3833             ;
3834                 ( functor(RealArg,F,A) ->
3835                     RealArg =.. [_|RAArgs],
3836                     nested_types(TArgs,AA,RAArgs,ACond),
3837                     C = (functor(Arg,F,A),Arg=Def2,ACond)
3838                 ;
3839                     C = functor(Arg,F,A)
3840                 )
3841             )
3842         )
3843     ;
3844         chr_error(internal,'Illegal type definition (must be nonvar).\n',[])
3845     ).  
3846 nested_types([],[],[],true).
3847 nested_types([T|RT],[A|RA],[RealA|RRA],C) :-
3848     ( get_type_definition(T,Def) ->
3849         type2condition(Def,A,RealA,TC),
3850         list2disj(TC,DisjTC),
3851         C = (DisjTC, RC),
3852         nested_types(RT,RA,RRA,RC)
3853     ;
3854         chr_error(internal,'Undefined type ~w inside type definition.\n',[T])
3855     ).
3857 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3858 % Static type checking
3859 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3860 % Checks head constraints and CHR constraint calls in bodies. 
3862 % TODO:
3863 %       - type clashes involving built-in types
3864 %       - Prolog built-ins in guard and body
3865 %       - indicate position in terms in error messages
3866 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3867 :- chr_constraint
3868         static_type_check/0.
3870 rule(_,Rule), static_type_check 
3871         ==>
3872                 copy_term_nat(Rule,RuleCopy),
3873                 RuleCopy = pragma(rule(Head1,Head2,G,Body),ids(IDs1,IDs2),Pragmas,Name,RuleNb),
3874                 (
3875                         catch(
3876                                 ( static_type_check_heads(Head1),
3877                                   static_type_check_heads(Head2),
3878                                   conj2list(Body,GoalList),
3879                                   static_type_check_body(GoalList)
3880                                 ),
3881                                 type_error(Error),
3882                                 ( Error = invalid_functor(Src,Term,Type) ->
3883                                         chr_error(type_error,'Invalid functor in ~@ of ~@:\n\t\tfound `~w\',\n\t\texpected type `~w\'!\n',
3884                                                 [chr_translate:format_src(Src),format_rule(Rule),Term,Type])
3885                                 ; Error = type_clash(Var,Src1,Src2,Type1,Type2) ->
3886                                         chr_error(type_error,'Type clash for variable ~w in ~@:\n\t\texpected type ~w in ~@\n\t\texpected type ~w in ~@\n',
3887                                                 [Var,format_rule(Rule),Type1,chr_translate:format_src(Src1),Type2,chr_translate:format_src(Src2)])
3888                                 )
3889                         ),
3890                         fail % cleanup constraints
3891                 ;
3892                         true
3893                 ).
3894                         
3896 static_type_check <=> true.
3898 static_type_check_heads([]).
3899 static_type_check_heads([Head|Heads]) :-
3900         static_type_check_head(Head),
3901         static_type_check_heads(Heads).
3903 static_type_check_head(Head) :-
3904         functor(Head,F,A),
3905         ( get_constraint_type(F/A,Types) ->
3906                 Head =..[_|Args],
3907                 maplist(static_type_check_term(head(Head)),Args,Types)
3908         ; % no type declared
3909                 true 
3910         ).      
3912 static_type_check_body([]).
3913 static_type_check_body([Goal|Goals]) :-
3914         functor(Goal,F,A),      
3915         ( get_constraint_type(F/A,Types) ->
3916                 Goal =..[_|Args],
3917                 maplist(static_type_check_term(body(Goal)),Args,Types)
3918         ; % not a CHR constraint or no type declared
3919                 true 
3920         ),      
3921         static_type_check_body(Goals).
3923 :- chr_constraint static_type_check_term/3.
3925 static_type_check_term(Src,Term,Type) 
3926         <=> 
3927                 var(Term) 
3928         | 
3929                 static_type_check_var(Src,Term,Type).
3930 static_type_check_term(Src,Term,Type) 
3931         <=> 
3932                 builtin_type_nonvar(Type,Term,Goal)
3933         |
3934                 ( call(Goal) ->
3935                         true
3936                 ;
3937                         throw(type_error(invalid_funtor(Src,Term,Type)))
3938                 ).      
3939 type_alias(AType,ADef) \ static_type_check_term(Src,Term,Type)
3940         <=>
3941                 functor(Type,F,A),
3942                 functor(AType,F,A)
3943         |
3944                 copy_term_nat(AType-ADef,Type-Def),
3945                 static_type_check_term(Src,Term,Def).
3947 type_definition(AType,ADef) \ static_type_check_term(Src,Term,Type)
3948         <=>
3949                 functor(Type,F,A),
3950                 functor(AType,F,A)
3951         |
3952                 copy_term_nat(AType-ADef,Type-Variants),
3953                 functor(Term,TF,TA),
3954                 ( member(Variant,Variants), functor(Variant,TF,TA) -> 
3955                         Term =.. [_|Args],
3956                         Variant =.. [_|Types],
3957                         maplist(static_type_check_term(Src),Args,Types)
3958                 ;
3959                         throw(type_error(invalid_functor(Src,Term,Type)))       
3960                 ).
3962 static_type_check_term(Src,Term,Type)
3963         <=>
3964                 chr_error(internal,'Undefined type ~w while type checking term ~w in ~@.\n',[Type,Term,chr_translate:format_src(Src)]).
3966 :- chr_constraint static_type_check_var/3.
3968 type_alias(AType,ADef) \ static_type_check_var(Src,Var,Type) 
3969         <=> 
3970                 functor(AType,F,A),
3971                 functor(Type,F,A)
3972         | 
3973                 copy_term_nat(AType-ADef,Type-Def),
3974                 static_type_check_var(Src,Var,Def).
3976 static_type_check_var(Src,Var,Type)
3977         <=>
3978                 builtin_type_nonvar(Type,_,_)
3979         |
3980                 true.
3981                 
3983 static_type_check_var(Src1,Var,Type1), static_type_check_var(Src2,Var,Type2)
3984         <=>
3985                 Type1 \== Type2
3986         |
3987                 throw(type_error(type_clash(Var,Src1,Src2,Type1,Type2))).
3989 format_src(head(Head)) :- format('head ~w',[Head]).
3990 format_src(body(Goal)) :- format('body goal ~w',[Goal]).
3992 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3993 % Dynamic type checking
3994 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
3996 :- chr_constraint
3997         dynamic_type_check/0,
3998         dynamic_type_check_clauses/1,
3999         get_dynamic_type_check_clauses/1.
4001 generate_dynamic_type_check_clauses(Clauses) :-
4002         ( chr_pp_flag(debugable,on) ->
4003                 dynamic_type_check,
4004                 get_dynamic_type_check_clauses(Clauses0),
4005                 append(Clauses0,
4006                                 [('$dynamic_type_check'(Type,Term) :- 
4007                                         throw(error(type_error(Type,Term),context(_,'CHR Runtime Type Error')))
4008                                 )],
4009                                 Clauses)
4010         ;
4011                 Clauses = []
4012         ).
4014 type_definition(T,D), dynamic_type_check
4015         ==>
4016                 copy_term_nat(T-D,Type-Definition),
4017                 maplist(dynamic_type_check_clause(Type),Definition,DynamicChecks),
4018                 dynamic_type_check_clauses(DynamicChecks).                      
4019 type_alias(A,B), dynamic_type_check
4020         ==>
4021                 copy_term_nat(A-B,Alias-Body),
4022                 dynamic_type_check_alias_clause(Alias,Body,Clause),
4023                 dynamic_type_check_clauses([Clause]).
4025 dynamic_type_check <=> 
4026         findall(('$dynamic_type_check'(Type,Term) :- !, Goal),builtin_type_nonvar(Type,Term,Goal), BuiltinChecks),
4027         dynamic_type_check_clauses(BuiltinChecks).
4029 dynamic_type_check_clause(T,DC,Clause) :-
4030         copy_term(T-DC,Type-DefinitionClause),
4031         functor(DefinitionClause,F,A),
4032         functor(Term,F,A),
4033         DefinitionClause =.. [_|DCArgs],
4034         Term =.. [_|TermArgs],
4035         maplist(dynamic_type_check_call,DCArgs,TermArgs,RecursiveCallList),
4036         list2conj(RecursiveCallList,RecursiveCalls),
4037         Clause = (
4038                         '$dynamic_type_check'(Type,Term) :- !,
4039                                 RecursiveCalls  
4040         ).
4042 dynamic_type_check_alias_clause(Alias,Body,Clause) :-
4043         Clause = (
4044                         '$dynamic_type_check'(Alias,Term) :- !,
4045                                 '$dynamic_type_check'(Body,Term)
4046         ).
4048 dynamic_type_check_call(Type,Term,Call) :-
4049         ( nonvar(Type), builtin_type_nonvar(Type,Term,Goal) ->
4050                 Call = when(nonvar(Term),Goal)
4051         ;
4052                 Call = when(nonvar(Term),'$dynamic_type_check'(Type,Term))
4053         ).
4055 dynamic_type_check_clauses(C1), dynamic_type_check_clauses(C2) 
4056         <=>
4057                 append(C1,C2,C),
4058                 dynamic_type_check_clauses(C).
4060 get_dynamic_type_check_clauses(Q), dynamic_type_check_clauses(C) 
4061         <=>
4062                 Q = C.
4063 get_dynamic_type_check_clauses(Q)
4064         <=>
4065                 Q = [].
4067 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4068 % Atomic Types 
4069 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4070 % Some optimizations can be applied for atomic types...
4071 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
4073 atomic_types_suspended_constraint(C) :- 
4074         C = _/N,
4075         get_constraint_type(C,ArgTypes),
4076         get_constraint_mode(C,ArgModes),
4077         findall(I,between(1,N,I),Indexes),
4078         maplist(atomic_types_suspended_constraint(C),ArgTypes,ArgModes,Indexes).        
4080 atomic_types_suspended_constraint(C,Type,Mode,Index) :-
4081         ( is_indexed_argument(C,Index) ->
4082                 ( Mode == (?) ->
4083                         atomic_type(Type)
4084                 ;
4085                         true
4086                 )
4087         ;
4088                 true
4089         ).
4091 :- chr_constraint atomic_type/1.
4093 atomic_type(Type) <=> builtin_type_nonvar(Type,_,_) | Type \== any.
4095 type_definition(TypePat,Def) \ atomic_type(Type) 
4096         <=> 
4097                 functor(Type,F,A), functor(TypePat,F,A) 
4098         |
4099                 forall(member(Term,Def),atomic(Term)).
4101 type_alias(TypePat,Alias) \ atomic_type(Type)
4102         <=>
4103                 functor(Type,F,A), functor(TypePat,F,A) 
4104         |
4105                 atomic(Alias),
4106                 copy_term_nat(TypePat-Alias,Type-NType),
4107                 atomic_type(NType).
4109 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4111 :- chr_constraint
4112         stored/3, % constraint,occurrence,(yes/no/maybe)
4113         stored_completing/3,
4114         stored_complete/3,
4115         is_stored/1,
4116         is_finally_stored/1,
4117         check_all_passive/2.
4119 :- chr_option(mode,stored(+,+,+)).
4120 :- chr_option(type_declaration,stored(any,int,storedinfo)).
4121 :- chr_option(type_definition,type(storedinfo,[yes,no,maybe])).
4122 :- chr_option(mode,stored_complete(+,+,+)).
4123 :- chr_option(mode,maybe_complementary_guards(+,+,?,?)).
4124 :- chr_option(mode,guard_list(+,+,+,+)).
4125 :- chr_option(mode,check_all_passive(+,+)).
4127 % change yes in maybe when yes becomes passive
4128 passive(RuleNb,ID), occurrence(C,O,RuleNb,ID,_) \ 
4129         stored(C,O,yes), stored_complete(C,RO,Yesses)
4130         <=> O < RO | NYesses is Yesses - 1,
4131         stored(C,O,maybe), stored_complete(C,RO,NYesses).
4132 % change yes in maybe when not observed
4133 ai_not_observed(C,O) \ stored(C,O,yes), stored_complete(C,RO,Yesses)
4134         <=> O < RO |
4135         NYesses is Yesses - 1,
4136         stored(C,O,maybe), stored_complete(C,RO,NYesses).
4138 occurrence(_,_,RuleNb,ID,_), occurrence(C2,_,RuleNb,_,_), stored_complete(C2,RO,0), max_occurrence(C2,MO2)
4139         ==> RO =< MO2 |  % C2 is never stored
4140         passive(RuleNb,ID).     
4143     
4145 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4147 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
4148     Rule = pragma(rule(Head1,Head2,G,B),ids([Id|IDs1],IDs2),Pragmas,Name,RuleNb) |
4149     append(IDs1,IDs2,I), check_all_passive(RuleNb,I).
4151 rule(RuleNb,Rule),passive(RuleNb,Id) ==>
4152     Rule = pragma(rule(Head1,Head2,G,B),ids([],[Id|IDs2]),Pragmas,Name,RuleNb) |
4153     check_all_passive(RuleNb,IDs2).
4155 passive(RuleNb,Id) \ check_all_passive(RuleNb,[Id|IDs]) <=>
4156     check_all_passive(RuleNb,IDs).
4158 rule(RuleNb,Rule) \ check_all_passive(RuleNb,[]) <=>
4159     chr_warning(weird_program,'All heads passive in ~@.\n\tThis rule never fires. Please check your program.\n',[format_rule(Rule)]).
4160     
4161 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4162     
4163 % collect the storage information
4164 stored(C,O,yes) \ stored_completing(C,O,Yesses)
4165         <=> NO is O + 1, NYesses is Yesses + 1,
4166             stored_completing(C,NO,NYesses).
4167 stored(C,O,maybe) \ stored_completing(C,O,Yesses)
4168         <=> NO is O + 1,
4169             stored_completing(C,NO,Yesses).
4170             
4171 stored(C,O,no) \ stored_completing(C,O,Yesses)
4172         <=> stored_complete(C,O,Yesses).
4173 stored_completing(C,O,Yesses)
4174         <=> stored_complete(C,O,Yesses).
4176 stored_complete(C,O,Yesses), occurrence(C,O2,RuleNb,Id,_) ==>
4177         O2 > O | passive(RuleNb,Id).
4178         
4179 % decide whether a constraint is stored
4180 max_occurrence(C,MO), stored_complete(C,RO,0) \ is_stored(C)
4181         <=> RO =< MO | fail.
4182 is_stored(C) <=>  true.
4184 % decide whether a constraint is suspends after occurrences
4185 max_occurrence(C,MO), stored_complete(C,RO,_) \ is_finally_stored(C)
4186         <=> RO =< MO | fail.
4187 is_finally_stored(C) <=>  true.
4189 storage_analysis(Constraints) :-
4190         ( chr_pp_flag(storage_analysis,on) ->
4191                 check_constraint_storages(Constraints)
4192         ;
4193                 true
4194         ).
4196 check_constraint_storages([]).
4197 check_constraint_storages([C|Cs]) :-
4198         check_constraint_storage(C),
4199         check_constraint_storages(Cs).
4201 check_constraint_storage(C) :-
4202         get_max_occurrence(C,MO),
4203         check_occurrences_storage(C,1,MO).
4205 check_occurrences_storage(C,O,MO) :-
4206         ( O > MO ->
4207                 stored_completing(C,1,0)
4208         ;
4209                 check_occurrence_storage(C,O),
4210                 NO is O + 1,
4211                 check_occurrences_storage(C,NO,MO)
4212         ).
4214 check_occurrence_storage(C,O) :-
4215         get_occurrence(C,O,RuleNb,ID),
4216         ( is_passive(RuleNb,ID) ->
4217                 stored(C,O,maybe)
4218         ;
4219                 get_rule(RuleNb,PragmaRule),
4220                 PragmaRule = pragma(rule(Heads1,Heads2,Guard,Body),ids(IDs1,IDs2),_,_,_),
4221                 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
4222                         check_storage_head1(Head1,O,Heads1,Heads2,Guard)
4223                 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
4224                         check_storage_head2(Head2,O,Heads1,Body)
4225                 )
4226         ).
4228 check_storage_head1(Head,O,H1,H2,G) :-
4229         functor(Head,F,A),
4230         C = F/A,
4231         ( H1 == [Head],
4232           H2 == [],
4233           guard_entailment:entails_guard([chr_pp_headvariables(Head)],G),
4234           Head =.. [_|L],
4235           no_matching(L,[]) ->
4236                 stored(C,O,no)
4237         ;
4238                 stored(C,O,maybe)
4239         ).
4241 no_matching([],_).
4242 no_matching([X|Xs],Prev) :-
4243         var(X),
4244         \+ memberchk_eq(X,Prev),
4245         no_matching(Xs,[X|Prev]).
4247 check_storage_head2(Head,O,H1,B) :-
4248         functor(Head,F,A),
4249         C = F/A,
4250         ( %( 
4251                 (H1 \== [], B == true ) 
4252           %; 
4253           % \+ is_observed(F/A,O)  % always fails because observation analysis has not been performed yet
4254           %)
4255         ->
4256                 stored(C,O,maybe)
4257         ;
4258                 stored(C,O,yes)
4259         ).
4261 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4263 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4264 %%  ____        _         ____                      _ _       _   _
4265 %% |  _ \ _   _| | ___   / ___|___  _ __ ___  _ __ (_) | __ _| |_(_) ___  _ __
4266 %% | |_) | | | | |/ _ \ | |   / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
4267 %% |  _ <| |_| | |  __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
4268 %% |_| \_\\__,_|_|\___|  \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
4269 %%                                           |_|
4271 constraints_code(Constraints,Clauses) :-
4272         (chr_pp_flag(reduced_indexing,on), 
4273                     \+ forsome(C,Constraints,\+ chr_translate:only_ground_indexed_arguments(C)) ->
4274             none_suspended_on_variables
4275         ;
4276             true
4277         ),
4278         constraints_code1(Constraints,Clauses,[]).
4280 %===============================================================================
4281 :- chr_constraint constraints_code1/3.
4282 :- chr_option(mode,constraints_code1(+,+,+)).
4283 :- chr_option(type_declaration,constraints_code(list,any,any)).
4284 %-------------------------------------------------------------------------------
4285 constraints_code1([],L,T) <=> L = T.
4286 constraints_code1([C|RCs],L,T) 
4287         <=>
4288                 constraint_code(C,L,T1),
4289                 constraints_code1(RCs,T1,T).
4290 %===============================================================================
4291 :- chr_constraint constraint_code/3.
4292 :- chr_option(mode,constraint_code(+,+,+)).
4293 %-------------------------------------------------------------------------------
4294 %%      Generate code for a single CHR constraint
4295 constraint_code(Constraint, L, T) 
4296         <=>     true
4297         |       ( (chr_pp_flag(debugable,on) ;
4298                   is_stored(Constraint), ( has_active_occurrence(Constraint); chr_pp_flag(late_allocation,off)), 
4299                   ( may_trigger(Constraint) ; 
4300                     get_allocation_occurrence(Constraint,AO), 
4301                     get_max_occurrence(Constraint,MO), MO >= AO ) )
4302                    ->
4303                         constraint_prelude(Constraint,Clause),
4304                         L = [Clause | L1]
4305                 ;
4306                         L = L1
4307                 ),
4308                 Id = [0],
4309                 occurrences_code(Constraint,1,Id,NId,L1,L2),
4310                 gen_cond_attach_clause(Constraint,NId,L2,T).
4312 %===============================================================================
4313 %%      Generate prelude predicate for a constraint.
4314 %%      f(...) :- f/a_0(...,Susp).
4315 constraint_prelude(F/A, Clause) :-
4316         vars_susp(A,Vars,Susp,VarsSusp),
4317         Head =.. [ F | Vars],
4318         make_suspension_continuation_goal(F/A,VarsSusp,Continuation),
4319         build_head(F,A,[0],VarsSusp,Delegate),
4320         ( chr_pp_flag(debugable,on) ->
4321                 insert_constraint_goal(F/A,Susp,Vars,InsertCall),
4322                 attach_constraint_atom(F/A,Vars2,Susp,AttachCall),
4323                 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
4324                 insert_constraint_internal_constraint_goal(F/A, Vars2, Susp, Continuation, Vars,InsertGoal),
4326                 ( get_constraint_type(F/A,ArgTypeList) ->       
4327                         maplist(dynamic_type_check_call,ArgTypeList,Vars,DynamicTypeCheckList),
4328                         list2conj(DynamicTypeCheckList,DynamicTypeChecks)
4329                 ;
4330                         DynamicTypeChecks = true
4331                 ),
4333                 Clause = 
4334                         ( Head :-
4335                                 DynamicTypeChecks,
4336                                 InsertGoal,
4337                                 InsertCall,
4338                                 AttachCall,
4339                                 Inactive,
4340                                 'chr debug_event'(insert(Head#Susp)),
4341                                 (   
4342                                         'chr debug_event'(call(Susp)),
4343                                         Delegate
4344                                 ;
4345                                         'chr debug_event'(fail(Susp)), !,
4346                                         fail
4347                                 ),
4348                                 (   
4349                                         'chr debug_event'(exit(Susp))
4350                                 ;   
4351                                         'chr debug_event'(redo(Susp)),
4352                                         fail
4353                                 )
4354                         )
4355         ; get_allocation_occurrence(F/A,0) ->
4356                 gen_insert_constraint_internal_goal(F/A,Goal,VarsSusp,Vars,Susp),
4357                 delay_phase_end(validate_store_type_assumptions,chr_translate:update_suspension_field(F/A,Susp,state,inactive,Inactive)),
4358                 Clause = ( Head  :- Goal, Inactive, Delegate )
4359         ;
4360                 Clause = ( Head  :- Delegate )
4361         ). 
4363 make_suspension_continuation_goal(F/A,VarsSusp,Goal) :-
4364         ( may_trigger(F/A) ->
4365                 build_head(F,A,[0],VarsSusp,Delegate),
4366                 ( chr_pp_flag(debugable,off) ->
4367                         Goal = Delegate
4368                 ;
4369                         get_target_module(Mod),
4370                         Goal = Mod:Delegate
4371                 )
4372         ;
4373                 Goal = true
4374         ).
4376 %===============================================================================
4377 :- chr_constraint has_active_occurrence/1, has_active_occurrence/2.
4378 %-------------------------------------------------------------------------------
4379 has_active_occurrence(C) <=> has_active_occurrence(C,1).
4381 max_occurrence(C,MO) \ has_active_occurrence(C,O) <=>
4382         O > MO | fail.
4383 passive(RuleNb,ID),occurrence(C,O,RuleNb,ID,_) \
4384         has_active_occurrence(C,O) <=>
4385         NO is O + 1,
4386         has_active_occurrence(C,NO).
4387 has_active_occurrence(C,O) <=> true.
4388 %===============================================================================
4390 gen_cond_attach_clause(F/A,Id,L,T) :-
4391         ( is_finally_stored(F/A) ->
4392                 get_allocation_occurrence(F/A,AllocationOccurrence),
4393                 get_max_occurrence(F/A,MaxOccurrence),
4394                 ( chr_pp_flag(debugable,off), MaxOccurrence < AllocationOccurrence ->
4395                         ( only_ground_indexed_arguments(F/A) ->
4396                                 gen_insert_constraint_internal_goal(F/A,Body,AllArgs,Args,Susp)
4397                         ;
4398                                 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
4399                         )
4400                 ;       vars_susp(A,Args,Susp,AllArgs),
4401                         gen_uncond_attach_goal(F/A,Susp,Args,Body,_)
4402                 ),
4403                 build_head(F,A,Id,AllArgs,Head),
4404                 Clause = ( Head :- Body ),
4405                 L = [Clause | T]
4406         ;
4407                 L = T
4408         ).      
4410 :- chr_constraint 
4411         use_auxiliary_predicate/1,
4412         use_auxiliary_predicate/2,
4413         is_used_auxiliary_predicate/1,
4414         is_used_auxiliary_predicate/2.
4416 :- chr_option(mode,use_auxiliary_predicate(+)).
4417 :- chr_option(mode,use_auxiliary_predicate(+,+)).
4419 use_auxiliary_predicate(P) \ use_auxiliary_predicate(P) <=> true.
4421 use_auxiliary_predicate(P,C) \ use_auxiliary_predicate(P,C) <=> true.
4423 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P) <=> true.
4425 use_auxiliary_predicate(P,_) \ is_used_auxiliary_predicate(P) <=> true.
4427 is_used_auxiliary_predicate(P) <=> fail.
4429 use_auxiliary_predicate(P) \ is_used_auxiliary_predicate(P,_) <=> true.
4430 use_auxiliary_predicate(P,C) \ is_used_auxiliary_predicate(P,C) <=> true.
4432 is_used_auxiliary_predicate(P,C) <=> fail.
4434 %------------------------------------------------------------------------------%
4435 % Only generate import statements for actually used modules.
4436 %------------------------------------------------------------------------------%
4438 :-chr_constraint
4439         use_auxiliary_module/1,
4440         is_used_auxiliary_module/1.
4442 :- chr_option(mode,use_auxiliary_module(+)).
4444 use_auxiliary_module(P) \ use_auxiliary_module(P) <=> true.
4446 use_auxiliary_module(P) \ is_used_auxiliary_module(P) <=> true.
4448 is_used_auxiliary_module(P) <=> fail.
4450         % only called for constraints with
4451         % at least one
4452         % non-ground indexed argument   
4453 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
4454         vars_susp(A,Args,Susp,AllArgs),
4455         make_suspension_continuation_goal(F/A,AllArgs,Closure),
4456         ( get_store_type(F/A,var_assoc_store(_,_)) ->
4457                 Attach = true
4458         ;
4459                 attach_constraint_atom(F/A,Vars,Susp,Attach)
4460         ),
4461         FTerm =.. [F|Args],
4462         insert_constraint_goal(F/A,Susp,Args,InsertCall),
4463         insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Closure, Args,InsertGoal),
4464         ( may_trigger(F/A) ->
4465                 activate_constraint_goal(F/A,(InsertCall,Attach),Vars,Susp,_,ActivateGoal),
4466                 Goal =
4467                 (
4468                         ( var(Susp) ->
4469                                 InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args)
4470                                 InsertCall,
4471                                 Attach
4472                         ; 
4473                                 ActivateGoal % activate_constraint(Stored,Vars,Susp,_)
4474                         )               
4475                 )
4476         ;
4477                 Goal =
4478                 (
4479                         InsertGoal, % insert_constraint_internal(Stored,Vars,Susp,Closure,F,Args),
4480                         InsertCall,     
4481                         Attach
4482                 )
4483         ).
4485 gen_insert_constraint_internal_goal(F/A,Goal,AllArgs,Args,Susp) :-
4486         vars_susp(A,Args,Susp,AllArgs),
4487         make_suspension_continuation_goal(F/A,AllArgs,Cont),
4488         ( \+ only_ground_indexed_arguments(F/A), \+ get_store_type(F/A,var_assoc_store(_,_)) ->
4489                 attach_constraint_atom(F/A,Vars,Susp,Attach)
4490         ;
4491                 Attach = true
4492         ),
4493         FTerm =.. [F|Args],
4494         insert_constraint_goal(F/A,Susp,Args,InsertCall),
4495         insert_constraint_internal_constraint_goal(F/A, Vars, Susp, Cont, Args,InsertInternalGoal),
4496         ( only_ground_indexed_arguments(F/A), chr_pp_flag(debugable,off) ->
4497             Goal =
4498             (
4499                 InsertInternalGoal, % insert_constraint_internal(Susp,F,Args),
4500                 InsertCall
4501             )
4502         ;
4503             Goal =
4504             (
4505                 InsertInternalGoal, % insert_constraint_internal(_,Vars,Susp,Cont,F,Args),
4506                 InsertCall,
4507                 Attach
4508             )
4509         ).
4511 gen_uncond_attach_goal(FA,Susp,Args,AttachGoal,Generation) :-
4512         ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
4513                 attach_constraint_atom(FA,Vars,Susp,Attach)
4514         ;
4515                 Attach = true
4516         ),
4517         insert_constraint_goal(FA,Susp,Args,InsertCall),
4518         ( chr_pp_flag(late_allocation,on) ->
4519                 activate_constraint_goal(FA,(InsertCall,Attach),Vars,Susp,Generation,AttachGoal)
4520         ;
4521                 activate_constraint_goal(FA,true,Vars,Susp,Generation,AttachGoal)
4522         ).
4524 %-------------------------------------------------------------------------------
4525 :- chr_constraint occurrences_code/6.
4526 :- chr_option(mode,occurrences_code(+,+,+,+,+,+)).
4527 %-------------------------------------------------------------------------------
4528 max_occurrence(C,MO) \ occurrences_code(C,O,Id,NId,L,T)
4529          <=>    O > MO 
4530         |       NId = Id, L = T.
4531 occurrences_code(C,O,Id,NId,L,T) 
4532         <=>
4533                 occurrence_code(C,O,Id,Id1,L,L1), 
4534                 NO is O + 1,
4535                 occurrences_code(C,NO,Id1,NId,L1,T).
4536 %-------------------------------------------------------------------------------
4537 :- chr_constraint occurrence_code/6.
4538 :- chr_option(mode,occurrence_code(+,+,+,+,+,+)).
4539 %-------------------------------------------------------------------------------
4540 occurrence(C,O,RuleNb,ID,_), passive(RuleNb,ID) \ occurrence_code(C,O,Id,NId,L,T) 
4541         <=>     NId = Id, L = T.
4542 occurrence(C,O,RuleNb,ID,_), rule(RuleNb,PragmaRule) \ occurrence_code(C,O,Id,NId,L,T)
4543         <=>     true |  
4544                 PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),      
4545                 ( select2(ID,Head1,IDs1,Heads1,RIDs1,RHeads1) ->
4546                         NId = Id,
4547                         head1_code(Head1,ID,RHeads1,RIDs1,PragmaRule,C,O,Id,L,T)
4548                 ; select2(ID,Head2,IDs2,Heads2,RIDs2,RHeads2) ->
4549                         head2_code(Head2,ID,RHeads2,RIDs2,PragmaRule,C,O,Id,L,L1),
4550                         inc_id(Id,NId),
4551                         ( unconditional_occurrence(C,O) ->
4552                                 L1 = T
4553                         ;
4554                                 gen_alloc_inc_clause(C,O,Id,L1,T)
4555                         )
4556                 ).
4558 occurrence_code(C,O,_,_,_,_)
4559         <=>     
4560                 chr_error(internal,'occurrence_code/6: missing information to compile ~w:~w\n',[C,O]).
4561 %-------------------------------------------------------------------------------
4563 %%      Generate code based on one removed head of a CHR rule
4564 head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
4565         PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
4566         Rule = rule(_,Head2,_,_),
4567         ( Head2 == [] ->
4568                 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
4569                 simplification_code(Head,ID,NOtherHeads,NOtherIDs,PragmaRule,FA,O,Id,L,T)
4570         ;
4571                 simpagation_head1_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
4572         ).
4574 %% Generate code based on one persistent head of a CHR rule
4575 head2_code(Head,ID,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) :-
4576         PragmaRule = pragma(Rule,_,_,_Name,RuleNb),
4577         Rule = rule(Head1,_,_,_),
4578         ( Head1 == [] ->
4579                 reorder_heads(RuleNb,Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
4580                 propagation_code(Head,ID,NOtherHeads,NOtherIDs,Rule,RuleNb,FA,O,Id,L,T)
4581         ;
4582                 simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,O,Id,L,T) 
4583         ).
4585 gen_alloc_inc_clause(F/A,O,Id,L,T) :-
4586         vars_susp(A,Vars,Susp,VarsSusp),
4587         build_head(F,A,Id,VarsSusp,Head),
4588         inc_id(Id,IncId),
4589         build_head(F,A,IncId,VarsSusp,CallHead),
4590         gen_occ_allocation(F/A,O,Vars,Susp,ConditionalAlloc),
4591         Clause =
4592         (
4593                 Head :-
4594                         ConditionalAlloc,
4595                         CallHead
4596         ),
4597         L = [Clause|T].
4599 gen_occ_allocation(FA,O,Vars,Susp,Goal) :-
4600         get_allocation_occurrence(FA,AO),
4601         ( chr_pp_flag(debugable,off), O == AO ->
4602                 allocate_constraint_goal(FA,Susp,Vars,Goal0),
4603                 ( may_trigger(FA) ->
4604                         Goal = (var(Susp) -> Goal0 ; true)      
4605                 ;
4606                         Goal = Goal0
4607                 )
4608         ;
4609                 Goal = true
4610         ).
4611 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4613 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4615 % Reorders guard goals with respect to partner constraint retrieval goals and
4616 % active constraint. Returns combined partner retrieval + guard goal.
4618 guard_via_reschedule_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,GoalSkeleton) :-
4619         ( chr_pp_flag(guard_via_reschedule,on) ->
4620                 guard_via_reschedule_main_new(Retrievals,GuardList,Prelude,GuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
4621                 list2conj(ScheduleSkeleton,GoalSkeleton)
4622         ;
4623                 length(Retrievals,RL), length(LookupSkeleton,RL),
4624                 length(GuardList,GL), length(GuardListSkeleton,GL),
4625                 append(LookupSkeleton,GuardListSkeleton,GoalListSkeleton),
4626                 list2conj(GoalListSkeleton,GoalSkeleton)        
4627         ).
4628 guard_via_reschedule_main_new(PartnerLookups,GuardList,ActiveHead,
4629         GuardListSkeleton,LookupSkeleton,ScheduleSkeleton) :-
4630         initialize_unit_dictionary(ActiveHead,Dict),
4631         maplist(wrap_in_functor(lookup),PartnerLookups,WrappedPartnerLookups),
4632         maplist(wrap_in_functor(guard),GuardList,WrappedGuardList),
4633         build_units(WrappedPartnerLookups,WrappedGuardList,Dict,Units),
4634         dependency_reorder(Units,NUnits),
4635         wrappedunits2lists(NUnits,IndexedGuardListSkeleton,LookupSkeleton,ScheduleSkeleton),
4636         sort(IndexedGuardListSkeleton,SortedIndexedGuardListSkeleton),
4637         snd_of_pairs(SortedIndexedGuardListSkeleton,GuardListSkeleton).
4639 wrap_in_functor(Functor,X,Term) :-
4640         Term =.. [Functor,X].
4642 wrappedunits2lists([],[],[],[]).
4643 wrappedunits2lists([unit(N,WrappedGoal,_,_)|Units],Gs,Ls,Ss) :-
4644         Ss = [GoalCopy|TSs],
4645         ( WrappedGoal = lookup(Goal) ->
4646                 Ls = [GoalCopy|TLs],
4647                 Gs = TGs
4648         ; WrappedGoal = guard(Goal) ->
4649                 Gs = [N-GoalCopy|TGs],
4650                 Ls = TLs
4651         ),
4652         wrappedunits2lists(Units,TGs,TLs,TSs).
4654 guard_splitting(Rule,SplitGuardList) :-
4655         Rule = rule(H1,H2,Guard,_),
4656         append(H1,H2,Heads),
4657         conj2list(Guard,GuardList),
4658         term_variables(Heads,HeadVars),
4659         split_off_simple_guard_new(GuardList,HeadVars,GuardPrefix,RestGuardList),
4660         append(GuardPrefix,[RestGuard],SplitGuardList),
4661         term_variables(RestGuardList,GuardVars1),
4662         % variables that are declared to be ground don't need to be locked
4663         ground_vars(Heads,GroundVars),  
4664         list_difference_eq(HeadVars,GroundVars,LockableHeadVars),
4665         intersect_eq(LockableHeadVars,GuardVars1,GuardVars),
4666         ( chr_pp_flag(guard_locks,on),
4667           bagof(('chr lock'(X)) - ('chr unlock'(X)), (lists:member(X,GuardVars)), LocksUnlocks) ->
4668                 once(pairup(Locks,Unlocks,LocksUnlocks))
4669         ;
4670                 Locks = [],
4671                 Unlocks = []
4672         ),
4673         list2conj(Locks,LockPhase),
4674         list2conj(Unlocks,UnlockPhase),
4675         list2conj(RestGuardList,RestGuard1),
4676         RestGuard = (LockPhase,(RestGuard1,UnlockPhase)).
4678 guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy) :-
4679         Rule = rule(_,_,_,Body),
4680         my_term_copy(GuardList,VarDict,VarDict2,GuardCopyList),
4681         my_term_copy(Body,VarDict2,BodyCopy).
4684 split_off_simple_guard_new([],_,[],[]).
4685 split_off_simple_guard_new([G|Gs],VarDict,S,C) :-
4686         ( simple_guard_new(G,VarDict) ->
4687                 S = [G|Ss],
4688                 split_off_simple_guard_new(Gs,VarDict,Ss,C)
4689         ;
4690                 S = [],
4691                 C = [G|Gs]
4692         ).
4694 % simple guard: cheap and benign (does not bind variables)
4695 simple_guard_new(G,Vars) :-
4696         binds_b(G,BoundVars),
4697         \+ (( member(V,BoundVars), 
4698               memberchk_eq(V,Vars)
4699            )).
4701 dependency_reorder(Units,NUnits) :-
4702         dependency_reorder(Units,[],NUnits).
4704 dependency_reorder([],Acc,Result) :-
4705         reverse(Acc,Result).
4707 dependency_reorder([Unit|Units],Acc,Result) :-
4708         Unit = unit(_GID,_Goal,Type,GIDs),
4709         ( Type == fixed ->
4710                 NAcc = [Unit|Acc]
4711         ;
4712                 dependency_insert(Acc,Unit,GIDs,NAcc)
4713         ),
4714         dependency_reorder(Units,NAcc,Result).
4716 dependency_insert([],Unit,_,[Unit]).
4717 dependency_insert([X|Xs],Unit,GIDs,L) :-
4718         X = unit(GID,_,_,_),
4719         ( memberchk(GID,GIDs) ->
4720                 L = [Unit,X|Xs]
4721         ;
4722                 L = [X | T],
4723                 dependency_insert(Xs,Unit,GIDs,T)
4724         ).
4726 build_units(Retrievals,Guard,InitialDict,Units) :-
4727         build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
4728         build_guard_units(Guard,N,Dict,Tail).
4730 build_retrieval_units([],N,N,Dict,Dict,L,L).
4731 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
4732         term_variables(U,Vs),
4733         update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
4734         L = [unit(N,U,fixed,GIDs)|L1], 
4735         N1 is N + 1,
4736         build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
4738 initialize_unit_dictionary(Term,Dict) :-
4739         term_variables(Term,Vars),
4740         pair_all_with(Vars,0,Dict).     
4742 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
4743 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
4744         ( lookup_eq(Dict,V,GID) ->
4745                 ( (GID == This ; memberchk(GID,GIDs) ) ->
4746                         GIDs1 = GIDs
4747                 ;
4748                         GIDs1 = [GID|GIDs]
4749                 ),
4750                 Dict1 = Dict
4751         ;
4752                 Dict1 = [V - This|Dict],
4753                 GIDs1 = GIDs
4754         ),
4755         update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
4757 build_guard_units(Guard,N,Dict,Units) :-
4758         ( Guard = [Goal] ->
4759                 Units = [unit(N,Goal,fixed,[])]
4760         ; Guard = [Goal|Goals] ->
4761                 term_variables(Goal,Vs),
4762                 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
4763                 Units = [unit(N,Goal,movable,GIDs)|RUnits],
4764                 N1 is N + 1,
4765                 build_guard_units(Goals,N1,NDict,RUnits)
4766         ).
4768 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
4769 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
4770         ( lookup_eq(Dict,V,GID) ->
4771                 ( (GID == This ; memberchk(GID,GIDs) ) ->
4772                         GIDs1 = GIDs
4773                 ;
4774                         GIDs1 = [GID|GIDs]
4775                 ),
4776                 Dict1 = [V - This|Dict]
4777         ;
4778                 Dict1 = [V - This|Dict],
4779                 GIDs1 = GIDs
4780         ),
4781         update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
4782         
4783 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4785 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4786 %%  ____       _     ____                             _   _            
4787 %% / ___|  ___| |_  / ___|  ___ _ __ ___   __ _ _ __ | |_(_) ___ ___ _ 
4788 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
4789 %%  ___) |  __/ |_   ___) |  __/ | | | | | (_| | | | | |_| | (__\__ \_ 
4790 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
4791 %%                                                                     
4792 %%  _   _       _                    ___        __                              
4793 %% | | | |_ __ (_) __ _ _   _  ___  |_ _|_ __  / _| ___ _ __ ___ _ __   ___ ___ 
4794 %% | | | | '_ \| |/ _` | | | |/ _ \  | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
4795 %% | |_| | | | | | (_| | |_| |  __/  | || | | |  _|  __/ | |  __/ | | | (_|  __/
4796 %%  \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_|  \___|_|  \___|_| |_|\___\___|
4797 %%                   |_|                                                        
4798 :- chr_constraint
4799         functional_dependency/4,
4800         get_functional_dependency/4.
4802 :- chr_option(mode,functional_dependency(+,+,?,?)).
4804 allocation_occurrence(C,AO), occurrence(C,O,RuleNb,_,_) \ functional_dependency(C,RuleNb,Pattern,Key)
4805         <=>
4806                 RuleNb > 1, AO > O
4807         |
4808                 functional_dependency(C,1,Pattern,Key).
4810 functional_dependency(C,RuleNb1,Pattern,Key) \ get_functional_dependency(C,RuleNb2,QPattern,QKey)
4811         <=> 
4812                 RuleNb2 >= RuleNb1
4813         |
4814                 QPattern = Pattern, QKey = Key.
4815 get_functional_dependency(_,_,_,_)
4816         <=>
4817                 fail.
4819 functional_dependency_analysis(Rules) :-
4820                 ( chr_pp_flag(functional_dependency_analysis,on) ->
4821                         functional_dependency_analysis_main(Rules)
4822                 ;
4823                         true
4824                 ).
4826 functional_dependency_analysis_main([]).
4827 functional_dependency_analysis_main([PRule|PRules]) :-
4828         ( discover_unique_pattern(PRule,C,RuleNb,Pattern,Key) ->
4829                 functional_dependency(C,RuleNb,Pattern,Key)
4830         ;
4831                 true
4832         ),
4833         functional_dependency_analysis_main(PRules).
4835 discover_unique_pattern(PragmaRule,F/A,RuleNb,Pattern,Key) :-
4836         PragmaRule = pragma(Rule,_,_,Name,RuleNb),
4837         Rule = rule(H1,H2,Guard,_),
4838         ( H1 = [C1],
4839           H2 = [C2] ->
4840                 true
4841         ; H1 = [C1,C2],
4842           H2 == [] ->
4843                 true
4844         ),
4845         check_unique_constraints(C1,C2,Guard,RuleNb,List),
4846         term_variables(C1,Vs),
4847         \+ ( 
4848                 member(V1,Vs),
4849                 lookup_eq(List,V1,V2),
4850                 memberchk_eq(V2,Vs)
4851         ),
4852         select_pragma_unique_variables(Vs,List,Key1),
4853         copy_term_nat(C1-Key1,Pattern-Key),
4854         functor(C1,F,A).
4855         
4856 select_pragma_unique_variables([],_,[]).
4857 select_pragma_unique_variables([V|Vs],List,L) :-
4858         ( lookup_eq(List,V,_) ->
4859                 L = T
4860         ;
4861                 L = [V|T]
4862         ),
4863         select_pragma_unique_variables(Vs,List,T).
4865         % depends on functional dependency analysis
4866         % and shape of rule: C1 \ C2 <=> true.
4867 set_semantics_rules(Rules) :-
4868         ( chr_pp_flag(set_semantics_rule,on) ->
4869                 set_semantics_rules_main(Rules)
4870         ;
4871                 true
4872         ).
4874 set_semantics_rules_main([]).
4875 set_semantics_rules_main([R|Rs]) :-
4876         set_semantics_rule_main(R),
4877         set_semantics_rules_main(Rs).
4879 set_semantics_rule_main(PragmaRule) :-
4880         PragmaRule = pragma(Rule,IDs,Pragmas,_,RuleNb),
4881         ( Rule = rule([C1],[C2],true,_),
4882           IDs = ids([ID1],[ID2]),
4883           \+ is_passive(RuleNb,ID1),
4884           functor(C1,F,A),
4885           get_functional_dependency(F/A,RuleNb,Pattern,Key),
4886           copy_term_nat(Pattern-Key,C1-Key1),
4887           copy_term_nat(Pattern-Key,C2-Key2),
4888           Key1 == Key2 ->
4889                 passive(RuleNb,ID2)
4890         ;
4891                 true
4892         ).
4894 check_unique_constraints(C1,C2,G,RuleNb,List) :-
4895         \+ any_passive_head(RuleNb),
4896         variable_replacement(C1-C2,C2-C1,List),
4897         copy_with_variable_replacement(G,OtherG,List),
4898         negate_b(G,NotG),
4899         once(entails_b(NotG,OtherG)).
4901         % checks for rules of the shape ...,C1,C2... (<|=)==> ...
4902         % where C1 and C2 are symmteric constraints
4903 symmetry_analysis(Rules) :-
4904         ( chr_pp_flag(check_unnecessary_active,off) ->
4905                 true
4906         ;
4907                 symmetry_analysis_main(Rules)
4908         ).
4910 symmetry_analysis_main([]).
4911 symmetry_analysis_main([R|Rs]) :-
4912         R = pragma(Rule,ids(IDs1,IDs2),_,_,RuleNb),
4913         Rule = rule(H1,H2,_,_),
4914         ( ( \+ chr_pp_flag(check_unnecessary_active,simplification)
4915           ; H2 == [] ), H1 \== [] ->
4916                 symmetry_analysis_heads(H1,IDs1,[],[],Rule,RuleNb),
4917                 symmetry_analysis_heads(H2,IDs2,[],[],Rule,RuleNb)
4918         ;
4919                 true
4920         ),       
4921         symmetry_analysis_main(Rs).
4923 symmetry_analysis_heads([],[],_,_,_,_).
4924 symmetry_analysis_heads([H|Hs],[ID|IDs],PreHs,PreIDs,Rule,RuleNb) :-
4925         ( \+ is_passive(RuleNb,ID),
4926           member2(PreHs,PreIDs,PreH-PreID),
4927           \+ is_passive(RuleNb,PreID),
4928           variable_replacement(PreH,H,List),
4929           copy_with_variable_replacement(Rule,Rule2,List),
4930           identical_rules(Rule,Rule2) ->
4931                 passive(RuleNb,ID)
4932         ;
4933                 true
4934         ),
4935         symmetry_analysis_heads(Hs,IDs,[H|PreHs],[ID|PreIDs],Rule,RuleNb).
4937 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4939 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
4940 %%  ____  _                 _ _  __ _           _   _
4941 %% / ___|(_)_ __ ___  _ __ | (_)/ _(_) ___ __ _| |_(_) ___  _ __
4942 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
4943 %%  ___) | | | | | | | |_) | | |  _| | (_| (_| | |_| | (_) | | | |
4944 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
4945 %%                   |_| 
4947 simplification_code(Head,ID,RestHeads,RestIDs,PragmaRule,F/A,O,Id,L,T) :-
4948         PragmaRule = pragma(Rule,_,Pragmas,_,_RuleNb),
4949         head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
4950         build_head(F,A,Id,HeadVars,ClauseHead),
4951         get_constraint_mode(F/A,Mode),
4952         head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
4953         
4954         guard_splitting(Rule,GuardList),
4955         guard_via_reschedule_new(RestHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),  
4957         rest_heads_retrieval_and_matching(RestHeads,RestIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
4958         
4959         guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
4960         
4961         gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
4962         gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
4964         ( chr_pp_flag(debugable,on) ->
4965                 Rule = rule(_,_,Guard,Body),
4966                 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),            
4967                 sort_by_key([Susp|Susps],[ID|RestIDs],SortedSusps),
4968                 DebugTry   = 'chr debug_event'(  try(SortedSusps,[],DebugGuard,DebugBody)),
4969                 DebugApply = 'chr debug_event'(apply(SortedSusps,[],DebugGuard,DebugBody)),
4970                 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
4971         ;
4972                 Cut = ActualCut
4973         ),
4974         ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) -> ActualCut = true ; ActualCut = (!) ),     
4975         Clause = ( ClauseHead :-
4976                         FirstMatching, 
4977                      RescheduledTest,
4978                      Cut,
4979                      SuspsDetachments,
4980                      SuspDetachment,
4981                      BodyCopy
4982                  ),
4983         L = [Clause | T].
4985 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict) :-
4986         head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,[],_).
4988 head_arg_matches(Pairs,Modes,VarDict,Goal,NVarDict,GroundVars,NGroundVars) :-
4989         head_arg_matches_(Pairs,Modes,VarDict,GroundVars,GoalList,NVarDict,NGroundVars),
4990         list2conj(GoalList,Goal).
4992 head_arg_matches_([],[],VarDict,GroundVars,[],VarDict,GroundVars).
4993 head_arg_matches_([Arg-Var| Rest],[Mode|Modes],VarDict,GroundVars,GoalList,NVarDict,NGroundVars) :-
4994    (   var(Arg) ->
4995        ( lookup_eq(VarDict,Arg,OtherVar) ->
4996            ( Mode = (+) ->
4997                 ( memberchk_eq(Arg,GroundVars) ->
4998                         GoalList = [Var = OtherVar | RestGoalList],
4999                         GroundVars1 = GroundVars
5000                 ;
5001                         GoalList = [Var == OtherVar | RestGoalList],
5002                         GroundVars1 = [Arg|GroundVars]
5003                 )
5004            ;
5005                 GoalList = [Var == OtherVar | RestGoalList],
5006                 GroundVars1 = GroundVars
5007            ),
5008            VarDict1 = VarDict
5009        ;   VarDict1 = [Arg-Var | VarDict],
5010            GoalList = RestGoalList,
5011            ( Mode = (+) ->
5012                 GroundVars1 = [Arg|GroundVars]
5013            ;
5014                 GroundVars1 = GroundVars
5015            )
5016        ),
5017        Pairs = Rest,
5018        RestModes = Modes        
5019    ;   atomic(Arg) ->
5020        ( Mode = (+) ->
5021                GoalList = [ Var = Arg | RestGoalList]   
5022        ;
5023                GoalList = [ Var == Arg | RestGoalList]
5024        ),
5025        VarDict = VarDict1,
5026        GroundVars1 = GroundVars,
5027        Pairs = Rest,
5028        RestModes = Modes
5029    ;   Mode == (+), is_ground(GroundVars,Arg)  -> 
5030        copy_with_variable_replacement(Arg,ArgCopy,VarDict),
5031        GoalList = [ Var = ArgCopy | RestGoalList],      
5032        VarDict = VarDict1,
5033        GroundVars1 = GroundVars,
5034        Pairs = Rest,
5035        RestModes = Modes
5036    ;   Arg =.. [_|Args],
5037        functor(Arg,Fct,N),
5038        functor(Term,Fct,N),
5039        Term =.. [_|Vars],
5040        ( Mode = (+) ->
5041                 GoalList = [ Var = Term | RestGoalList ] 
5042        ;
5043                 GoalList = [ nonvar(Var), Var = Term | RestGoalList ] 
5044        ),
5045        pairup(Args,Vars,NewPairs),
5046        append(NewPairs,Rest,Pairs),
5047        replicate(N,Mode,NewModes),
5048        append(NewModes,Modes,RestModes),
5049        VarDict1 = VarDict,
5050        GroundVars1 = GroundVars
5051    ),
5052    head_arg_matches_(Pairs,RestModes,VarDict1,GroundVars1,RestGoalList,NVarDict,NGroundVars).
5054 is_ground(GroundVars,Term) :-
5055         ( ground(Term) -> 
5056                 true
5057         ; compound(Term) ->
5058                 Term =.. [_|Args],
5059                 maplist(is_ground(GroundVars),Args)
5060         ;
5061                 memberchk_eq(Term,GroundVars)
5062         ).
5064 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
5065         rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,[],_).
5067 rest_heads_retrieval_and_matching(Heads,IDs,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict,GroundVars,NGroundVars) :-
5068         ( Heads = [_|_] ->
5069                 rest_heads_retrieval_and_matching_n(Heads,IDs,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict,GroundVars,NGroundVars)      
5070         ;
5071                 GoalList = [],
5072                 Susps = [],
5073                 VarDict = NVarDict,
5074                 GroundVars = NGroundVars
5075         ).
5077 rest_heads_retrieval_and_matching_n([],_,_,_,_,[],[],VarDict,VarDict,_AttrDict,GroundVars,GroundVars).
5078 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],PrevHs,PrevSusps,ActiveHead,
5079     [Goal|Goals],[Susp|Susps],VarDict,NVarDict,_AttrDict,GroundVars,NGroundVars) :-
5080         functor(H,F,A),
5081         head_info(H,A,Vars,_,_,Pairs),
5082         get_store_type(F/A,StoreType),
5083         ( StoreType == default ->
5084                 passive_head_via(H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
5085                 delay_phase_end(validate_store_type_assumptions,
5086                         ( static_suspension_term(F/A,Suspension),
5087                           get_static_suspension_term_field(arguments,F/A,Suspension,Vars),
5088                           get_static_suspension_field(F/A,Suspension,state,active,GetState)     
5089                         )
5090                 ),
5091                 % create_get_mutable_ref(active,State,GetMutable),
5092                 get_constraint_mode(F/A,Mode),
5093                 head_arg_matches(Pairs,Mode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1),
5094                 NPairs = Pairs,
5095                 sbag_member_call(Susp,VarSusps,Sbag),
5096                 ExistentialLookup =     (
5097                                                 ViaGoal,
5098                                                 Sbag,
5099                                                 Susp = Suspension,              % not inlined
5100                                                 GetState
5101                                         )
5102         ;
5103                 delay_phase_end(validate_store_type_assumptions,
5104                         ( static_suspension_term(F/A,Suspension),
5105                           get_static_suspension_term_field(arguments,F/A,Suspension,Vars)
5106                         )
5107                 ),
5108                 existential_lookup(StoreType,H,[ActiveHead|PrevHs],VarDict,Suspension,ExistentialLookup,Susp,Pairs,NPairs),
5109                 get_constraint_mode(F/A,Mode),
5110                 filter_mode(NPairs,Pairs,Mode,NMode),
5111                 head_arg_matches(NPairs,NMode,VarDict,MatchingGoal,VarDict1,GroundVars,GroundVars1)
5112         ),
5113         different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
5114         append(NPairs,VarDict1,DA_),            % order important here
5115         translate(GroundVars1,DA_,GroundVarsA),
5116         translate(GroundVars1,VarDict1,GroundVarsB),
5117         inline_matching_goal(MatchingGoal,MatchingGoal2,GroundVarsA,GroundVarsB),
5118         Goal = 
5119         (
5120                 ExistentialLookup,
5121                 DiffSuspGoals,
5122                 MatchingGoal2
5123         ),
5124         rest_heads_retrieval_and_matching_n(Hs,IDs,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,_NewAttrDict,GroundVars1,NGroundVars).
5126 inline_matching_goal(A==B,true,GVA,GVB) :- 
5127     memberchk_eq(A,GVA),
5128     memberchk_eq(B,GVB),
5129     A=B, !.
5130     
5131 % inline_matching_goal(A=B,true,_,_) :- A=B, !.
5132 inline_matching_goal((A,B),(A2,B2),GVA,GVB) :- !,
5133     inline_matching_goal(A,A2,GVA,GVB),
5134     inline_matching_goal(B,B2,GVA,GVB).
5135 inline_matching_goal(X,X,_,_).
5138 filter_mode([],_,_,[]).
5139 filter_mode([Arg-Var|Rest],[_-V|R],[M|Ms],Modes) :-
5140         ( Var == V ->
5141                 Modes = [M|MT],
5142                 filter_mode(Rest,R,Ms,MT)
5143         ;
5144                 filter_mode([Arg-Var|Rest],R,Ms,Modes)
5145         ).
5147 check_unique_keys([],_).
5148 check_unique_keys([V|Vs],Dict) :-
5149         lookup_eq(Dict,V,_),
5150         check_unique_keys(Vs,Dict).
5152 % Generates tests to ensure the found constraint differs from previously found constraints
5153 %       TODO: detect more cases where constraints need be different
5154 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
5155         different_from_other_susps_(Heads,Susps,Head,Susp,DiffSuspGoalList),
5156         list2conj(DiffSuspGoalList,DiffSuspGoals).
5158 different_from_other_susps_(_,[],_,_,[]) :- !.
5159 different_from_other_susps_([PreHead|Heads],[PreSusp|Susps],Head,Susp,List) :-
5160         ( functor(Head,F,A), functor(PreHead,F,A),
5161           copy_term_nat(PreHead-Head,PreHeadCopy-HeadCopy),
5162           \+ \+ PreHeadCopy = HeadCopy ->
5164                 List = [Susp \== PreSusp | Tail]
5165         ;
5166                 List = Tail
5167         ),
5168         different_from_other_susps_(Heads,Susps,Head,Susp,Tail).
5170 % passive_head_via(in,in,in,in,out,out,out) :-
5171 passive_head_via(Head,PrevHeads,VarDict,Goal,AllSusps) :-
5172         functor(Head,F,A),
5173         get_constraint_index(F/A,Pos),
5174         common_variables(Head,PrevHeads,CommonVars),
5175         global_list_store_name(F/A,Name),
5176         GlobalGoal = nb_getval(Name,AllSusps),
5177         get_constraint_mode(F/A,ArgModes),
5178         ( Vars == [] ->
5179                 Goal = GlobalGoal
5180         ; member(CommonVar,CommonVars), nth(I,ArgModes,(-)), arg(I,Head,Arg), Arg == CommonVar ->
5181                 translate([CommonVar],VarDict,[Var]),
5182                 gen_get_mod_constraints(F/A,Var,AttrGoal,AllSusps),
5183                 Goal = AttrGoal
5184         ; 
5185                 translate(CommonVars,VarDict,Vars),
5186                 gen_get_mod_constraints(F/A,Vars,ViaGoal,AttrGoal,AllSusps),
5187                 Goal = 
5188                         ( ViaGoal ->
5189                                 AttrGoal
5190                         ;
5191                                 GlobalGoal
5192                         )
5193         ).
5195 common_variables(T,Ts,Vs) :-
5196         term_variables(T,V1),
5197         term_variables(Ts,V2),
5198         intersect_eq(V1,V2,Vs).
5200 gen_get_mod_constraints(FA,Vars,ViaGoal,AttrGoal,AllSusps) :-
5201         get_target_module(Mod),
5202         ( Vars = [A] ->
5203                 ViaGoal =  'chr newvia_1'(A,V)
5204         ; Vars = [A,B] ->
5205                 ViaGoal = 'chr newvia_2'(A,B,V)
5206         ;   
5207                 ViaGoal = 'chr newvia'(Vars,V)
5208         ),
5209         AttrGoal =
5210         (   get_attr(V,Mod,TSusps),
5211             TSuspsEqSusps % TSusps = Susps
5212         ),
5213         get_max_constraint_index(N),
5214         ( N == 1 ->
5215                 TSuspsEqSusps = true, % TSusps = Susps
5216                 AllSusps = TSusps
5217         ;
5218                 TSuspsEqSusps = (TSusps = Susps),
5219                 get_constraint_index(FA,Pos),
5220                 make_attr(N,_,SuspsList,Susps),
5221                 nth1(Pos,SuspsList,AllSusps)
5222         ).
5223 gen_get_mod_constraints(FA,Var,AttrGoal,AllSusps) :-
5224         get_target_module(Mod),
5225         AttrGoal =
5226         (   get_attr(Var,Mod,TSusps),
5227             TSuspsEqSusps % TSusps = Susps
5228         ),
5229         get_max_constraint_index(N),
5230         ( N == 1 ->
5231                 TSuspsEqSusps = true, % TSusps = Susps
5232                 AllSusps = TSusps
5233         ;
5234                 TSuspsEqSusps = (TSusps = Susps),
5235                 get_constraint_index(FA,Pos),
5236                 make_attr(N,_,SuspsList,Susps),
5237                 nth1(Pos,SuspsList,AllSusps)
5238         ).
5240 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
5241         guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
5242         list2conj(GuardCopyList,GuardCopy).
5244 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
5245         Rule = rule(H,_,Guard,Body),
5246         conj2list(Guard,GuardList),
5247         split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
5248         my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
5250         append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
5251         term_variables(RestGuardList,GuardVars),
5252         term_variables(RestGuardListCopyCore,GuardCopyVars),
5253         % variables that are declared to be ground don't need to be locked
5254         ground_vars(H,GroundVars),      
5255         list_difference_eq(GuardVars,GroundVars,GuardVars_),
5256         ( chr_pp_flag(guard_locks,on),
5257           bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
5258                 X ^ (lists:member(X,GuardVars),         % X is a variable appearing in the original guard
5259                      pairlist:lookup_eq(VarDict,X,Y),            % translate X into new variable
5260                      memberchk_eq(Y,GuardCopyVars)      % redundant check? or multiple entries for X possible?
5261                     ),
5262                 LocksUnlocks) ->
5263                 once(pairup(Locks,Unlocks,LocksUnlocks))
5264         ;
5265                 Locks = [],
5266                 Unlocks = []
5267         ),
5268         list2conj(Locks,LockPhase),
5269         list2conj(Unlocks,UnlockPhase),
5270         list2conj(RestGuardListCopyCore,RestGuardCopyCore),
5271         RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
5272         my_term_copy(Body,VarDict2,BodyCopy).
5275 split_off_simple_guard([],_,[],[]).
5276 split_off_simple_guard([G|Gs],VarDict,S,C) :-
5277         ( simple_guard(G,VarDict) ->
5278                 S = [G|Ss],
5279                 split_off_simple_guard(Gs,VarDict,Ss,C)
5280         ;
5281                 S = [],
5282                 C = [G|Gs]
5283         ).
5285 % simple guard: cheap and benign (does not bind variables)
5286 simple_guard(G,VarDict) :-
5287         binds_b(G,Vars),
5288         \+ (( member(V,Vars), 
5289              lookup_eq(VarDict,V,_)
5290            )).
5292 gen_cond_susp_detachment(Id,Susp,FA,SuspDetachment) :-
5293         ( is_stored(FA) ->
5294                 ( (Id == [0]; 
5295                   (get_allocation_occurrence(FA,AO),
5296                    get_max_occurrence(FA,MO), 
5297                    MO < AO )), 
5298                   only_ground_indexed_arguments(FA), chr_pp_flag(late_allocation,on) ->
5299                         SuspDetachment = true
5300                 ;
5301                         gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
5302                         ( chr_pp_flag(late_allocation,on) ->
5303                                 SuspDetachment = 
5304                                 (   var(Susp) ->
5305                                     true
5306                                 ;   UnCondSuspDetachment
5307                                 )
5308                         ;
5309                                 SuspDetachment = UnCondSuspDetachment
5310                         )
5311                 )
5312         ;
5313                 SuspDetachment = true
5314         ).
5316 gen_uncond_susp_detachment(Susp,FA,SuspDetachment) :-
5317    ( is_stored(FA) ->
5318         ( \+ only_ground_indexed_arguments(FA), \+ get_store_type(FA,var_assoc_store(_,_)) ->
5319                 detach_constraint_atom(FA,Vars,Susp,Detach)
5320         ;
5321                 Detach = true
5322         ),
5323         ( chr_pp_flag(debugable,on) ->
5324                 DebugEvent = 'chr debug_event'(remove(Susp))
5325         ;
5326                 DebugEvent = true
5327         ),
5328         generate_delete_constraint_call(FA,Susp,DeleteCall),
5329         remove_constraint_goal(FA,Susp,Vars,true,(DeleteCall,Detach),RemoveInternalGoal),
5330         SuspDetachment = ( DebugEvent, RemoveInternalGoal)
5331    ;
5332         SuspDetachment = true
5333    ).
5335 gen_uncond_susps_detachments([],[],true).
5336 gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
5337    functor(Term,F,A),
5338    gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
5339    gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
5341 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5343 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5344 %%  ____  _                                   _   _               _
5345 %% / ___|(_)_ __ ___  _ __   __ _  __ _  __ _| |_(_) ___  _ __   / |
5346 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \  | |
5347 %%  ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
5348 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
5349 %%                   |_|          |___/
5351 simpagation_head1_code(Head,ID,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
5352         PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name,_RuleNb),
5353         Rule = rule(_Heads,Heads2,Guard,Body),
5355         head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
5356         get_constraint_mode(F/A,Mode),
5357         head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict1,[],GroundVars),
5359         build_head(F,A,Id,HeadVars,ClauseHead),
5361         append(RestHeads,Heads2,Heads),
5362         append(OtherIDs,Heads2IDs,IDs),
5363         reorder_heads(RuleNb,Head,Heads,IDs,NHeads,NIDs),
5364    
5365         guard_splitting(Rule,GuardList),
5366         guard_via_reschedule_new(NHeads,GuardList,Head,GuardCopyList,GetRestHeads,RescheduledTest),     
5368         rest_heads_retrieval_and_matching(NHeads,NIDs,Head,GetRestHeads,Susps,VarDict1,VarDict,[],[],[],GroundVars,_),
5369         split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps1IDs,Susps2,Susps2IDs), 
5371         guard_body_copies3(Rule,GuardList,VarDict,GuardCopyList,BodyCopy),
5373         sort_by_key(Susps1,Susps1IDs,SortedSusps1),
5374         gen_uncond_susps_detachments(SortedSusps1,RestHeads,SuspsDetachments),
5375         gen_cond_susp_detachment(Id,Susp,F/A,SuspDetachment),
5376    
5377         ( chr_pp_flag(debugable,on) ->
5378                 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),            
5379                 sort_by_key([Susp|Susps1],[ID|Susps1IDs],RemovedSusps),
5380                 sort_by_key(Susps2,Susps2IDs,KeptSusps),
5381                 DebugTry   = 'chr debug_event'(  try(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
5382                 DebugApply = 'chr debug_event'(apply(RemovedSusps,KeptSusps,DebugGuard,DebugBody)),
5383                 instrument_goal((!),DebugTry,DebugApply,Cut)
5384         ;
5385                 Cut = (!)
5386         ),
5388    Clause = ( ClauseHead :-
5389                 FirstMatching, 
5390                 RescheduledTest,
5391                 Cut,
5392                 SuspsDetachments,
5393                 SuspDetachment,
5394                 BodyCopy
5395             ),
5396    L = [Clause | T].
5398 split_by_ids([],[],_,[],[]).
5399 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
5400         ( memberchk_eq(I,I1s) ->
5401                 S1s = [S | R1s],
5402                 S2s = R2s
5403         ;
5404                 S1s = R1s,
5405                 S2s = [S | R2s]
5406         ),
5407         split_by_ids(Is,Ss,I1s,R1s,R2s).
5409 split_by_ids([],[],_,[],[],[],[]).
5410 split_by_ids([I|Is],[S|Ss],I1s,S1s,SI1s,S2s,SI2s) :-
5411         ( memberchk_eq(I,I1s) ->
5412                 S1s  = [S | R1s],
5413                 SI1s = [I|RSI1s],
5414                 S2s = R2s,
5415                 SI2s = RSI2s
5416         ;
5417                 S1s = R1s,
5418                 SI1s = RSI1s,
5419                 S2s = [S | R2s],
5420                 SI2s = [I|RSI2s]
5421         ),
5422         split_by_ids(Is,Ss,I1s,R1s,RSI1s,R2s,RSI2s).
5423 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5426 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5427 %%  ____  _                                   _   _               ____
5428 %% / ___|(_)_ __ ___  _ __   __ _  __ _  __ _| |_(_) ___  _ __   |___ \
5429 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \    __) |
5430 %%  ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | |  / __/
5431 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
5432 %%                   |_|          |___/
5434 %% Genereate prelude + worker predicate
5435 %% prelude calls worker
5436 %% worker iterates over one type of removed constraints
5437 simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,O,Id,L,T) :-
5438    PragmaRule = pragma(Rule,ids(IDs1,IDs2),Pragmas,_Name,RuleNb),
5439    Rule = rule(Heads1,_,Guard,Body),
5440    append(Heads1,RestHeads2,Heads),
5441    append(IDs1,RestIDs,IDs),
5442    reorder_heads(RuleNb,Head2,Heads,IDs,[NHead|NHeads],[NID|NIDs]),
5443    simpagation_head2_prelude(Head2,NHead,[NHeads,Guard,Body],FA,O,Id,L,L1),
5444    extend_id(Id,Id1),
5445    ( memberchk_eq(NID,IDs2) ->
5446         simpagation_universal_searches(NHeads,NIDs,IDs2,[NHead,Head2],Rule,FA,NextHeads,PreHeads,NextIDs,Id1,Id2,L1,L2)
5447    ;
5448         L1 = L2, Id1 = Id2,NextHeads = NHeads, PreHeads = [NHead,Head2], NextIDs = NIDs
5449    ),
5450    universal_search_iterator_end(PreHeads,NextHeads,Rule,FA,Id2,L2,L3),
5451    simpagation_head2_worker(PreHeads,NextHeads,NextIDs,PragmaRule,FA,O,Id2,L3,T).
5453 simpagation_universal_searches([],[],_,PreHeads,_,_,[],PreHeads,[],Id,Id,L,L).
5454 simpagation_universal_searches(Heads,[ID|IDs],IDs2,PreHeads,Rule,C,OutHeads,OutPreHeads,OutIDs,Id,NId,L,T) :-
5455         Heads = [Head|RHeads],
5456         inc_id(Id,Id1),
5457         universal_search_iterator_end(PreHeads,Heads,Rule,C,Id,L,L0),
5458         universal_search_iterator(Heads,PreHeads,Rule,C,Id,L0,L1),
5459         ( memberchk_eq(ID,IDs2) ->
5460                 simpagation_universal_searches(RHeads,IDs,IDs2,[Head|PreHeads],Rule,C,OutHeads,OutPreHeads,OutIDs,Id1,NId,L1,T)
5461         ;
5462                 NId = Id1, L1 = T, OutHeads = RHeads, OutPreHeads = [Head|PreHeads], IDs = OutIDs
5463         ).
5465 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5466 simpagation_head2_prelude(Head,Head1,Rest,F/A,O,Id1,L,T) :-
5467         head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
5468         build_head(F,A,Id1,VarsSusp,ClauseHead),
5469         get_constraint_mode(F/A,Mode),
5470         head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict),
5472         lookup_passive_head(Head1,[Head],VarDict,ModConstraintsGoal,AllSusps),
5474         gen_occ_allocation(F/A,O,Vars,Susp,ConstraintAllocationGoal),
5476         extend_id(Id1,DelegateId),
5477         extra_active_delegate_variables(Head,[Head1|Rest],VarDict,ExtraVars),
5478         append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
5479         build_head(F,A,DelegateId,DelegateCallVars,Delegate),
5481         PreludeClause = 
5482            ( ClauseHead :-
5483                   FirstMatching,
5484                   ModConstraintsGoal,
5485                   !,
5486                   ConstraintAllocationGoal,
5487                   Delegate
5488            ),
5489         L = [PreludeClause|T].
5491 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
5492         Term =.. [_|Args],
5493         delegate_variables(Term,Terms,VarDict,Args,Vars).
5495 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
5496         term_variables(PrevTerms,PrevVars),
5497         delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
5499 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
5500         term_variables(Term,V1),
5501         term_variables(Terms,V2),
5502         intersect_eq(V1,V2,V3),
5503         list_difference_eq(V3,PrevVars,V4),
5504         translate(V4,VarDict,Vars).
5505         
5506         
5507 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5508 simpagation_head2_worker([CurrentHead|PreHeads],NextHeads,NextIDs,PragmaRule,F/A,O,Id,L,T) :-
5509         PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_,RuleNb), 
5510         Rule = rule(_,_,Guard,Body),
5511         get_prop_inner_loop_vars(PreHeads,[CurrentHead,NextHeads,Guard,Body],PreVarsAndSusps,VarDict,Susp,Vars,PreSusps),
5512         
5513         gen_var(OtherSusp),
5514         gen_var(OtherSusps),
5515         
5516         functor(CurrentHead,OtherF,OtherA),
5517         gen_vars(OtherA,OtherVars),
5518         head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
5519         get_constraint_mode(OtherF/OtherA,Mode),
5520         head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1,[],GroundVars),
5521         
5522         delay_phase_end(validate_store_type_assumptions,
5523                 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
5524                   get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
5525                   get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
5526                 )
5527         ),
5528         % create_get_mutable_ref(active,State,GetMutable),
5529         different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
5530         CurrentSuspTest = (
5531            OtherSusp = OtherSuspension,
5532            GetState,
5533            DiffSuspGoals,
5534            FirstMatching
5535         ),
5536         
5537         ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
5538         build_head(F,A,Id,ClauseVars,ClauseHead),
5539         
5540         guard_splitting(Rule,GuardList),
5541         guard_via_reschedule_new(NextHeads,GuardList,[CurrentHead|PreHeads],GuardCopyList,RestSuspsRetrieval,RescheduledTest),  
5543         rest_heads_retrieval_and_matching(NextHeads,NextIDs,[CurrentHead|PreHeads],RestSuspsRetrieval,Susps,VarDict1,VarDict2,[CurrentHead|PreHeads],[OtherSusp|PreSusps],[]),
5544         split_by_ids(NextIDs,Susps,IDs1,Susps1,Susps2),
5545         split_by_ids(NextIDs,NextHeads,IDs1,RestHeads1,_),
5546         
5547         gen_uncond_susps_detachments([OtherSusp | Susps1],[CurrentHead|RestHeads1],Susps1Detachments),
5548         
5549         RecursiveVars = [OtherSusps|PreVarsAndSusps],
5550         build_head(F,A,Id,RecursiveVars,RecursiveCall),
5551         RecursiveVars2 = [[]|PreVarsAndSusps],
5552         build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
5553         
5554         guard_body_copies3(Rule,GuardList,VarDict2,GuardCopyList,BodyCopy),
5555         (   BodyCopy \== true, is_observed(F/A,O) ->
5556             gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
5557             gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall),
5558             gen_state_cond_call(Susp,F/A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
5559         ;   Attachment = true,
5560             ConditionalRecursiveCall = RecursiveCall,
5561             ConditionalRecursiveCall2 = RecursiveCall2
5562         ),
5563         
5564         ( chr_pp_flag(debugable,on) ->
5565                 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),            
5566                 DebugTry   = 'chr debug_event'(  try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
5567                 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
5568         ;
5569                 DebugTry = true,
5570                 DebugApply = true
5571         ),
5572         
5573         ( member(unique(ID1,UniqueKeys), Pragmas),
5574           check_unique_keys(UniqueKeys,VarDict) ->
5575              Clause =
5576                 ( ClauseHead :-
5577                         ( CurrentSuspTest ->
5578                                 ( RescheduledTest,
5579                                   DebugTry ->
5580                                         DebugApply,
5581                                         Susps1Detachments,
5582                                         Attachment,
5583                                         BodyCopy,
5584                                         ConditionalRecursiveCall2
5585                                 ;
5586                                         RecursiveCall2
5587                                 )
5588                         ;
5589                                 RecursiveCall
5590                         )
5591                 )
5592          ;
5593              Clause =
5594                         ( ClauseHead :-
5595                                 ( CurrentSuspTest,
5596                           RescheduledTest,
5597                           DebugTry ->
5598                                 DebugApply,
5599                                 Susps1Detachments,
5600                                 Attachment,
5601                                 BodyCopy,
5602                                 ConditionalRecursiveCall
5603                         ;
5604                                 RecursiveCall
5605                         )
5606                 )
5607         ),
5608         L = [Clause | T].
5610 gen_state_cond_call(Susp,FA,Call,Generation,ConditionalCall) :-
5611         ( may_trigger(FA) ->
5612                 does_use_field(FA,generation),
5613                 delay_phase_end(validate_store_type_assumptions,
5614                         ( static_suspension_term(FA,Suspension),
5615                           get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
5616                           get_static_suspension_field(FA,Suspension,generation,Generation,GetGeneration),
5617                           get_static_suspension_term_field(arguments,FA,Suspension,Args)
5618                         )
5619                 )
5620         ;
5621                 delay_phase_end(validate_store_type_assumptions,
5622                         ( static_suspension_term(FA,Suspension),
5623                           get_update_static_suspension_field(FA,Susp,Suspension,state,active,inactive,GetState,UpdateState),
5624                           get_static_suspension_term_field(arguments,FA,Suspension,Args)
5625                         )
5626                 ),
5627                 GetGeneration = true
5628         ),
5629         ConditionalCall =
5630         (       Susp = Suspension,
5631                 GetState,
5632                 GetGeneration ->
5633                         UpdateState,
5634                         Call
5635                 ;   
5636                         true
5637         ).
5639 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5642 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5643 %%  ____                                    _   _             
5644 %% |  _ \ _ __ ___  _ __   __ _  __ _  __ _| |_(_) ___  _ __  
5645 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ 
5646 %% |  __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
5647 %% |_|   |_|  \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
5648 %%                 |_|          |___/                         
5650 propagation_code(Head,ID,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
5651         ( RestHeads == [] ->
5652                 propagation_single_headed(Head,Rule,RuleNb,FA,O,Id,L,T)
5653         ;   
5654                 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T)
5655         ).
5656 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5657 %% Single headed propagation
5658 %% everything in a single clause
5659 propagation_single_headed(Head,Rule,RuleNb,F/A,O,Id,ProgramList,ProgramTail) :-
5660         head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
5661         build_head(F,A,Id,VarsSusp,ClauseHead),
5662         
5663         inc_id(Id,NextId),
5664         build_head(F,A,NextId,VarsSusp,NextHead),
5665         
5666         get_constraint_mode(F/A,Mode),
5667         head_arg_matches(HeadPairs,Mode,[],HeadMatching,VarDict,[],GroundVars),
5668         guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
5669         gen_occ_allocation(F/A,O,Vars,Susp,Allocation),
5670         
5671         % - recursive call -
5672         RecursiveCall = NextHead,
5673         ( Body \== true, is_observed(F/A,O) ->
5674             gen_uncond_attach_goal(F/A,Susp,Vars,Attachment,Generation),
5675             gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
5676         ;   Attachment = true,
5677             ConditionalRecursiveCall = RecursiveCall
5678         ),
5680         ( unconditional_occurrence(F/A,O), chr_pp_flag(late_allocation,on) ->
5681                 ActualCut = true
5682         ;
5683                 ActualCut = !
5684         ),
5686         ( chr_pp_flag(debugable,on) ->
5687                 Rule = rule(_,_,Guard,Body),
5688                 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),            
5689                 DebugTry   = 'chr debug_event'(  try([],[Susp],DebugGuard,DebugBody)),
5690                 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody)),
5691                 instrument_goal(ActualCut,DebugTry,DebugApply,Cut)
5692         ;
5693                 Cut = ActualCut
5694         ),
5695         ( may_trigger(F/A), \+ has_no_history(RuleNb)->
5696                 use_auxiliary_predicate(novel_production),
5697                 use_auxiliary_predicate(extend_history),
5698                 does_use_history(F/A,O),
5699                 NovelProduction = '$novel_production'(Susp,RuleNb),     % optimisation of t(RuleNb,Susp)
5700                 ExtendHistory   = '$extend_history'(Susp,RuleNb)
5701         ;
5702                 NovelProduction = true,
5703                 ExtendHistory   = true
5704         ),
5706         Clause = (
5707              ClauseHead :-
5708                 HeadMatching,
5709                 Allocation,
5710                 NovelProduction,
5711                 GuardCopy,
5712                 Cut,
5713                 ExtendHistory,
5714                 Attachment,
5715                 BodyCopy,
5716                 ConditionalRecursiveCall
5717         ),  
5718         ProgramList = [Clause | ProgramTail].
5719    
5720 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5721 %% multi headed propagation
5722 %% prelude + predicates to accumulate the necessary combinations of suspended
5723 %% constraints + predicate to execute the body
5724 propagation_multi_headed(Head,RestHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
5725    RestHeads = [First|Rest],
5726    propagation_prelude(Head,RestHeads,Rule,FA,O,Id,L,L1),
5727    extend_id(Id,ExtendedId),
5728    propagation_nested_code(Rest,[First,Head],RestIDs,Rule,RuleNb,FA,O,ExtendedId,L1,T).
5730 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5731 propagation_prelude(Head,[First|Rest],Rule,F/A,O,Id,L,T) :-
5732    head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
5733    build_head(F,A,Id,VarsSusp,PreludeHead),
5734    get_constraint_mode(F/A,Mode),
5735    head_arg_matches(HeadPairs,Mode,[],FirstMatching,VarDict),
5736    Rule = rule(_,_,Guard,Body),
5737    extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
5739    lookup_passive_head(First,[Head],VarDict,FirstSuspGoal,Susps),
5741    gen_occ_allocation(F/A,O,Vars,Susp,CondAllocation),
5743    extend_id(Id,NestedId),
5744    append([Susps|VarsSusp],ExtraVars,NestedVars), 
5745    build_head(F,A,NestedId,NestedVars,NestedHead),
5746    NestedCall = NestedHead,
5748    Prelude = (
5749       PreludeHead :-
5750           FirstMatching,
5751           FirstSuspGoal,
5752           !,
5753           CondAllocation,
5754           NestedCall
5755    ),
5756    L = [Prelude|T].
5758 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5759 propagation_nested_code([],[CurrentHead|PreHeads],RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
5760    universal_search_iterator_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
5761    propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L1,T).
5763 propagation_nested_code([Head|RestHeads],PreHeads,RestIDs,Rule,RuleNb,FA,O,Id,L,T) :-
5764    universal_search_iterator_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
5765    universal_search_iterator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
5766    inc_id(Id,IncId),
5767    propagation_nested_code(RestHeads,[Head|PreHeads],RestIDs,Rule,RuleNb,FA,O,IncId,L2,T).
5769 %check_fd_lookup_condition(_,_,_,_) :- fail.
5770 check_fd_lookup_condition(F,A,_,_) :-
5771         get_store_type(F/A,global_singleton), !.
5772 check_fd_lookup_condition(F,A,CurrentHead,PreHeads) :-
5773         \+ may_trigger(F/A),
5774         get_functional_dependency(F/A,1,P,K),
5775         copy_term(P-K,CurrentHead-Key),
5776         term_variables(PreHeads,PreVars),
5777         intersect_eq(Key,PreVars,Key),!.                
5779 propagation_body(CurrentHead,PreHeads,RestIDs,Rule,RuleNb,F/A,O,Id,L,T) :-
5780         Rule = rule(_,H2,Guard,Body),
5781         gen_var_susp_list_for_b(PreHeads,[CurrentHead,Guard,Body],VarDict1,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
5782         flatten(PreVarsAndSuspsList,PreVarsAndSusps),
5783         init(AllSusps,RestSusps),
5784         last(AllSusps,Susp),    
5785         gen_var(OtherSusp),
5786         gen_var(OtherSusps),
5787         functor(CurrentHead,OtherF,OtherA),
5788         gen_vars(OtherA,OtherVars),
5789         delay_phase_end(validate_store_type_assumptions,
5790                 ( static_suspension_term(OtherF/OtherA,Suspension),
5791                   get_static_suspension_field(OtherF/OtherA,Suspension,state,active,GetState),
5792                   get_static_suspension_term_field(arguments,OtherF/OtherA,Suspension,OtherVars)
5793                 )
5794         ),
5795         % create_get_mutable_ref(active,State,GetMutable),
5796         CurrentSuspTest = (
5797            OtherSusp = Suspension,
5798            GetState
5799         ),
5800         ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
5801         build_head(F,A,Id,ClauseVars,ClauseHead),
5802         ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) ->      % iterator (OtherSusps) is empty at runtime
5803                 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
5804                 RecursiveVars = PreVarsAndSusps1
5805         ;
5806                 RecursiveVars = [OtherSusps|PreVarsAndSusps],
5807                 PrevId = Id
5808         ),
5809         build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
5810         RecursiveCall = RecursiveHead,
5811         CurrentHead =.. [_|OtherArgs],
5812         pairup(OtherArgs,OtherVars,OtherPairs),
5813         get_constraint_mode(OtherF/OtherA,Mode),
5814         head_arg_matches(OtherPairs,Mode,VarDict1,Matching,VarDict),
5815         
5816         different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals), 
5817         guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
5818         
5819         (   BodyCopy \== true, is_observed(F/A,O) ->
5820             init(FirstVarsSusp,FirstVars),
5821             gen_uncond_attach_goal(F/A,Susp,FirstVars,Attach,Generation),
5822             gen_state_cond_call(Susp,F/A,RecursiveCall,Generation,ConditionalRecursiveCall)
5823         ;   Attach = true,
5824             ConditionalRecursiveCall = RecursiveCall
5825         ),
5826         ( (is_least_occurrence(RuleNb) ; has_no_history(RuleNb)) ->
5827                 NovelProduction = true,
5828                 ExtendHistory   = true
5829         ;         
5830                 get_occurrence(F/A,O,_,ID),
5831                 history_susps(RestIDs,[OtherSusp|RestSusps],Susp,ID,HistorySusps),
5832                 Tuple =.. [t,RuleNb|HistorySusps],
5833                 findall(Functor/Arity,(member(H,H2),functor(H,Functor,Arity)),ConstraintSymbols),       
5834                 sort([ID|RestIDs],HistoryIDs),
5835                 ( \+ may_trigger(F/A), forall(member(SomeID,RestIDs),(chr_translate:is_passive(RuleNb,SomeID))) -> 
5836                         NovelProduction = true,
5837                         ExtendHistory   = true
5838                 ;
5839                         use_auxiliary_predicate(novel_production),
5840                         use_auxiliary_predicate(extend_history),
5841                         does_use_history(F/A,O),
5842                         novel_production_calls(ConstraintSymbols,HistoryIDs,HistorySusps,RuleNb,TupleVar,NovelProductions),
5843                         NovelProduction = ( TupleVar = Tuple, NovelProductions),
5844                         ExtendHistory   = '$extend_history'(Susp,TupleVar)
5845                 )
5846         ),
5849         ( chr_pp_flag(debugable,on) ->
5850                 Rule = rule(_,_,Guard,Body),
5851                 my_term_copy(Guard - Body, VarDict, DebugGuard - DebugBody),            
5852                 get_occurrence(F/A,O,_,ID),
5853                 sort_by_key([Susp,OtherSusp|RestSusps],[ID|RestIDs],KeptSusps),
5854                 DebugTry   = 'chr debug_event'(  try([],KeptSusps,DebugGuard,DebugBody)),
5855                 DebugApply = 'chr debug_event'(apply([],KeptSusps,DebugGuard,DebugBody))
5856         ;
5857                 DebugTry = true,
5858                 DebugApply = true
5859         ),
5861    Clause = (
5862       ClauseHead :-
5863           (   CurrentSuspTest,
5864              DiffSuspGoals,
5865              Matching,
5866              NovelProduction,
5867              GuardCopy,
5868              DebugTry ->
5869              DebugApply,
5870              ExtendHistory,
5871              Attach,
5872              BodyCopy,
5873              ConditionalRecursiveCall
5874          ;   RecursiveCall
5875          )
5876    ),
5877    L = [Clause|T].
5879 novel_production_calls([],[],[],_,_,true).
5880 novel_production_calls([ConstraintSymbol|ConstraintSymbols],[ID|IDs],[Suspension|Suspensions],RuleNb,Tuple,(Goal,Goals)) :-
5881         get_occurrence_from_id(ConstraintSymbol,Occurrence,RuleNb,ID),
5882         delay_phase_end(validate_store_type_assumptions,novel_production_call(ConstraintSymbol,Occurrence,'$novel_production'(Suspension,Tuple),Goal)),
5883         novel_production_calls(ConstraintSymbols,IDs,Suspensions,RuleNb,Tuple,Goals).
5885 history_susps(RestIDs,ReversedRestSusps,Susp,ID,HistorySusps) :-
5886         reverse(ReversedRestSusps,RestSusps),
5887         sort_by_key([Susp|RestSusps],[ID|RestIDs],HistorySusps).
5890 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
5891    !,
5892    functor(Head,F,A),
5893    head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
5894    get_constraint_mode(F/A,Mode),
5895    head_arg_matches(HeadPairs,Mode,[],_,VarDict),
5896    extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
5897    append(VarsSusp,ExtraVars,HeadVars).
5898 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
5899         gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
5900         functor(Head,F,A),
5901         gen_var(Susps),
5902         head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
5903         get_constraint_mode(F/A,Mode),
5904         head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
5905         passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
5906         append(HeadVars,[Susp,Susps|Rest],VarsSusps).
5908         % returns
5909         %       VarDict         for the copies of variables in the original heads
5910         %       VarsSuspsList   list of lists of arguments for the successive heads
5911         %       FirstVarsSusp   top level arguments
5912         %       SuspList        list of all suspensions
5913         %       Iterators       list of all iterators
5914 gen_var_susp_list_for_b([Head],NextHeads,VarDict,[HeadVars],VarsSusp,[Susp],[]) :-
5915         !,
5916         functor(Head,F,A),
5917         head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),                    % make variables for argument positions
5918         get_constraint_mode(F/A,Mode),
5919         head_arg_matches(Pairs,Mode,[],_,VarDict),                              % copy variables inside arguments, build dictionary
5920         extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),      % decide what additional variables are needed
5921         append(VarsSusp,ExtraVars,HeadVars).                                    % add additional variables to head variables
5922 gen_var_susp_list_for_b([Head|Heads],NextHeads,NVarDict,[Vars|RestVars],FirstVarsSusp,[Susp|SuspList],[Susps|Iterators]) :-
5923         gen_var_susp_list_for_b(Heads,[Head|NextHeads],VarDict,RestVars,FirstVarsSusp,SuspList,Iterators),
5924         functor(Head,F,A),
5925         gen_var(Susps),
5926         head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
5927         get_constraint_mode(F/A,Mode),
5928         head_arg_matches(HeadPairs,Mode,VarDict,_,NVarDict),
5929         passive_delegate_variables(Head,Heads,NextHeads,NVarDict,HeadVars),
5930         append(HeadVars,[Susp,Susps],Vars).
5932 get_prop_inner_loop_vars([Head],NextHeads,HeadVars,VarDict,Susp,Vars,[]) :-
5933         !,
5934         functor(Head,F,A),
5935         head_info(Head,A,Vars,Susp,VarsSusp,Pairs),
5936         get_constraint_mode(F/A,Mode),
5937         head_arg_matches(Pairs,Mode,[],_,VarDict),
5938         extra_active_delegate_variables(Head,NextHeads,VarDict,ExtraVars),
5939         append(VarsSusp,ExtraVars,HeadVars).
5940 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,MainVars,[Susp|RestSusps]) :-
5941         get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,MainVars,RestSusps),
5942         functor(Head,F,A),
5943         gen_var(Susps),
5944         head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
5945         get_constraint_mode(F/A,Mode),
5946         head_arg_matches(Pairs,Mode,VarDict,_,NVarDict),
5947         passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
5948         append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
5950 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5952 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
5953 %%  ____               _             _   _                _ 
5954 %% |  _ \ __ _ ___ ___(_)_   _____  | | | | ___  __ _  __| |
5955 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
5956 %% |  __/ (_| \__ \__ \ |\ V /  __/ |  _  |  __/ (_| | (_| |
5957 %% |_|   \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
5958 %%                                                          
5959 %%  ____      _        _                 _ 
5960 %% |  _ \ ___| |_ _ __(_) _____   ____ _| |
5961 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
5962 %% |  _ <  __/ |_| |  | |  __/\ V / (_| | |
5963 %% |_| \_\___|\__|_|  |_|\___| \_/ \__,_|_|
5964 %%                                         
5965 %%  ____                    _           _             
5966 %% |  _ \ ___  ___  _ __ __| | ___ _ __(_)_ __   __ _ 
5967 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
5968 %% |  _ <  __/ (_) | | | (_| |  __/ |  | | | | | (_| |
5969 %% |_| \_\___|\___/|_|  \__,_|\___|_|  |_|_| |_|\__, |
5970 %%                                              |___/ 
5972 reorder_heads(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
5973         ( chr_pp_flag(reorder_heads,on), length(RestHeads,Length), Length =< 6 ->
5974                 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
5975         ;
5976                 NRestHeads = RestHeads,
5977                 NRestIDs = RestIDs
5978         ).
5980 reorder_heads_main(RuleNb,Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
5981         term_variables(Head,Vars),
5982         InitialData = entry([],[],Vars,RestHeads,RestIDs,RuleNb),
5983         copy_term_nat(InitialData,InitialDataCopy),
5984         a_star(InitialDataCopy,FD^(chr_translate:final_data(FD)),N^EN^C^(chr_translate:expand_data(N,EN,C)),FinalData),
5985         InitialDataCopy = InitialData,
5986         FinalData   = entry(RNRestHeads,RNRestIDs,_,_,_,_),
5987         reverse(RNRestHeads,NRestHeads),
5988         reverse(RNRestIDs,NRestIDs).
5990 final_data(Entry) :-
5991         Entry = entry(_,_,_,_,[],_).    
5993 expand_data(Entry,NEntry,Cost) :-
5994         Entry = entry(Heads,IDs,Vars,NHeads,NIDs,RuleNb),
5995         select2(Head1,ID1,NHeads,NIDs,NHeads1,NIDs1),
5996         term_variables([Head1|Vars],Vars1),
5997         NEntry = entry([Head1|Heads],[ID1|IDs],Vars1,NHeads1,NIDs1,RuleNb),
5998         order_score(Head1,ID1,Vars,NHeads1,RuleNb,Cost).
6000         % Assigns score to head based on known variables and heads to lookup
6001 order_score(Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
6002         functor(Head,F,A),
6003         get_store_type(F/A,StoreType),
6004         order_score(StoreType,Head,ID,KnownVars,RestHeads,RuleNb,Score).
6006 order_score(default,Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
6007         term_variables(Head,HeadVars),
6008         term_variables(RestHeads,RestVars),
6009         order_score_vars(HeadVars,KnownVars,RestVars,Score).
6010 order_score(multi_inthash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
6011         order_score_indexes(Indexes,Head,KnownVars,0,Score).
6012 order_score(multi_hash(Indexes),Head,_ID,KnownVars,RestHeads,RuleNb,Score) :-
6013         order_score_indexes(Indexes,Head,KnownVars,0,Score).
6014 order_score(global_ground,Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
6015         term_variables(Head,HeadVars),
6016         term_variables(RestHeads,RestVars),
6017         order_score_vars(HeadVars,KnownVars,RestVars,Score_),
6018         Score is Score_ * 2.
6019 order_score(var_assoc_store(_,_),_,_,_,_,_,1).
6020 order_score(global_singleton,_Head,ID,_KnownVars,_RestHeads,_RuleNb,Score) :-
6021         Score = 1.              % guaranteed O(1)
6022                         
6023 order_score(multi_store(StoreTypes),Head,ID,KnownVars,RestHeads,RuleNb,Score) :-
6024         find_with_var_identity(
6025                 S,
6026                 t(Head,KnownVars,RestHeads),
6027                 ( lists:member(ST,StoreTypes), chr_translate:order_score(ST,Head,ID,KnownVars,RestHeads,RuleNb,S) ),
6028                 Scores
6029         ),
6030         min_list(Scores,Score).
6031                 
6033 order_score_indexes([],_,_,Score,NScore) :-
6034         Score > 0, NScore = 100.
6035 order_score_indexes([I|Is],Head,KnownVars,Score,NScore) :-
6036         multi_hash_key_args(I,Head,Args),
6037         ( forall(Arg,Args,memberchk_eq(Arg,KnownVars)) ->
6038                 Score1 is Score + 1     
6039         ;
6040                 Score1 = Score
6041         ),
6042         order_score_indexes(Is,Head,KnownVars,Score1,NScore).
6044 order_score_vars(Vars,KnownVars,RestVars,Score) :-
6045         order_score_count_vars(Vars,KnownVars,RestVars,K-R-O),
6046         ( K-R-O == 0-0-0 ->
6047                 Score = 0
6048         ; K > 0 ->
6049                 Score is max(10 - K,0)
6050         ; R > 0 ->
6051                 Score is max(10 - R,1) * 10
6052         ; 
6053                 Score is max(10-O,1) * 100
6054         ).      
6055 order_score_count_vars([],_,_,0-0-0).
6056 order_score_count_vars([V|Vs],KnownVars,RestVars,NK-NR-NO) :-
6057         order_score_count_vars(Vs,KnownVars,RestVars,K-R-O),
6058         ( memberchk_eq(V,KnownVars) ->
6059                 NK is K + 1,
6060                 NR = R, NO = O
6061         ; memberchk_eq(V,RestVars) ->
6062                 NR is R + 1,
6063                 NK = K, NO = O
6064         ;
6065                 NO is O + 1,
6066                 NK = K, NR = R
6067         ).
6069 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6070 %%  ___       _ _       _             
6071 %% |_ _|_ __ | (_)_ __ (_)_ __   __ _ 
6072 %%  | || '_ \| | | '_ \| | '_ \ / _` |
6073 %%  | || | | | | | | | | | | | | (_| |
6074 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
6075 %%                              |___/ 
6077 %% SWI begin
6078 create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
6079 create_get_mutable(V,M,GM) :- M = mutable(V), GM = true.
6080 %% SWI end
6082 %% SICStus begin
6083 %% create_get_mutable(V,M,GM) :- GM = get_mutable(V,M).
6084 %% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
6085 %% SICStus end
6087 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6089 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6090 %%  _   _ _   _ _ _ _
6091 %% | | | | |_(_) (_) |_ _   _
6092 %% | | | | __| | | | __| | | |
6093 %% | |_| | |_| | | | |_| |_| |
6094 %%  \___/ \__|_|_|_|\__|\__, |
6095 %%                      |___/
6097 gen_var(_).
6098 gen_vars(N,Xs) :-
6099    length(Xs,N). 
6101 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
6102    vars_susp(A,Vars,Susp,VarsSusp),
6103    Head =.. [_|Args],
6104    pairup(Args,Vars,HeadPairs).
6106 inc_id([N|Ns],[O|Ns]) :-
6107    O is N + 1.
6108 dec_id([N|Ns],[M|Ns]) :-
6109    M is N - 1.
6111 extend_id(Id,[0|Id]).
6113 next_id([_,N|Ns],[O|Ns]) :-
6114    O is N + 1.
6116 build_head(F,A,Id,Args,Head) :-
6117    buildName(F,A,Id,Name),
6118    ( (chr_pp_flag(debugable,on) ; is_stored(F/A), has_active_occurrence(F/A),
6119         ( may_trigger(F/A) ; 
6120                 get_allocation_occurrence(F/A,AO), 
6121                 get_max_occurrence(F/A,MO), 
6122         MO >= AO ) ) -> 
6123            Head =.. [Name|Args]
6124    ;
6125            init(Args,ArgsWOSusp),       % XXX not entirely correct!
6126            Head =.. [Name|ArgsWOSusp]
6127   ).
6129 buildName(Fct,Aty,List,Result) :-
6130    ( (chr_pp_flag(debugable,on) ; (once((is_stored(Fct/Aty), ( has_active_occurrence(Fct/Aty) ; chr_pp_flag(late_allocation,off)), 
6131    ( may_trigger(Fct/Aty) ; get_allocation_occurrence(Fct/Aty,AO), get_max_occurrence(Fct/Aty,MO), 
6132    MO >= AO ) ; List \= [0])) ) ) -> 
6133         atom_concat(Fct, (/) ,FctSlash),
6134         atomic_concat(FctSlash,Aty,FctSlashAty),
6135         buildName_(List,FctSlashAty,Result)
6136    ;
6137         Result = Fct
6138    ).
6140 buildName_([],Name,Name).
6141 buildName_([N|Ns],Name,Result) :-
6142   buildName_(Ns,Name,Name1),
6143   atom_concat(Name1,'__',NameDash),    % '_' is a char :-(
6144   atomic_concat(NameDash,N,Result).
6146 vars_susp(A,Vars,Susp,VarsSusp) :-
6147    length(Vars,A),
6148    append(Vars,[Susp],VarsSusp).
6150 make_attr(N,Mask,SuspsList,Attr) :-
6151         length(SuspsList,N),
6152         Attr =.. [v,Mask|SuspsList].
6154 or_pattern(Pos,Pat) :-
6155         Pow is Pos - 1,
6156         Pat is 1 << Pow.      % was 2 ** X
6158 and_pattern(Pos,Pat) :-
6159         X is Pos - 1,
6160         Y is 1 << X,          % was 2 ** X
6161         Pat is (-1)*(Y + 1).
6163 make_name(Prefix,F/A,Name) :-
6164         atom_concat_list([Prefix,F,(/),A],Name).
6166 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6167 % Storetype dependent lookup
6168 lookup_passive_head(Head,PreJoin,VarDict,Goal,AllSusps) :-
6169         functor(Head,F,A),
6170         get_store_type(F/A,StoreType),
6171         lookup_passive_head(StoreType,Head,PreJoin,VarDict,Goal,AllSusps).
6173 lookup_passive_head(default,Head,PreJoin,VarDict,Goal,AllSusps) :-
6174         functor(Head,F,A),
6175         passive_head_via(Head,PreJoin,VarDict,Goal,AllSusps).   
6176 lookup_passive_head(multi_inthash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
6177         once((
6178                 member(Index,Indexes),
6179                 multi_hash_key_args(Index,Head,KeyArgs),        
6180                 (translate(KeyArgs,VarDict,KeyArgCopies) ;
6181                  ground(KeyArgs), KeyArgCopies = KeyArgs )
6182         )),
6183         ( KeyArgCopies = [KeyCopy] ->
6184                 true
6185         ;
6186                 KeyCopy =.. [k|KeyArgCopies]
6187         ),
6188         functor(Head,F,A),
6189         multi_hash_via_lookup_name(F/A,Index,ViaName),
6190         Goal =.. [ViaName,KeyCopy,AllSusps],
6191         update_store_type(F/A,multi_inthash([Index])).
6192 lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
6193         once((
6194                 member(Index,Indexes),
6195                 multi_hash_key_args(Index,Head,KeyArgs),        
6196                 (translate(KeyArgs,VarDict,KeyArgCopies) ;
6197                  ground(KeyArgs), KeyArgCopies = KeyArgs )
6198         )),
6199         ( KeyArgCopies = [KeyCopy] ->
6200                 true
6201         ;
6202                 KeyCopy =.. [k|KeyArgCopies]
6203         ),
6204         functor(Head,F,A),
6205         multi_hash_via_lookup_name(F/A,Index,ViaName),
6206         Goal =.. [ViaName,KeyCopy,AllSusps],
6207         update_store_type(F/A,multi_hash([Index])).
6208 lookup_passive_head(global_ground,Head,_PreJoin,_VarDict,Goal,AllSusps) :-
6209         functor(Head,F,A),
6210         global_ground_store_name(F/A,StoreName),
6211         make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
6212         update_store_type(F/A,global_ground).
6213 lookup_passive_head(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,Goal,AllSusps) :-
6214         arg(VarIndex,Head,OVar),
6215         arg(KeyIndex,Head,OKey),
6216         translate([OVar,OKey],VarDict,[Var,Key]),
6217         get_target_module(Module),
6218         Goal = (
6219                 get_attr(Var,Module,AssocStore),
6220                 lookup_assoc_store(AssocStore,Key,AllSusps)
6221         ).
6222 lookup_passive_head(global_singleton,Head,_PreJoin,_VarDict,Goal,AllSusps) :-
6223         functor(Head,F,A),
6224         global_singleton_store_name(F/A,StoreName),
6225         make_get_store_goal(StoreName,Susp,GetStoreGoal),
6226         Goal = (GetStoreGoal,Susp \== [],AllSusps = [Susp]),
6227         update_store_type(F/A,global_singleton).
6228 lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,Goal,AllSusps) :-
6229         once((
6230                 member(ST,StoreTypes),
6231                 lookup_passive_head(ST,Head,PreJoin,VarDict,Goal,AllSusps)
6232         )).
6234 existential_lookup(var_assoc_store(VarIndex,KeyIndex),Head,_PreJoin,VarDict,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
6235         arg(VarIndex,Head,OVar),
6236         arg(KeyIndex,Head,OKey),
6237         translate([OVar,OKey],VarDict,[Var,Key]),
6238         get_target_module(Module),
6239         sbag_member_call(Susp,AllSusps,Sbag),
6240         functor(Head,F,A),
6241         delay_phase_end(validate_store_type_assumptions,
6242                 ( static_suspension_term(F/A,SuspTerm),
6243                   get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
6244                 )
6245         ),
6246         Goal = (
6247                 get_attr(Var,Module,AssocStore),
6248                 lookup_assoc_store(AssocStore,Key,AllSusps),
6249                 Sbag,
6250                 Susp = SuspTerm,
6251                 GetState
6252         ).
6253 existential_lookup(global_singleton,Head,_PreJoin,_VarDict,SuspTerm,Goal,Susp,Pairs,Pairs) :- !,
6254         functor(Head,F,A),
6255         global_singleton_store_name(F/A,StoreName),
6256         make_get_store_goal(StoreName,Susp,GetStoreGoal),
6257         Goal =  (
6258                         GetStoreGoal, % nb_getval(StoreName,Susp),
6259                         Susp \== [],
6260                         Susp = SuspTerm
6261                 ),
6262         update_store_type(F/A,global_singleton).
6263 existential_lookup(multi_store(StoreTypes),Head,PreJoin,VarDict,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
6264         once((
6265                 member(ST,StoreTypes),
6266                 existential_lookup(ST,Head,PreJoin,VarDict,SuspTerm,Goal,Susp,Pairs,NPairs)
6267         )).
6268 existential_lookup(multi_inthash(Indexes),Head,_PreJoin,VarDict,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
6269         once((
6270                 member(Index,Indexes),
6271                 multi_hash_key_args(Index,Head,KeyArgs),        
6272                 (translate(KeyArgs,VarDict,KeyArgCopies) ;
6273                  ground(KeyArgs), KeyArgCopies = KeyArgs )
6274         )),
6275         ( KeyArgCopies = [KeyCopy] ->
6276                 true
6277         ;
6278                 KeyCopy =.. [k|KeyArgCopies]
6279         ),
6280         functor(Head,F,A),
6281         multi_hash_via_lookup_name(F/A,Index,ViaName),
6282         LookupGoal =.. [ViaName,KeyCopy,AllSusps],
6283         delay_phase_end(validate_store_type_assumptions,
6284                 ( static_suspension_term(F/A,SuspTerm),
6285                   get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
6286                 )
6287         ),
6288         sbag_member_call(Susp,AllSusps,Sbag),
6289         Goal =  (
6290                         LookupGoal,
6291                         Sbag,
6292                         Susp = SuspTerm,        % not inlined
6293                         GetState
6294                 ),
6295         hash_index_filter(Pairs,Index,NPairs),
6296         update_store_type(F/A,multi_inthash([Index])).
6297 existential_lookup(multi_hash(Indexes),Head,PreJoin,VarDict,SuspTerm,Goal,Susp,Pairs,NPairs) :- !,
6298         once((
6299                 member(Index,Indexes),
6300                 multi_hash_key_args(Index,Head,KeyArgs),        
6301                 (translate(KeyArgs,VarDict,KeyArgCopies) ;
6302                  ground(KeyArgs), KeyArgCopies = KeyArgs )
6303         )),
6304         ( KeyArgCopies = [KeyCopy] ->
6305                 true
6306         ;
6307                 KeyCopy =.. [k|KeyArgCopies]
6308         ),
6309         functor(Head,F,A),
6310         multi_hash_via_lookup_name(F/A,Index,ViaName),
6311         LookupGoal =.. [ViaName,KeyCopy,AllSusps],
6312         ( check_fd_lookup_condition(F,A,Head,KeyArgs) ->
6313                 Sbag = (AllSusps = [Susp])
6314         ;
6315                 sbag_member_call(Susp,AllSusps,Sbag)
6316         ),
6317         delay_phase_end(validate_store_type_assumptions,
6318                 ( static_suspension_term(F/A,SuspTerm),
6319                   get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
6320                 )
6321         ),
6322         Goal =  (
6323                         LookupGoal,
6324                         Sbag,
6325                         Susp = SuspTerm,                % not inlined
6326                         GetState
6327                 ),
6328         hash_index_filter(Pairs,Index,NPairs),
6329         update_store_type(F/A,multi_hash([Index])).
6330 existential_lookup(StoreType,Head,PreJoin,VarDict,SuspTerm,Goal,Susp,Pairs,Pairs) :-
6331         lookup_passive_head(StoreType,Head,PreJoin,VarDict,UGoal,Susps),        
6332         sbag_member_call(Susp,Susps,Sbag),
6333         functor(Head,F,A),
6334         delay_phase_end(validate_store_type_assumptions,
6335                 ( static_suspension_term(F/A,SuspTerm),
6336                   get_static_suspension_field(F/A,SuspTerm,state,active,GetState)
6337                 )
6338         ),
6339         Goal =  (
6340                         UGoal,
6341                         Sbag,
6342                         Susp = SuspTerm,                % not inlined
6343                         GetState
6344                 ).
6346 hash_index_filter(Pairs,Index,NPairs) :-
6347         ( integer(Index) ->
6348                 NIndex = [Index]
6349         ;
6350                 NIndex = Index
6351         ),
6352         hash_index_filter(Pairs,NIndex,1,NPairs).
6354 hash_index_filter([],_,_,[]).
6355 hash_index_filter([P|Ps],Index,N,NPairs) :-
6356         ( Index = [I|Is] ->
6357                 NN is N + 1,
6358                 ( I > N ->
6359                         NPairs = [P|NPs],
6360                         hash_index_filter(Ps,[I|Is],NN,NPs)
6361                 ; I == N ->
6362                         NPairs = NPs,
6363                         hash_index_filter(Ps,Is,NN,NPs)
6364                 )       
6365         ;
6366                 NPairs = [P|Ps]
6367         ).      
6369 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6370 assume_constraint_stores([]).
6371 assume_constraint_stores([C|Cs]) :-
6372         ( only_ground_indexed_arguments(C),
6373           is_stored(C),
6374           get_store_type(C,default) ->
6375                 get_indexed_arguments(C,IndexedArgs),
6376                 % TODO: O(2^n) is not robust for too many indexed arguments, 
6377                 %       reject some possible indexes... 
6378                 %       or replace brute force index generation with other approach
6379                 length(IndexedArgs,NbIndexedArgs),
6380                 ( NbIndexedArgs > 10 ->
6381                         findall([Index],member(Index,IndexedArgs),Indexes)
6382                 ;
6383                         findall(Index,(sublist(Index,IndexedArgs), Index \== []),UnsortedIndexes),
6384                         predsort(longer_list,UnsortedIndexes,Indexes)
6385                 ),
6386                 ( get_functional_dependency(C,1,Pattern,Key), 
6387                   all_distinct_var_args(Pattern), Key == [] ->
6388                         assumed_store_type(C,global_singleton)
6389                 ;
6390                     ( get_constraint_type(C,Type),
6391                     findall(Index,(member(Index,Indexes), Index = [I],
6392                     nth(I,Type,dense_int)),IndexesA),
6393                     IndexesA \== [] ->
6394                         list_difference_eq(Indexes,IndexesA,IndexesB),
6395                         ( IndexesB \== [] ->
6396                             assumed_store_type(C,multi_store([multi_inthash(IndexesA),multi_hash(IndexesB),global_ground]))     
6397                         ;
6398                             assumed_store_type(C,multi_store([multi_inthash(IndexesA),global_ground]))  
6399                         )
6400                     ;
6401                         assumed_store_type(C,multi_store([multi_hash(Indexes),global_ground]))  
6402                     )
6403                 )
6404         ;
6405                 true
6406         ),
6407         assume_constraint_stores(Cs).
6409 longer_list(R,L1,L2) :-
6410         length(L1,N1),
6411         length(L2,N2),
6412         compare(Rt,N2,N1),
6413         ( Rt == (=) ->
6414                 compare(R,L1,L2)
6415         ;
6416                 R = Rt
6417         ).
6419 all_distinct_var_args(Term) :-
6420         Term =.. [_|Args],
6421         copy_term_nat(Args,NArgs),
6422         all_distinct_var_args_(NArgs).
6424 all_distinct_var_args_([]).
6425 all_distinct_var_args_([X|Xs]) :-
6426         var(X),
6427         X = t,  
6428         all_distinct_var_args_(Xs).
6430 get_indexed_arguments(C,IndexedArgs) :-
6431         C = F/A,
6432         get_indexed_arguments(1,A,C,IndexedArgs).
6434 get_indexed_arguments(I,N,C,L) :-
6435         ( I > N ->
6436                 L = []
6437         ;       ( is_indexed_argument(C,I) ->
6438                         L = [I|T]
6439                 ;
6440                         L = T
6441                 ),
6442                 J is I + 1,
6443                 get_indexed_arguments(J,N,C,T)
6444         ).
6445         
6446 validate_store_type_assumptions([]).
6447 validate_store_type_assumptions([C|Cs]) :-
6448         validate_store_type_assumption(C),
6449         validate_store_type_assumptions(Cs).    
6451 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6452 % new code generation
6453 universal_search_iterator_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
6454         Rule = rule(H1,_,Guard,Body),
6455         ( H1 == [],
6456           functor(CurrentHead,CF,CA),
6457           check_fd_lookup_condition(CF,CA,CurrentHead,PrevHeads) ->
6458                 L = T
6459         ;
6460                 gen_var_susp_list_for_b(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSuspsList,FirstVarsSusp,_,PrevIterators),
6461                 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,FirstVarsSusp,PrevIterators,PrevVarsAndSusps,PrevId),
6462                 flatten(VarsAndSuspsList,VarsAndSusps),
6463                 Vars = [ [] | VarsAndSusps],
6464                 build_head(F,A,Id,Vars,Head),
6465                 build_head(F,A,PrevId,PrevVarsAndSusps,PredecessorCall),
6466                 Clause = ( Head :- PredecessorCall),
6467                 L = [Clause | T]
6468         ).
6470         % skips back intelligently over global_singleton lookups
6471 universal_search_iterator_failure_vars(PrevHeads,Id,VarsAndSuspsList,BaseCallArgs,PrevIterators,PrevVarsAndSusps,PrevId) :-
6472         ( Id = [0|_] ->
6473                 next_id(Id,PrevId),
6474                 PrevVarsAndSusps = BaseCallArgs
6475         ;
6476                 VarsAndSuspsList = [_|AllButFirstList],
6477                 dec_id(Id,PrevId1),
6478                 ( PrevHeads  = [PrevHead|PrevHeads1],
6479                   functor(PrevHead,F,A),
6480                   check_fd_lookup_condition(F,A,PrevHead,PrevHeads1) ->
6481                         PrevIterators = [_|PrevIterators1],
6482                         universal_search_iterator_failure_vars(PrevHeads1,PrevId1,AllButFirstList,BaseCallArgs,PrevIterators1,PrevVarsAndSusps,PrevId)
6483                 ;
6484                         PrevId = PrevId1,
6485                         flatten(AllButFirstList,AllButFirst),
6486                         PrevIterators = [PrevIterator|_],
6487                         PrevVarsAndSusps = [PrevIterator|AllButFirst]
6488                 )
6489         ).
6491 universal_search_iterator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
6492         Rule = rule(_,_,Guard,Body),
6493         gen_var_susp_list_for_b(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],VarDict,PreVarsAndSuspsList,FirstVarsSusp,AllSusps,PrevIterators),
6494         init(AllSusps,PreSusps),
6495         flatten(PreVarsAndSuspsList,PreVarsAndSusps),
6496         gen_var(OtherSusps),
6497         functor(CurrentHead,OtherF,OtherA),
6498         gen_vars(OtherA,OtherVars),
6499         head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
6500         get_constraint_mode(OtherF/OtherA,Mode),
6501         head_arg_matches(HeadPairs,Mode,VarDict,FirstMatching,VarDict1),
6502         
6503         delay_phase_end(validate_store_type_assumptions,
6504                 ( static_suspension_term(OtherF/OtherA,OtherSuspension),
6505                   get_static_suspension_field(OtherF/OtherA,OtherSuspension,state,active,GetState),
6506                   get_static_suspension_term_field(arguments,OtherF/OtherA,OtherSuspension,OtherVars)
6507                 )
6508         ),
6510         different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
6511         % create_get_mutable_ref(active,State,GetMutable),
6512         CurrentSuspTest = (
6513            OtherSusp = OtherSuspension,
6514            GetState,
6515            DiffSuspGoals,
6516            FirstMatching
6517         ),
6518         lookup_passive_head(NextHead,[CurrentHead|PreHeads],VarDict1,NextSuspGoal,NextSusps),
6519         inc_id(Id,NestedId),
6520         ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
6521         build_head(F,A,Id,ClauseVars,ClauseHead),
6522         passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
6523         append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
6524         build_head(F,A,NestedId,NestedVars,NestedHead),
6525         
6526         ( check_fd_lookup_condition(OtherF,OtherA,CurrentHead,PreHeads) ->      % iterator (OtherSusps) is empty at runtime
6527                 universal_search_iterator_failure_vars(PreHeads,Id,PreVarsAndSuspsList,FirstVarsSusp,PrevIterators,PreVarsAndSusps1,PrevId),
6528                 RecursiveVars = PreVarsAndSusps1
6529         ;
6530                 RecursiveVars = [OtherSusps|PreVarsAndSusps],
6531                 PrevId = Id
6532         ),
6533         build_head(F,A,PrevId,RecursiveVars,RecursiveHead),
6535         Clause = (
6536            ClauseHead :-
6537            (   CurrentSuspTest,
6538                NextSuspGoal
6539                ->
6540                NestedHead
6541            ;   RecursiveHead
6542            )
6543         ),   
6544         L = [Clause|T].
6546 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6548 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6549 % Observation Analysis
6551 % CLASSIFICATION
6552 %   Enabled 
6554 % Analysis based on Abstract Interpretation paper.
6556 % TODO: 
6557 %   stronger analysis domain [research]
6559 :- chr_constraint
6560         initial_call_pattern/1,
6561         call_pattern/1,
6562         call_pattern_worker/1,
6563         final_answer_pattern/2,
6564         abstract_constraints/1,
6565         depends_on/2,
6566         depends_on_ap/4,
6567         depends_on_goal/2,
6568         ai_observed_internal/2,
6569         % ai_observed/2,
6570         ai_not_observed_internal/2,
6571         ai_not_observed/2,
6572         ai_is_observed/2,
6573         depends_on_as/3,
6574         ai_observation_gather_results/0.
6576 :- chr_option(type_definition,type(abstract_domain,[odom(any,any)])).
6578 :- chr_option(mode,initial_call_pattern(+)).
6579 :- chr_option(type_declaration,call_pattern(abstract_domain)).
6581 :- chr_option(mode,call_pattern(+)).
6582 :- chr_option(type_declaration,call_pattern(abstract_domain)).
6584 :- chr_option(mode,call_pattern_worker(+)).
6585 :- chr_option(type_declaration,call_pattern_worker(abstract_domain)).
6587 :- chr_option(mode,final_answer_pattern(+,+)).
6588 :- chr_option(type_declaration,final_answer_pattern(abstract_domain,abstract_domain)).
6590 :- chr_option(mode,abstract_constraints(+)).
6591 :- chr_option(type_declaration,abstract_constraints(list)).
6593 :- chr_option(mode,depends_on(+,+)).
6594 :- chr_option(type_declaration,depends_on(abstract_domain,abstract_domain)).
6596 :- chr_option(mode,depends_on_as(+,+,+)).
6597 :- chr_option(mode,depends_on_ap(+,+,+,+)).
6598 :- chr_option(mode,depends_on_goal(+,+)).
6599 :- chr_option(mode,ai_is_observed(+,+)).
6600 :- chr_option(mode,ai_not_observed(+,+)).
6601 % :- chr_option(mode,ai_observed(+,+)).
6602 :- chr_option(mode,ai_not_observed_internal(+,+)).
6603 :- chr_option(mode,ai_observed_internal(+,+)).
6606 abstract_constraints_fd @ 
6607         abstract_constraints(_) \ abstract_constraints(_) <=> true.
6609 ai_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
6610 ai_not_observed_internal(C,O) \ ai_not_observed_internal(C,O) <=> true.
6611 ai_observed_internal(C,O) \ ai_observed_internal(C,O) <=> true.
6613 ai_not_observed(C,O) \ ai_is_observed(C,O) <=> fail.
6614 ai_is_observed(_,_) <=> true.
6616 ai_observation_gather_results \ ai_observed_internal(C,O) <=> true. % ai_observed(C,O).
6617 ai_observation_gather_results \ ai_not_observed_internal(C,O) <=> ai_not_observed(C,O).
6618 ai_observation_gather_results <=> true.
6620 %------------------------------------------------------------------------------%
6621 % Main Analysis Entry
6622 %------------------------------------------------------------------------------%
6623 ai_observation_analysis(ACs) :-
6624     ( chr_pp_flag(ai_observation_analysis,on),
6625         get_target_module(Module), '$chr_compiled_with_version'(3) -> % , Module \== guard_entailment ->
6626         list_to_ord_set(ACs,ACSet),
6627         abstract_constraints(ACSet),
6628         ai_observation_schedule_initial_calls(ACSet,ACSet),
6629         ai_observation_gather_results
6630     ;
6631         true
6632     ).
6634 ai_observation_schedule_initial_calls([],_).
6635 ai_observation_schedule_initial_calls([AC|RACs],ACs) :-
6636         ai_observation_schedule_initial_call(AC,ACs),
6637         ai_observation_schedule_initial_calls(RACs,ACs).
6639 ai_observation_schedule_initial_call(AC,ACs) :-
6640         ai_observation_top(AC,CallPattern),     
6641         % ai_observation_bot(AC,ACs,CallPattern),       
6642         initial_call_pattern(CallPattern).
6644 ai_observation_schedule_new_calls([],AP).
6645 ai_observation_schedule_new_calls([AC|ACs],AP) :-
6646         AP = odom(_,Set),
6647         initial_call_pattern(odom(AC,Set)),
6648         ai_observation_schedule_new_calls(ACs,AP).
6650 final_answer_pattern(CP,AP1) \ final_answer_pattern(CP,AP2)
6651         <=>
6652                 ai_observation_leq(AP2,AP1)
6653         |
6654                 true.
6656 initial_call_pattern(CP) \ initial_call_pattern(CP) <=> true.
6658 initial_call_pattern(CP) ==> call_pattern(CP).
6660 initial_call_pattern(CP), final_answer_pattern(CP,AP), abstract_constraints(ACs) # ID3 
6661         ==>
6662                 ai_observation_schedule_new_calls(ACs,AP)
6663         pragma
6664                 passive(ID3).
6666 call_pattern(CP) \ call_pattern(CP) <=> true.   
6668 depends_on(CP1,CP2), final_answer_pattern(CP2,AP) ==>
6669         final_answer_pattern(CP1,AP).
6671  %call_pattern(CP) ==> writeln(call_pattern(CP)).
6673 call_pattern(CP) ==> call_pattern_worker(CP).
6675 %------------------------------------------------------------------------------%
6676 % Abstract Goal
6677 %------------------------------------------------------------------------------%
6679         % AbstractGoala
6680 %call_pattern(odom([],Set)) ==> 
6681 %       final_answer_pattern(odom([],Set),odom([],Set)).
6683 call_pattern_worker(odom([],Set)) <=>
6684         % writeln(' - AbstractGoal'(odom([],Set))),
6685         final_answer_pattern(odom([],Set),odom([],Set)).
6687         % AbstractGoalb
6688 call_pattern_worker(odom([G|Gs],Set)) <=>
6689         % writeln(' - AbstractGoal'(odom([G|Gs],Set))),
6690         CP1 = odom(G,Set),
6691         depends_on_goal(odom([G|Gs],Set),CP1),
6692         call_pattern(CP1).
6694 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2) \ depends_on(CP1,_) # ID
6695         <=> true pragma passive(ID).
6696 depends_on_goal(CP1,CP2), final_answer_pattern(CP2,AP2)
6697         ==> 
6698                 CP1 = odom([_|Gs],_),
6699                 AP2 = odom([],Set),
6700                 CCP = odom(Gs,Set),
6701                 call_pattern(CCP),
6702                 depends_on(CP1,CCP).
6704 %------------------------------------------------------------------------------%
6705 % Abstract Solve 
6706 %------------------------------------------------------------------------------%
6707 call_pattern_worker(odom(builtin,Set)) <=>
6708         % writeln('  - AbstractSolve'(odom(builtin,Set))),
6709         ord_empty(EmptySet),
6710         final_answer_pattern(odom(builtin,Set),odom([],EmptySet)).
6712 %------------------------------------------------------------------------------%
6713 % Abstract Drop
6714 %------------------------------------------------------------------------------%
6715 max_occurrence(C,MO) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) 
6716         <=>
6717                 O > MO 
6718         |
6719                 % writeln('  - AbstractDrop'(odom(occ(C,O),Set))),
6720                 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
6721         pragma 
6722                 passive(ID2).
6724 %------------------------------------------------------------------------------%
6725 % Abstract Activate
6726 %------------------------------------------------------------------------------%
6727 call_pattern_worker(odom(AC,Set))
6728         <=>
6729                 AC = _ / _
6730         |
6731                 % writeln('  - AbstractActivate'(odom(AC,Set))),
6732                 CP = odom(occ(AC,1),Set),
6733                 call_pattern(CP),
6734                 depends_on(odom(AC,Set),CP).
6736 %------------------------------------------------------------------------------%
6737 % Abstract Passive
6738 %------------------------------------------------------------------------------%
6739 occurrence(C,O,RuleNb,ID,_) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
6740         <=>
6741                 is_passive(RuleNb,ID)
6742         |
6743                 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
6744                 % DEFAULT
6745                 NO is O + 1,
6746                 DCP = odom(occ(C,NO),Set),
6747                 call_pattern(DCP),
6748                 final_answer_pattern(odom(occ(C,O),Set),odom([],Set)),
6749                 depends_on(odom(occ(C,O),Set),DCP)
6750         pragma
6751                 passive(ID2).
6752 %------------------------------------------------------------------------------%
6753 % Abstract Simplify
6754 %------------------------------------------------------------------------------%
6756         % AbstractSimplify
6757 occurrence(C,O,RuleNb,ID,simplification) # ID2 \ call_pattern_worker(odom(occ(C,O),Set)) 
6758         <=>
6759                 \+ is_passive(RuleNb,ID) 
6760         |
6761                 % writeln(' - AbstractPassive'(odom(occ(C,O),Set))),
6762                 ai_observation_memo_simplification_rest_heads(C,O,AbstractRestHeads),
6763                 ai_observation_observe_set(Set,AbstractRestHeads,Set2),
6764                 ai_observation_memo_abstract_goal(RuleNb,AG),
6765                 call_pattern(odom(AG,Set2)),
6766                 % DEFAULT
6767                 NO is O + 1,
6768                 DCP = odom(occ(C,NO),Set),
6769                 call_pattern(DCP),
6770                 depends_on_as(odom(occ(C,O),Set),odom(AG,Set2),DCP),
6771                 % DEADLOCK AVOIDANCE
6772                 final_answer_pattern(odom(occ(C,O),Set),odom([],Set))
6773         pragma
6774                 passive(ID2).
6776 depends_on_as(CP,CPS,CPD),
6777         final_answer_pattern(CPS,APS),
6778         final_answer_pattern(CPD,APD) ==>
6779         ai_observation_lub(APS,APD,AP),
6780         final_answer_pattern(CP,AP).    
6783 :- chr_constraint
6784         ai_observation_memo_simplification_rest_heads/3,
6785         ai_observation_memoed_simplification_rest_heads/3.
6787 :- chr_option(mode,ai_observation_memo_simplification_rest_heads(+,+,?)).
6788 :- chr_option(mode,ai_observation_memoed_simplification_rest_heads(+,+,+)).
6790 ai_observation_memoed_simplification_rest_heads(C,O,RH) \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
6791         <=>
6792                 QRH = RH.
6793 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_simplification_rest_heads(C,O,QRH)
6794         <=>
6795                 Rule = pragma(rule(H1,H2,_,_),ids(IDs1,_),_,_,_),
6796                 once(select2(ID,_,IDs1,H1,_,RestH1)),
6797                 ai_observation_abstract_constraints(RestH1,ACs,ARestHeads),
6798                 ai_observation_abstract_constraints(H2,ACs,AH2),
6799                 append(ARestHeads,AH2,AbstractHeads),
6800                 sort(AbstractHeads,QRH),
6801                 ai_observation_memoed_simplification_rest_heads(C,O,QRH)
6802         pragma
6803                 passive(ID1),
6804                 passive(ID2),
6805                 passive(ID3).
6807 ai_observation_memo_simplification_rest_heads(_,_,_) <=> fail.
6809 %------------------------------------------------------------------------------%
6810 % Abstract Propagate
6811 %------------------------------------------------------------------------------%
6814         % AbstractPropagate
6815 occurrence(C,O,RuleNb,ID,propagation) # ID2 \ call_pattern_worker(odom(occ(C,O),Set))
6816         <=>
6817                 \+ is_passive(RuleNb,ID)
6818         |
6819                 % writeln('  - AbstractPropagate'(odom(occ(C,O),Set))),
6820                 % observe partners
6821                 ai_observation_memo_propagation_rest_heads(C,O,AHs),
6822                 ai_observation_observe_set(Set,AHs,Set2),
6823                 ord_add_element(Set2,C,Set3),
6824                 ai_observation_memo_abstract_goal(RuleNb,AG),
6825                 call_pattern(odom(AG,Set3)),
6826                 ( ord_memberchk(C,Set2) ->
6827                         Delete = no
6828                 ;
6829                         Delete = yes
6830                 ),
6831                 % DEFAULT
6832                 NO is O + 1,
6833                 DCP = odom(occ(C,NO),Set),
6834                 call_pattern(DCP),
6835                 depends_on_ap(odom(occ(C,O),Set),odom(AG,Set3),DCP,Delete)
6836         pragma
6837                 passive(ID2).
6839 :- chr_constraint
6840         ai_observation_memo_propagation_rest_heads/3,
6841         ai_observation_memoed_propagation_rest_heads/3.
6843 :- chr_option(mode,ai_observation_memo_propagation_rest_heads(+,+,?)).
6844 :- chr_option(mode,ai_observation_memoed_propagation_rest_heads(+,+,+)).
6846 ai_observation_memoed_propagation_rest_heads(C,O,RH) \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
6847         <=>
6848                 QRH = RH.
6849 abstract_constraints(ACs) # ID1, occurrence(C,O,RuleNb,ID,_) # ID2, rule(RuleNb,Rule) # ID3 \ ai_observation_memo_propagation_rest_heads(C,O,QRH)
6850         <=>
6851                 Rule = pragma(rule(H1,H2,_,_),ids(_,IDs2),_,_,_),
6852                 once(select2(ID,_,IDs2,H2,_,RestH2)),
6853                 ai_observation_abstract_constraints(RestH2,ACs,ARestHeads),
6854                 ai_observation_abstract_constraints(H1,ACs,AH1),
6855                 append(ARestHeads,AH1,AbstractHeads),
6856                 sort(AbstractHeads,QRH),
6857                 ai_observation_memoed_propagation_rest_heads(C,O,QRH)
6858         pragma
6859                 passive(ID1),
6860                 passive(ID2),
6861                 passive(ID3).
6863 ai_observation_memo_propagation_rest_heads(_,_,_) <=> fail.
6865 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPD,APD) ==>
6866         final_answer_pattern(CP,APD).
6867 depends_on_ap(CP,CPP,CPD,Delete), final_answer_pattern(CPP,APP),
6868         final_answer_pattern(CPD,APD) ==>
6869         true | 
6870         CP = odom(occ(C,O),_),
6871         ( ai_observation_is_observed(APP,C) ->
6872                 ai_observed_internal(C,O)       
6873         ;
6874                 ai_not_observed_internal(C,O)   
6875         ),
6876         ( Delete == yes ->
6877                 APP = odom([],Set0),
6878                 ord_del_element(Set0,C,Set),
6879                 NAPP = odom([],Set)
6880         ;
6881                 NAPP = APP
6882         ),
6883         ai_observation_lub(NAPP,APD,AP),
6884         final_answer_pattern(CP,AP).
6886 %------------------------------------------------------------------------------%
6887 % Catch All
6888 %------------------------------------------------------------------------------%
6890 call_pattern_worker(CP) <=> chr_error(internal,'AI observation analysis: unexpected abstract state ~w\n',[CP]).
6892 %------------------------------------------------------------------------------%
6893 % Auxiliary Predicates 
6894 %------------------------------------------------------------------------------%
6896 ai_observation_lub(odom(AG,S1),odom(AG,S2),odom(AG,S3)) :-
6897         ord_intersection(S1,S2,S3).
6899 ai_observation_bot(AG,AS,odom(AG,AS)).
6901 ai_observation_top(AG,odom(AG,EmptyS)) :-
6902         ord_empty(EmptyS).
6904 ai_observation_leq(odom(AG,S1),odom(AG,S2)) :-
6905         ord_subset(S2,S1).
6907 ai_observation_observe_set(S,ACSet,NS) :-
6908         ord_subtract(S,ACSet,NS).
6910 ai_observation_abstract_constraint(C,ACs,AC) :-
6911         functor(C,F,A),
6912         AC = F/A,
6913         memberchk(AC,ACs).
6915 ai_observation_abstract_constraints(Cs,ACs,NACs) :-
6916         findall(NAC,(member(C,Cs),ai_observation_abstract_constraint(C,ACs,NAC)),NACs).
6918 %------------------------------------------------------------------------------%
6919 % Abstraction of Rule Bodies
6920 %------------------------------------------------------------------------------%
6922 :- chr_constraint
6923         ai_observation_memoed_abstract_goal/2,
6924         ai_observation_memo_abstract_goal/2.
6926 :- chr_option(mode,ai_observation_memoed_abstract_goal(+,+)).
6927 :- chr_option(mode,ai_observation_memo_abstract_goal(+,?)).
6929 ai_observation_memoed_abstract_goal(RuleNb,AG) # ID1 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
6930         <=>
6931                 QAG = AG
6932         pragma
6933                 passive(ID1).
6935 rule(RuleNb,Rule) # ID1, abstract_constraints(ACs) # ID2 \ ai_observation_memo_abstract_goal(RuleNb,QAG)
6936         <=>
6937                 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
6938                 ai_observation_abstract_goal_(H1,H2,Guard,Body,ACs,AG),
6939                 QAG = AG,
6940                 ai_observation_memoed_abstract_goal(RuleNb,AG)
6941         pragma
6942                 passive(ID1),
6943                 passive(ID2).      
6945 ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG) :-
6946         % also guard: e.g. b, c(X) ==> Y=X | p(Y).
6947         term_variables((H1,H2,Guard),HVars),
6948         append(H1,H2,Heads),
6949         % variables that are declared to be ground are safe,
6950         ground_vars(Heads,GroundVars),  
6951         % so we remove them from the list of 'dangerous' head variables
6952         list_difference_eq(HVars,GroundVars,HV),
6953         ai_observation_abstract_goal(G,ACs,AG,[],HV),!.
6954         % writeln(ai_observation_abstract_goal(G,ACs,AG,[],HV)).
6955         % HV are 'dangerous' variables, all others are fresh and safe
6956         
6957 ground_vars([],[]).
6958 ground_vars([H|Hs],GroundVars) :-
6959         functor(H,F,A),
6960         get_constraint_mode(F/A,Mode),
6961         head_info(H,A,_Vars,_Susp,_HeadVars,HeadPairs),
6962         head_arg_matches(HeadPairs,Mode,[],_FirstMatching,_VarDict1,[],GroundVars1),
6963         ground_vars(Hs,GroundVars2),
6964         append(GroundVars1,GroundVars2,GroundVars).
6966 ai_observation_abstract_goal((G1,G2),ACs,List,Tail,HV) :- !,    % conjunction
6967         ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
6968         ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
6969 ai_observation_abstract_goal((G1;G2),ACs,List,Tail,HV) :- !,    % disjunction
6970         ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
6971         ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
6972 ai_observation_abstract_goal((G1->G2),ACs,List,Tail,HV) :- !,   % if-then
6973         ai_observation_abstract_goal(G1,ACs,List,IntermediateList,HV),
6974         ai_observation_abstract_goal(G2,ACs,IntermediateList,Tail,HV).
6975 ai_observation_abstract_goal(C,ACs,[AC|Tail],Tail,HV) :-                
6976         ai_observation_abstract_constraint(C,ACs,AC), !.        % CHR constraint
6977 ai_observation_abstract_goal(true,_,Tail,Tail,_) :- !.
6978 ai_observation_abstract_goal(writeln(_),_,Tail,Tail,_) :- !.
6979 % non-CHR constraint is safe if it only binds fresh variables
6980 ai_observation_abstract_goal(G,_,Tail,Tail,HV) :- 
6981         builtin_binds_b(G,Vars),
6982         intersect_eq(Vars,HV,[]), 
6983         !.      
6984 ai_observation_abstract_goal(G,_,[AG|Tail],Tail,_) :-
6985         AG = builtin. % default case if goal is not recognized/safe
6987 ai_observation_is_observed(odom(_,ACSet),AC) :-
6988         \+ ord_memberchk(AC,ACSet).
6990 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
6991 unconditional_occurrence(C,O) :-
6992         get_occurrence(C,O,RuleNb,ID),
6993         get_rule(RuleNb,PRule),
6994         PRule = pragma(ORule,_,_,_,_),
6995         copy_term_nat(ORule,Rule),
6996         Rule = rule(H1,H2,Guard,_),
6997         guard_entailment:entails_guard([chr_pp_headvariables(H1,H2)],Guard),
6998         once((
6999                 H1 = [Head], H2 == []
7000              ;
7001                 H2 = [Head], H1 == [], \+ may_trigger(C)
7002         )),
7003         functor(Head,F,A),
7004         Head =.. [_|Args],
7005         unconditional_occurrence_args(Args).
7007 unconditional_occurrence_args([]).
7008 unconditional_occurrence_args([X|Xs]) :-
7009         var(X),
7010         X = x,
7011         unconditional_occurrence_args(Xs).
7013 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7015 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
7016 % Partial wake analysis
7018 % In a Var = Var unification do not wake up constraints of both variables,
7019 % but rather only those of one variable.
7020 %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
7022 :- chr_constraint
7023         partial_wake_analysis/0,
7024         no_partial_wake/1,
7025         wakes_partially/1.
7027 partial_wake_analysis, occurrence(FA,O,RuleNb,ID,Type),  rule(RuleNb,Rule), constraint_mode(FA,ArgModes) 
7028         ==>
7029                 Rule = pragma(rule(H1,H2,Guard,Body),_,_,_,_),
7030                 ( is_passive(RuleNb,ID) ->
7031                         true 
7032                 ; Type == simplification ->
7033                         select(H,H1,RestH1),
7034                         H =.. [_|Args],
7035                         term_variables(Guard,Vars),
7036                         partial_wake_args(Args,ArgModes,Vars,FA)        
7037                 ; % Type == propagation  ->
7038                         select(H,H2,RestH2),
7039                         H =.. [_|Args],
7040                         term_variables(Guard,Vars),
7041                         partial_wake_args(Args,ArgModes,Vars,FA)        
7042                 ).
7044 partial_wake_args([],_,_,_).
7045 partial_wake_args([Arg|Args],[Mode|Modes],Vars,C) :-
7046         ( Mode \== (+) ->
7047                 ( nonvar(Arg) ->
7048                         no_partial_wake(C)      
7049                 ; memberchk_eq(Arg,Vars) ->
7050                         no_partial_wake(C)      
7051                 ;
7052                         true
7053                 )
7054         ;
7055                 true
7056         ),
7057         partial_wake_args(Args,Modes,Vars,C).
7059 no_partial_wake(C) \ no_partial_wake(C) <=> true.
7061 no_partial_wake(C) \ wakes_partially(C) <=> fail.
7063 wakes_partially(C) <=> true.
7064   
7066 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7067 % Generate rules that implement chr_show_store/1 functionality.
7069 % CLASSIFICATION
7070 %   Experimental
7071 %   Unused
7073 % Generates additional rules:
7075 %   $show, C1 # ID ==> writeln(C1) pragma passive(ID).
7076 %   ...
7077 %   $show, Cn # ID ==> writeln(Cn) pragma passive(ID).
7078 %   $show <=> true.
7080 generate_show_constraint(Constraints0,Constraints,Rules0,Rules) :-
7081         ( chr_pp_flag(show,on) ->
7082                 Constraints = ['$show'/0|Constraints0],
7083                 generate_show_rules(Constraints0,Rules,[Rule|Rules0]),
7084                 inc_rule_count(RuleNb),
7085                 Rule = pragma(
7086                                 rule(['$show'],[],true,true),
7087                                 ids([0],[]),
7088                                 [],
7089                                 no,     
7090                                 RuleNb
7091                         )
7092         ;
7093                 Constraints = Constraints0,
7094                 Rules = Rules0
7095         ).
7097 generate_show_rules([],Rules,Rules).
7098 generate_show_rules([F/A|Rest],[Rule|Tail],Rules) :-
7099         functor(C,F,A),
7100         inc_rule_count(RuleNb),
7101         Rule = pragma(
7102                         rule([],['$show',C],true,writeln(C)),
7103                         ids([],[0,1]),
7104                         [passive(1)],
7105                         no,     
7106                         RuleNb
7107                 ),
7108         generate_show_rules(Rest,Tail,Rules).
7110 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7111 % Custom supension term layout
7113 static_suspension_term(F/A,Suspension) :-
7114         suspension_term_base(F/A,Base),
7115         Arity is Base + A,
7116         functor(Suspension,suspension,Arity).
7118 has_suspension_field(FA,Field) :-
7119         suspension_term_base_fields(FA,Fields),
7120         memberchk(Field,Fields).
7122 suspension_term_base(FA,Base) :-
7123         suspension_term_base_fields(FA,Fields),
7124         length(Fields,Base).
7126 suspension_term_base_fields(FA,Fields) :-
7127         ( chr_pp_flag(debugable,on) ->
7128                 % 1. ID
7129                 % 2. State
7130                 % 3. Propagation History
7131                 % 4. Generation Number
7132                 % 5. Continuation Goal
7133                 % 6. Functor
7134                 Fields = [id,state,history,generation,continuation,functor]
7135         ;  
7136                 ( uses_history(FA) ->
7137                         Fields = [id,state,history|Fields2]
7138                 ; only_ground_indexed_arguments(FA), get_functional_dependency(FA,1,_,_) ->
7139                         Fields = [state|Fields2]
7140                 ;
7141                         Fields = [id,state|Fields2]
7142                 ),
7143                 ( only_ground_indexed_arguments(FA) ->
7144                         get_store_type(FA,StoreType),
7145                         basic_store_types(StoreType,BasicStoreTypes),
7146                         ( memberchk(global_ground,BasicStoreTypes) ->
7147                                 % 1. ID
7148                                 % 2. State
7149                                 % 3. Propagation History
7150                                 % 4. Global List Prev
7151                                 Fields2 = [global_list_prev]
7152                         ;
7153                                 % 1. ID
7154                                 % 2. State
7155                                 % 3. Propagation History
7156                                 Fields2 = []
7157                         )
7158                 ; may_trigger(FA) ->
7159                         % 1. ID
7160                         % 2. State
7161                         % 3. Propagation History
7162                         ( uses_field(FA,generation) ->
7163                         % 4. Generation Number
7164                         % 5. Global List Prev
7165                                 Fields2 = [generation,global_list_prev]
7166                         ;
7167                                 Fields2 = [global_list_prev]
7168                         )
7169                 ;
7170                         % 1. ID
7171                         % 2. State
7172                         % 3. Propagation History
7173                         % 4. Global List Prev
7174                         Fields2 = [global_list_prev]
7175                 )
7176         ).
7178 get_static_suspension_term_field(FieldName,FA,StaticSuspension,Field) :-
7179         suspension_term_base_fields(FA,Fields),
7180         nth(Index,Fields,FieldName), !,
7181         arg(Index,StaticSuspension,Field).
7182 get_static_suspension_term_field(arguments,FA,StaticSuspension,Field) :- !,
7183         suspension_term_base(FA,Base),
7184         StaticSuspension =.. [_|Args],
7185         drop(Base,Args,Field).
7186 get_static_suspension_term_field(FieldName,FA,_StaticSuspension,_Field) :- 
7187         chr_error(internal,'Trying to obtain field ~w of ~w, wich does not have it!',[FieldName,FA]).
7190 get_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
7191         suspension_term_base_fields(FA,Fields),
7192         nth(Index,Fields,FieldName), !,
7193         Goal = arg(Index,DynamicSuspension,Field).      
7194 get_dynamic_suspension_term_field(arguments,FA,DynamicSuspension,Field,Goal) :- !,
7195         static_suspension_term(FA,StaticSuspension),
7196         get_static_suspension_term_field(arguments,FA,StaticSuspension,Field),  
7197         Goal = (DynamicSuspension = StaticSuspension).
7198 get_dynamic_suspension_term_field(argument(I),FA,DynamicSuspension,Field,Goal) :- !,
7199         suspension_term_base(FA,Base),
7200         Index is I + Base,
7201         Goal = arg(Index,DynamicSuspension,Field).
7202 get_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
7203         chr_error(internal,'Dynamic goal to get ~w of ~w, which does not have this field!',[FieldName,FA]).
7206 set_dynamic_suspension_term_field(FieldName,FA,DynamicSuspension,Field,Goal) :-
7207         suspension_term_base_fields(FA,Fields),
7208         nth(Index,Fields,FieldName), !,
7209         Goal = setarg(Index,DynamicSuspension,Field).
7210 set_dynamic_suspension_term_field(FieldName,FA,_DynamicSuspension,_Field,_Goal) :-
7211         chr_error(internal,'Dynamic goal to set ~w of ~w, which does not have this field!',[FieldName,FA]).
7213 basic_store_types(multi_store(Types),Types) :- !.
7214 basic_store_types(Type,[Type]).
7216 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7219 :- chr_constraint
7220         phase_end/1,
7221         delay_phase_end/2.
7223 :- chr_option(mode,phase_end(+)).
7224 :- chr_option(mode,delay_phase_end(+,?)).
7226 phase_end(Phase) \ delay_phase_end(Phase,Goal) <=> call(Goal).
7227 % phase_end(Phase) <=> true.
7229         
7230 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7231 :- chr_constraint
7232         does_use_history/2,
7233         uses_history/1,
7234         novel_production_call/4.
7236 :- chr_option(mode,uses_history(+)).
7237 :- chr_option(mode,does_use_history(+,+)).
7238 :- chr_option(mode,novel_production_call(+,+,?,?)).
7240 does_use_history(FA,Occ) \ does_use_history(FA,Occ) <=> true.
7241 does_use_history(FA,_) \ uses_history(FA) <=> true.
7242 uses_history(_FA) <=> fail.
7244 does_use_history(FA,Occ) \ novel_production_call(FA,Occ,PossibleGoal,Goal) <=> Goal = PossibleGoal.
7245 novel_production_call(FA,_,_PossibleGoal,Goal) <=> Goal = true.
7247 :- chr_constraint
7248         does_use_field/2,
7249         uses_field/2.
7251 :- chr_option(mode,uses_field(+,+)).
7252 :- chr_option(mode,does_use_field(+,+)).
7254 does_use_field(FA,Field) \ does_use_field(FA,Field) <=> true.
7255 does_use_field(FA,Field) \ uses_field(FA,Field) <=> true.
7256 uses_field(_FA,_Field) <=> fail.
7258 :- chr_constraint 
7259         uses_state/2, 
7260         if_used_state/5, 
7261         used_states_known/0.
7263 :- chr_option(mode,uses_state(+,+)).
7264 :- chr_option(mode,if_used_state(+,+,?,?,?)).
7267 % states ::= not_stored_yet | passive | active | triggered | removed
7269 % allocate CREATES not_stored_yet
7270 %   remove CHECKS  not_stored_yet
7271 % activate CHECKS  not_stored_yet
7273 %  ==> no allocate THEN no not_stored_yet
7275 % recurs   CREATES inactive
7276 % lookup   CHECKS  inactive
7278 % insert   CREATES active
7279 % activate CREATES active
7280 % lookup   CHECKS  active
7281 % recurs   CHECKS  active
7283 % runsusp  CREATES triggered
7284 % lookup   CHECKS  triggered 
7286 % ==> no runsusp THEN no triggered
7288 % remove   CREATES removed
7289 % runsusp  CHECKS  removed
7290 % lookup   CHECKS  removed
7291 % recurs   CHECKS  removed
7293 % ==> no remove THEN no removed
7295 % ==> no allocate, no remove, no active/inactive distinction THEN no state at all...
7297 uses_state(Constraint,State) \ uses_state(Constraint,State) <=> true.
7299 used_states_known, uses_state(Constraint,State) \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal) 
7300         <=> ResultGoal = Used.
7301 used_states_known \ if_used_state(Constraint,State,Used,NotUsed,ResultGoal) 
7302         <=> ResultGoal = NotUsed.
7303 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7304 % % In-place updates
7306 % inplace_updates(Constraints) :- 
7307 %       ( chr_pp_flag(inplace_updates,off) ->
7308 %               true
7309 %       ;
7310 %               inplace_updates0(Constraints)
7311 %       ).
7313 % inplace_updates0([]).
7314 % inplace_updates([C|Cs]) :-
7315 %     inplace_update_allowed(C),
7316 %     inplace_updates0(Cs).
7318 % :- chr_constraint 
7319 %       inplace_update_allowed/1,
7320 %         inplace_update_safe/1,   
7321 %         is_safe_inplace_update/1,
7322 %       partial_remove_insert/7.
7324 % :- chr_option(mode,inplace_update_allowed(+)).
7325 % :- chr_option(mode,inplace_update_safe(+)).
7326 % :- chr_option(mode,is_safe_inplace_update(+)).
7327 % :- chr_option(mode,partial_remove_insert(+,?,?,?,?,?)).
7329 % % pointless to even check for in-place updates if C is never removed
7330 % occurrence(C,ON,RuleNb,ID,_), rule(RuleNb,Rule) \ inplace_update_allowed(C) 
7331 %       <=> 
7332 %               never_removed(C) 
7333 %       | 
7334 %               true.
7336 % inplace_update_allowed(C) ==> reuse_susps_test(C).
7338 % inplace_update_allowed(C) <=> inplace_update_safe(C).
7340 % :-chr_constraint 
7341 %       safe_body_check/5, 
7342 %       all_occs_passive_or_safe/2.
7344 % abstract_constraints(ACs) \ safe_body_check(H1,H2,Guard,G,C) 
7345 %       <=> 
7346 %               ai_observation_abstract_goal_(H1,H2,Guard,G,ACs,AG),
7347 %               check_abstract_body_safety(AG,C).
7349 % safe_body_check(H1,H2,Guard,G,C) <=> fail.
7351 % check_abstract_body_safety([],_).
7352 % check_abstract_body_safety([builtin|_],_) :- !, fail.
7353 % check_abstract_body_safety([AC|Rest],C) :-
7354 %       all_occs_passive_or_safe(AC,C),
7355 %       check_abstract_body_safety(Rest,C).
7357 % % this breaks loops
7358 % this_one_should_not_be_all_passive @ 
7359 % all_occs_passive_or_safe(AC,C), all_occs_passive_or_safe(AC,C) <=> fail.        
7361 % abstract_constraints(ACs), occurrence(AC,ON,RuleNb,ID,_), rule(RuleNb,Rule), all_occs_passive_or_safe(AC,C) 
7362 %       ==> 
7363 %               \+ is_passive(RuleNb,ID),
7364 %               Rule = pragma(rule(Hr,Hk,Guard,Body),ids(IDr,IDk),_,_,_) 
7365 %       |
7366 %               ai_observation_abstract_constraints(Hr,ACs,ARemovedHeads),
7367 %               %not safe if it is removed
7368 %               \+ memberchk_eq(C,ARemovedHeads),
7369 %       safe_body_check(Hr,Hk,Guard,Body,C).
7370 %     
7371 % all_occs_passive_or_safe(AC,C) <=> true.
7373 % check_passive([],RuleNb).
7374 % check_passive([ID|IDs],RuleNb) :- 
7375 %     is_passive(RuleNb,ID), 
7376 %     check_passive(IDs,RuleNb).
7378 % inplace_update_safe(C) \ is_safe_inplace_update(C) <=> true.
7379 % is_safe_inplace_update(C) <=> fail.
7381 % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
7383 % :- chr_constraint 
7384 %       inplace_updates2/0, 
7385 %       maybe_inplace/16.
7387 % inplace_updates2 \ maybe_inplace(C,_,Del,Ins,DelClause,InsClause,_,_,_,_,_,_,_,_,_,_)#Id
7388 %       <=>     
7389 %               chr_pp_flag(inplace_updates,off) 
7390 %       |
7391 %               Del = DelClause,
7392 %               Ins = InsClause
7393 %         pragma 
7394 %               passive(Id).
7396 % inplace_updates2, 
7397 %       maybe_inplace(C,Susp,Del,Ins,DelClause,InsClause,UpdateDelClause,UpdateInsClause,UpdatedArgs,_,OrigVars,TheNewVars,V1,V2,NewState,ResetHistory)#Id
7398 %       <=> 
7399 %               true 
7400 %       |  
7401 %               ( fix_stores(C,Susp,UpdatedArgs,OrigVars,TheNewVars,UpdatedIndexes,RemoveFromModifiedStores,ReInsertIntoModifiedStores,UpdateInsClause,V1,V2,RSA) ->
7402 %                       ( reuse_susps_history_reset_needed(C) ->
7403 %                           update_suspension_field(C,Susp,history,t,ResetHistory)      
7404 %                       ;
7405 %                           ResetHistory = true
7406 %                       ),
7407 %                       ( has_active_occurrence(C) ->
7408 %                               C = F/A,
7409 %                               InsClause =.. [_|NewVars],
7410 %                               append(NewVars,[Susp],VarsSusp),
7411 %                               ( (chr_pp_flag(debugable,on) ; is_stored(C), ( has_active_occurrence(C); chr_pp_flag(late_allocation,off)), ( may_trigger(C) ; get_allocation_occurrence(C,AO), get_max_occurrence(C,MO), MO >= AO ) ) ->
7412 %                                       build_head(F,A,[0],VarsSusp,Delegate),
7413 %                                       ConstraintCall = (SetNewState,Delegate),
7414 %                                       ( NewState = inactive ->
7415 %                                               SetNewState = true
7416 %                                       ;
7417 %                                               update_suspension_field(C,Susp,state,inactive,SetNewState)
7418 %                                       ),
7419 %                                       reuse_susps_removed_needed(C),
7420 %                                       Del = (RemoveFromModifiedStores,UpdateDelClause),
7421 %                                       Ins = (ReInsertIntoModifiedStores,RSA,ConstraintCall)
7422 %                               ;
7423 %                                       Del = DelClause,
7424 %                                       Ins = InsClause
7425 %                               )
7426 %                       ;
7427 %                               Del = (RemoveFromModifiedStores,UpdateDelClause),
7428 %                               Ins = (ReInsertIntoModifiedStores,RSA), 
7429 %                               % weird goal
7430 %                               (NewState = active -> true ; true)
7431 %                       )
7432 %               ;
7433 %                           Del = DelClause,
7434 %                           Ins = InsClause
7435 %               ),
7436 %               inplace_updates2
7437 %       pragma 
7438 %               passive(Id).
7441 % fix_stores(C,Susp,UpdatedArgs,OrigVars,TheNewVars,UpdatedIndexes,RemoveFromModifiedStores,ReInsertIntoModifiedStores,SetArgs,V1,V2,RestSetArgs) :-
7442 %       suspension_term_base(C,Base),
7443 %       get_store_type(C,StoreType),
7444 %       ( StoreType == default -> 
7445 %               RemoveFromModifiedStores = true,   
7446 %               (
7447 %                       none_indexed(UpdatedArgs,C),
7448 %                       UpdatedIndexes = [], 
7449 %                       ReInsertIntoModifiedStores = true,
7450 %                       keep_nonindex_setargs(SetArgs,RestSetArgs,Base)
7451 %               ;
7452 %                       UpdatedIndexes = UpdatedArgs,
7453 %                       attach_constraint_atom(C,NewVars2,Susp,Attach),
7454 %                       detach_constraint_atom(C,OrigVars2,Susp,Detach),
7455 %                       ReInsertIntoModifiedStores = ('chr attach_diff'(OrigVars,TheNewVars,OrigVars2,NewVars2), Detach, Attach),
7456 %                       keep_nonindex_setargs(SetArgs,RestSetArgs,Base)
7457 %               )
7458 %       ;
7459 %               indexargs(StoreType,KeepArgs),
7460 %               intersect_eq(KeepArgs,UpdatedArgs,UpdatedIndexes1),
7461 %               multi_arg_updated_indexes(StoreType,UpdatedIndexes1,UpdatedIndexes,ModifiedStore),
7462 %               generate_insert_constraint_body2(ModifiedStore,C,Susp,V1,V2,ReInsertIntoModifiedStores),
7463 %               keep_nonindex_setargs(SetArgs,UpdatedIndexes1,RestSetArgs,Base),
7464 %               RemoveFromModifiedStores = true
7465 %       ).
7467 % keep_nonindex_setargs(SetArgs,RestSetArgs,Base) :-
7468 %       keep_nonindex_setargs(SetArgs,[],RestSetArgs,Base).
7470 % keep_nonindex_setargs(SetArgs,UpdatedIndexes1,RestSetArgs,Base) :-
7471 %       conj2list(SetArgs,SA),
7472 %       keep_nonindex_setargs_(SA,UpdatedIndexes1,RSA,Base),
7473 %       list2conj(RSA,RestSetArgs).
7475 % keep_nonindex_setargs_([],_,[],_).
7476 % keep_nonindex_setargs_([X|Rest],UI,[X|Rest2],Base) :-
7477 %         var(X), !,
7478 %       keep_nonindex_setargs_(Rest,UI,Rest2,Base).
7479 % keep_nonindex_setargs_([setarg(Pos,X,Y)|Rest],UI,Rest2,Base) :-
7480 %       CPos is Pos - 6,!, % TOM: What is the magic number 6?
7481 %       ( memberchk(CPos,UI) ->
7482 %               Rest2 = R2
7483 %          ;
7484 %                 (CPos > 0 ->
7485 %                         CPos2 is CPos + Base,
7486 %                         Rest2 = [setarg(CPos2,X,Y)|R2]
7487 %                 ;
7488 %                         Rest2 = [setarg(Pos,X,Y)|R2]
7489 %                 )
7490 %          ),
7491 %       keep_nonindex_setargs_(Rest,UI,R2,Base).
7492 % keep_nonindex_setargs_([X|Rest],UI,[X|Rest2],Base) :-
7493 %       keep_nonindex_setargs_(Rest,UI,Rest2,Base).
7494 %       
7496 % generate_insert_constraint_body2(multi_inthash(Indexes),C,Susp,O,N,Body) :-
7497 %       generate_multi_inthash_insert_constraint_bodies2(Indexes,C,Susp,O,N,Body).
7498 % generate_insert_constraint_body2(multi_hash(Indexes),C,Susp,O,N,Body) :-
7499 %       generate_multi_hash_insert_constraint_bodies2(Indexes,C,Susp,O,N,Body).
7500 % generate_insert_constraint_body2(multi_store(StoreTypes),C,Susp,O,N,Body) :-
7501 %       append(O,N,ON),
7502 %       find_with_var_identity(
7503 %               B,
7504 %               [Susp|ON],
7505 %               ( 
7506 %                       lists:member(ST,StoreTypes),
7507 %                       generate_insert_constraint_body2(ST,C,Susp,O,N,B)
7508 %               ),
7509 %               Bodies
7510 %               ),
7511 %       list2conj(Bodies,Body).
7513 % generate_multi_inthash_insert_constraint_bodies2([],_,_,_,_,true).
7514 % generate_multi_inthash_insert_constraint_bodies2([Index|Indexes],FA,Susp,O,N,(Body,Bodies)) :-
7515 %       multi_hash_store_name(FA,Index,StoreName),
7516 %       Index = [Pos],
7517 %       nth(Pos,O,Orig),
7518 %       nth(Pos,N,New),
7519 %         set_dynamic_suspension_term_field(argument(Pos),FA,Susp,New,UpdateArgument),
7520 %       Body =
7521 %       (
7522 %               (Orig == New ->
7523 %                       true
7524 %               ;
7525 %                       nb_getval(StoreName,Store),
7526 %                       chr_integertable_store:delete_ht(Store,Orig,Susp),
7527 %                         UpdateArgument,
7528 %                       chr_integertable_store:insert_ht(Store,New,Susp)
7529 %               )
7530 %       ),
7531 %       generate_multi_inthash_insert_constraint_bodies2(Indexes,FA,Susp,O,N,Bodies).
7532 % generate_multi_hash_insert_constraint_bodies2([],_,_,_,_,true).
7533 % generate_multi_hash_insert_constraint_bodies2([Index|Indexes],FA,Susp,O,N,(Body,Bodies)) :-
7534 %       multi_hash_store_name(FA,Index,StoreName),
7535 %       multi_hash_key2(FA,Index,Susp,O,N,Key1,Key2,SetArgs),
7536 %       Body =
7537 %       (
7538 %               (Key1 == Key2 ->
7539 %                       true
7540 %               ;
7541 %                       nb_getval(StoreName,Store),
7542 %                       chr_hashtable_store:delete_ht(Store,Key1,Susp),
7543 %                       SetArgs,
7544 %                       chr_hashtable_store:insert_ht(Store,Key2,Susp)
7545 %               )
7546 %       ),
7547 %       generate_multi_hash_insert_constraint_bodies2(Indexes,FA,Susp,O,N,Bodies).
7549 % multi_hash_key2(F/A,Index,Susp,O,N,Key1,Key2,SetArgs) :-
7550 %       ( ( integer(Index) ->
7551 %               I = Index
7552 %         ; 
7553 %               Index = [I]
7554 %         ) ->
7555 %               nth(I,O,Key1),
7556 %               nth(I,N,Key2),
7557 %                 set_dynamic_suspension_term_field(argument(I),F/A,Susp,Key2,SetArgs)
7558 %                 
7559 %       ; is_list(Index) ->
7560 %               sort(Index,Indexes),
7561 %               append(O,N,ON),
7562 %               find_with_var_identity(
7563 %                         SetArg-(KeyO-KeyI),
7564 %                       [Susp|ON],
7565 %                       (lists:member(I,Indexes),
7566 %                        lists:nth(I,N,KeyI),
7567 %                        lists:nth(I,O,KeyO),
7568 %                          set_dynamic_suspension_term_field(argument(I),F/A,Susp,KeyI,SetArg)),
7569 %                       ArgKeyPairs),
7570 %               pairup(Bodies,Keys,ArgKeyPairs),
7571 %               pairup(OldKey,NewKey,Keys),
7572 %               Key1 =.. [k|OldKey],
7573 %               Key2 =.. [k|NewKey],
7574 %               list2conj(Bodies,SetArgs)
7575 %       ).
7578 % avoid_redundant_arg_getval([],_,_,[]).
7579 % avoid_redundant_arg_getval([arg(Pos,Susp,Var)|Rest],SetArgs,GetVals,Rest2) :-
7580 %       already_set(SetArgs,Pos,Susp,Var), !,
7581 %       avoid_redundant_arg_getval(Rest,SetArgs,GetVals,Rest2).
7582 % avoid_redundant_arg_getval([nb_getval(Table,Var)|Rest],SetArgs,GetVals,Rest2) :-
7583 %       already_got(GetVals,Table,Var), !,
7584 %       avoid_redundant_arg_getval(Rest,SetArgs,GetVals,Rest2).
7585 % avoid_redundant_arg_getval([X|Rest],SetArgs,GetVals,[X|Rest2]) :-
7586 %       avoid_redundant_arg_getval(Rest,SetArgs,GetVals,Rest2).
7588 % already_set([setarg(Pos,Susp2,Var2)|_],Pos,Susp,Var) :-
7589 %       Susp == Susp2, !, Var = Var2.
7590 % already_set([_|Rest],Pos,Susp,Var) :- 
7591 %       already_set(Rest,Pos,Susp,Var).
7593 % already_got([nb_getval(Table,Var2)|_],Table,Var) :-
7594 %       !, Var = Var2.
7595 % already_got([_|Rest],Table,Var) :- already_got(Rest,Table,Var).
7599 % % TOM: Is this predicate used?
7600 % singleton(C) :- 
7601 %       get_store_type(C,StoreType),
7602 %       ( 
7603 %               StoreType = global_singleton
7604 %       ;
7605 %                StoreType = multi_store([global_singleton])
7606 %       ).
7609 % inplace_updates2 \ reuse_susps_removed(_,_,X) <=> X = true.
7610 % inplace_updates2 \ reuse_susps_active(_,_,X) <=> X = true.
7612 % inplace_updates2 \
7613 %         partial_remove_insert(F/A,X,TheNewVars,PartialRemove,PartialInsert,SetArgs,V2)
7614 %         <=>
7615 %         (get_store_type(F/A,StoreType),
7616 %               (StoreType \== default ->
7617 %                  indexargs(StoreType,UpdatedArgs)
7618 %               ;
7619 %                  length(UpdatedArgs,A),
7620 %                  fill_inc_numbers(UpdatedArgs,1)
7621 %               ),
7622 %         length(V1,A),
7623 %         fix_stores(F/A,X,UpdatedArgs,V1,TheNewVars
7624 %         , UpdatedIndexes, RemoveFromModifiedStores, 
7625 %         ReInsertIntoModifiedStores,SetArgs,V1,V2,RemainingSetArgs) ->
7626 %               term_variables(ReInsertIntoModifiedStores,UsedVars),
7627 %                 suspension_term_base(F/A,Base),
7628 %                 Base1 is Base+1,
7629 %               getorigvars(V1,Base1,X,UsedVars,GetOrigVars2),
7630 %               
7631 %               PartialRemove = 
7632 %                       (GetOrigVars2,
7633 %                       RemoveFromModifiedStores),
7634 %               PartialInsert = (ReInsertIntoModifiedStores,RemainingSetArgs)
7635 %         ;
7636 %               writeln('ERROR: could not fix stores')
7637 %         ).      
7641 % getorigvars([],_,_,_,true).
7642 % getorigvars([V|Vs],Pos,Susp,UV,T) :-
7643 %       Pos1 is Pos+1,
7644 %       (memberchk_eq(V,UV) ->
7645 %               T = (arg(Pos,Susp,V),RT),
7646 %               getorigvars(Vs,Pos1,Susp,UV,RT)
7647 %       ;
7648 %               getorigvars(Vs,Pos1,Susp,UV,T)
7649 %       ).
7651 % fill_inc_numbers([],_).
7652 % fill_inc_numbers([A|As],A) :- B is A+1, fill_inc_numbers(As,B).
7654 % inplace_updates2 <=> true.
7656 % get_extra_constraint_clauses([],_C,[],[]).
7657 % get_extra_constraint_clauses([A|RC],C,EC,EC2) :-
7658 %       once((A = (Head :- B) ; A = Head)),
7659 %       ( Head = (C-H2) ->
7660 %               EC = [(H2 :- B)|REC],
7661 %               EC2 = REC2
7662 %       ;
7663 %               EC = REC,
7664 %               EC2 = [A|REC2]
7665 %       ),
7666 %       get_extra_constraint_clauses(RC,C,REC,REC2).
7668 % :- chr_constraint onlyone/1, isonlyone/1.
7669 % :- chr_option(mode,onlyone(+)).
7670 % :- chr_option(mode,isonlyone(+)).
7672 % onlyone(C) \ onlyone(C) <=> true.
7673 % onlyone(C) \ isonlyone(C) <=> true.
7674 % isonlyone(C) <=> fail.
7677 % none_indexed([],_).
7678 % none_indexed([A|As],C) :-
7679 %       ( is_indexed_argument(C,A), get_constraint_mode(C,Mode), nth(A,Mode,M), M \== (+) -> 
7680 %               fail
7681 %       ; 
7682 %               none_indexed(As,C) 
7683 %       ).
7686 % multi_arg_updated_indexes(multi_inthash(Indices),UI,UpdInd,multi_inthash(UpdInd)) :- !, 
7687 %       find_updated(Indices,UI,UpdInd).
7688 % multi_arg_updated_indexes(multi_hash(Indices),UI,UpdInd,multi_hash(UpdInd)) :- !, 
7689 %       find_updated(Indices,UI,UpdInd).
7691 % find_updated([],_,[]).
7692 % find_updated([Ind|RInd],UI,RInd2) :- 
7693 %       intersect_eq(Ind,UI,[]), !, 
7694 %       find_updated(RInd,UI,RInd2).
7695 % find_updated([Ind|RInd],UI,[Ind|RInd2]) :- !, 
7696 %       find_updated(RInd,UI,RInd2).
7698 % multi_arg_updated_indexes(multi_store([]),_,[],multi_store([])) :- !.
7699 % multi_arg_updated_indexes(multi_store([S|Ss]),UI,UI2,multi_store([AS|ASs])) :- !,
7700 %     multi_arg_updated_indexes(S,UI,X1,AS), 
7701 %     multi_arg_updated_indexes(multi_store(Ss),UI,X2,multi_store(ASs)),
7702 %     append(X1,X2,Args_),
7703 %     sort(Args_,UI2).
7704 % multi_arg_updated_indexes(_,_,[],multi_store([])).
7709 % indexargs(multi_inthash(Indexes),Args) :- !,indexes2args(Indexes,Args).
7710 % indexargs(multi_hash(Indexes),Args) :- !,indexes2args(Indexes,Args).
7711 % indexargs(multi_store([]),[]) :- !.
7712 % indexargs(multi_store([S|Ss]),Args) :- !,
7713 %     indexargs(S,A1), 
7714 %     indexargs(multi_store(Ss),A2),
7715 %     append(A1,A2,Args_),
7716 %     sort(Args_,Args).
7717 % indexargs(global_ground,[]).
7718 % indexargs(global_singleton,[]).
7719 % % no default store (need to add support for correct detach-attach)
7721 % indexes2args([],[]).
7722 % indexes2args([[]|R],Ys) :- !, indexes2args(R,Ys).
7723 % indexes2args([[X|Xs]|R],[X|Ys]) :- !,indexes2args([Xs|R],Ys).
7724 % indexes2args([X|R],[X|Ys]) :- !,indexes2args(R,Ys).