| blob | b661b4d5c91819868b28bbcc7a7f01798e35ffb6 |
1 /* $Id$
3 Part of CHR (Constraint Handling Rules)
5 Author: Tom Schrijvers
6 E-mail: Tom.Schrijvers@cs.kuleuven.ac.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.
30 */
32 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
33 %%
34 %% ____ _ _ ____ ____ _ _
35 %% / ___| | | | _ \ / ___|___ _ __ ___ _ __ (_) | ___ _ __
36 %% | | | |_| | |_) | | | / _ \| '_ ` _ \| '_ \| | |/ _ \ '__|
37 %% | |___| _ | _ < | |__| (_) | | | | | | |_) | | | __/ |
38 %% \____|_| |_|_| \_\ \____\___/|_| |_| |_| .__/|_|_|\___|_|
39 %% |_|
40 %%
41 %% hProlog CHR compiler:
42 %%
43 %% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.ac.be
44 %%
45 %% * based on the SICStus CHR compilation by Christian Holzbaur
46 %%
47 %% First working version: 6 June 2003
48 %%
49 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
50 %% To Do
51 %%
52 %% * SICStus compatibility
53 %% - rules/1 declaration
54 %% - options
55 %% - pragmas
56 %% - tell guard
57 %%
58 %%
59 %% * do not suspend on variables that don't matter
60 %% * make difference between cheap guards for reordering
61 %% and non-binding guards for lock removal
62 %%
63 %% * unqiue -> once/[] transformation for propagation
64 %%
65 %% * cheap guards interleaved with head retrieval + faster
66 %% via-retrieval + non-empty checking for propagation rules
67 %% redo for simpagation_head2 prelude
68 %%
69 %% * intelligent backtracking for simplification/simpagation rule
70 %% generator_1(X),'_$savecp'(CP_1),
71 %% ...
72 %% if( (
73 %% generator_n(Y),
74 %% test(X,Y)
75 %% ),
76 %% true,
77 %% ('_$cutto'(CP_1), fail)
78 %% ),
79 %% ...
80 %%
81 %% or recently developped cascading-supported approach
82 %%
83 %% * intelligent backtracking for propagation rule
84 %% use additional boolean argument for each possible smart backtracking
85 %% when boolean at end of list true -> no smart backtracking
86 %% false -> smart backtracking
87 %% only works for rules with at least 3 constraints in the head
88 %%
89 %% * mutually exclusive rules
90 %%
91 %% * (set semantics + functional dependency) declaration + resolution
92 %%
93 %% * type and instantiation declarations + optimisations
94 %% + better indexes
95 %%
96 %% * disable global store option
97 %%
98 %% Done
99 %%
100 %% * debugging events
101 %% * constraints that can never be attached / always simplified away
102 %% -> need not be considered in diverse operations
103 %% * clean up generated code
104 %% * input verification: pragmas
105 %% * SICStus compatibility: handler/1, constraints/1
106 %% * optimise variable passing for propagation rule
107 %% * reordering of head constraints for passive head search
108 %% * unique inference for simpagation rules
109 %% * unique optimisation for simpagation and simplification rules
110 %% * cheap guards interleaved with head retrieval + faster
111 %% via-retrieval + non-empty checking for simplification / simpagation rules
112 %% * transform
113 %% C1 \ C2 <=> true | Body.
114 %% into
115 %% C1 # ID \ C2 <=> true | Body pragma passive(ID).
116 %% where C1 and C2 are indentical under functional dependency information
117 %% * valid to disregard body in uniqueness inference?
118 %% * unique inference for simplification rules
119 %%
120 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
122 :- module(chr_translate_bootstrap1,
123 [ chr_translate/2 % +Decls, -TranslatedDecls
124 ]).
125 :- use_module(library(lists)).
126 :- use_module(hprolog).
127 :- use_module(library(assoc)).
128 :- use_module(pairlist).
129 :- use_module(library(ordsets)).
130 :- include(chr_op2).
133 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
134 :- constraints
135 constraint/2,
136 constraint_count/1,
137 constraint_index/2,
138 get_constraint_index/2,
139 max_constraint_index/1,
140 get_max_constraint_index/1,
141 target_module/1,
142 get_target_module/1,
143 attached/2,
144 is_attached/1,
145 chr_clear/0.
147 constraint(FA,Number) \ constraint(FA,Query)
148 <=> Query = Number.
149 constraint(FA,Index) # ID \ constraint(Query,Index)
150 <=> Query = FA pragma passive(ID).
152 constraint_count(Index) # ID \ constraint_count(Query)
153 <=> Query = Index pragma passive(ID).
155 target_module(Mod) # ID \ get_target_module(Query)
156 <=> Query = Mod
157 pragma passive(ID).
158 get_target_module(Query)
159 <=> Query = user.
161 constraint_index(C,Index) # ID \ get_constraint_index(C,Query)
162 <=> Query = Index
163 pragma passive(ID).
164 get_constraint_index(C,Query)
165 <=> fail.
167 max_constraint_index(Index) # ID \ get_max_constraint_index(Query)
168 <=> Query = Index
169 pragma passive(ID).
170 get_max_constraint_index(Query)
171 <=> fail.
173 attached(Constr,yes) \ attached(Constr,_) <=> true.
174 attached(Constr,no) \ attached(Constr,_) <=> true.
175 attached(Constr,maybe) \ attached(Constr,maybe) <=> true.
177 attached(Constr,Type) # ID \ is_attached(Constr)
178 <=> true |
179 ( Type == no ->
180 fail
181 ;
182 true
183 )
184 pragma passive(ID).
185 is_attached(C) <=> true.
187 chr_clear \ constraint(_,_) # ID
188 <=> true pragma passive(ID).
189 chr_clear \ constraint_count(_) # ID
190 <=> true pragma passive(ID).
191 chr_clear \ constraint_index(_,_) # ID
192 <=> true pragma passive(ID).
193 chr_clear \ max_constraint_index(_) # ID
194 <=> true pragma passive(ID).
195 chr_clear \ target_module(_) # ID
196 <=> true pragma passive(ID).
197 chr_clear \ attached(_,_) # ID
198 <=> true pragma passive(ID).
199 chr_clear
200 <=> true.
201 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
203 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
204 %%
205 %% Translation
207 chr_translate(Declarations,NewDeclarations) :-
208 init_chr_pp_flags,
209 partition_clauses(Declarations,Decls,Rules,OtherClauses),
210 ( Decls == [] ->
211 NewDeclarations = OtherClauses
212 ;
213 check_rules(Rules,Decls),
214 unique_analyse_optimise(Rules,NRules),
215 check_attachments(NRules),
216 set_constraint_indices(Decls,1),
217 store_management_preds(Decls,StoreClauses),
218 constraints_code(Decls,NRules,ConstraintClauses),
219 append_lists([OtherClauses,
220 StoreClauses,
221 ConstraintClauses
222 ],
223 NewDeclarations)
224 ),
225 chr_clear.
227 store_management_preds(Constraints,Clauses) :-
228 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
229 generate_attach_increment(AttachIncrementClauses),
230 generate_attr_unify_hook(AttrUnifyHookClauses),
231 append_lists([AttachAConstraintClauses
232 ,AttachIncrementClauses
233 ,AttrUnifyHookClauses]
234 ,Clauses).
237 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
238 %%
239 %% Partitioning of clauses into constraint declarations, chr rules and other
240 %% clauses
242 partition_clauses([],[],[],[]).
243 partition_clauses([C|Cs],Ds,Rs,OCs) :-
244 ( rule(C,R) ->
245 Ds = RDs,
246 Rs = [R | RRs],
247 OCs = ROCs
248 ; is_declaration(C,D) ->
249 append(D,RDs,Ds),
250 Rs = RRs,
251 OCs = ROCs
252 ; is_module_declaration(C,Mod) ->
253 target_module(Mod),
254 Ds = RDs,
255 Rs = RRs,
256 OCs = [C|ROCs]
257 ; C = (handler _) ->
258 format('CHR compiler WARNING: ~w.\n',[C]),
259 format(' `--> SICStus compatibility: ignoring handler/1 declaration.\n',[]),
260 Ds = RDs,
261 Rs = RRs,
262 OCs = ROCs
263 ; C = (rules _) ->
264 format('CHR compiler WARNING: ~w.\n',[C]),
265 format(' `--> SICStus compatibility: ignoring rules/1 declaration.\n',[]),
266 Ds = RDs,
267 Rs = RRs,
268 OCs = ROCs
269 ; C = option(OptionName,OptionValue) ->
270 handle_option(OptionName,OptionValue),
271 Ds = RDs,
272 Rs = RRs,
273 OCs = ROCs
274 ; Ds = RDs,
275 Rs = RRs,
276 OCs = [C|ROCs]
277 ),
278 partition_clauses(Cs,RDs,RRs,ROCs).
280 is_declaration(D, Constraints) :- %% constraint declaration
281 ( D = (:- Decl) ->
282 true
283 ;
284 D = Decl
285 ),
286 Decl =.. [constraints,Cs],
287 conj2list(Cs,Constraints).
289 %% Data Declaration
290 %%
291 %% pragma_rule
292 %% -> pragma(
293 %% rule,
294 %% ids,
295 %% list(pragma),
296 %% yesno(string)
297 %% )
298 %%
299 %% ids -> ids(
300 %% list(int),
301 %% list(int)
302 %% )
303 %%
304 %% rule -> rule(
305 %% list(constraint), :: constraints to be removed
306 %% list(constraint), :: surviving constraints
307 %% goal, :: guard
308 %% goal :: body
309 %% )
311 rule(RI,R) :- %% name @ rule
312 RI = (Name @ RI2), !,
313 rule(RI2,yes(Name),R).
314 rule(RI,R) :-
315 rule(RI,no,R).
317 rule(RI,Name,R) :-
318 RI = (RI2 pragma P), !, %% pragmas
319 is_rule(RI2,R1,IDs),
320 conj2list(P,Ps),
321 R = pragma(R1,IDs,Ps,Name).
322 rule(RI,Name,R) :-
323 is_rule(RI,R1,IDs),
324 R = pragma(R1,IDs,[],Name).
326 is_rule(RI,R,IDs) :- %% propagation rule
327 RI = (H ==> B), !,
328 conj2list(H,Head2i),
329 get_ids(Head2i,IDs2,Head2),
330 IDs = ids([],IDs2),
331 ( B = (G | RB) ->
332 R = rule([],Head2,G,RB)
333 ;
334 R = rule([],Head2,true,B)
335 ).
336 is_rule(RI,R,IDs) :- %% simplification/simpagation rule
337 RI = (H <=> B), !,
338 ( B = (G | RB) ->
339 Guard = G,
340 Body = RB
341 ; Guard = true,
342 Body = B
343 ),
344 ( H = (H1 \ H2) ->
345 conj2list(H1,Head2i),
346 conj2list(H2,Head1i),
347 get_ids(Head2i,IDs2,Head2,0,N),
348 get_ids(Head1i,IDs1,Head1,N,_),
349 IDs = ids(IDs1,IDs2)
350 ; conj2list(H,Head1i),
351 Head2 = [],
352 get_ids(Head1i,IDs1,Head1),
353 IDs = ids(IDs1,[])
354 ),
355 R = rule(Head1,Head2,Guard,Body).
357 get_ids(Cs,IDs,NCs) :-
358 get_ids(Cs,IDs,NCs,0,_).
360 get_ids([],[],[],N,N).
361 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN) :-
362 ( C = (NC # N) ->
363 true
364 ;
365 NC = C
366 ),
367 M is N + 1,
368 get_ids(Cs,IDs,NCs, M,NN).
370 is_module_declaration((:- module(Mod)),Mod).
371 is_module_declaration((:- module(Mod,_)),Mod).
373 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
375 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
376 %% Some input verification:
377 %% - all constraints in heads are declared constraints
379 check_rules(Rules,Decls) :-
380 check_rules(Rules,Decls,1).
382 check_rules([],_,_).
383 check_rules([PragmaRule|Rest],Decls,N) :-
384 check_rule(PragmaRule,Decls,N),
385 N1 is N + 1,
386 check_rules(Rest,Decls,N1).
388 check_rule(PragmaRule,Decls,N) :-
389 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name),
390 Rule = rule(H1,H2,_,_),
391 append(H1,H2,HeadConstraints),
392 check_head_constraints(HeadConstraints,Decls,PragmaRule,N),
393 check_pragmas(Pragmas,PragmaRule,N).
395 check_head_constraints([],_,_,_).
396 check_head_constraints([Constr|Rest],Decls,PragmaRule,N) :-
397 functor(Constr,F,A),
398 ( member(F/A,Decls) ->
399 check_head_constraints(Rest,Decls,PragmaRule,N)
400 ;
401 format('CHR compiler ERROR: Undeclared constraint ~w in head of ~@.\n',
402 [F/A,format_rule(PragmaRule,N)]),
403 format(' `--> Constraint should be on of ~w.\n',[Decls]),
404 fail
405 ).
407 check_pragmas([],_,_).
408 check_pragmas([Pragma|Pragmas],PragmaRule,N) :-
409 check_pragma(Pragma,PragmaRule,N),
410 check_pragmas(Pragmas,PragmaRule,N).
412 check_pragma(Pragma,PragmaRule,N) :-
413 var(Pragma), !,
414 format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',
415 [Pragma,format_rule(PragmaRule,N)]),
416 format(' `--> Pragma should not be a variable!\n',[]),
417 fail.
419 check_pragma(passive(ID), PragmaRule, N) :-
420 !,
421 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_),
422 ( memberchk_eq(ID,IDs1) ->
423 true
424 ; memberchk_eq(ID,IDs2) ->
425 true
426 ;
427 format('CHR compiler ERROR: invalid identifier ~w in pragma passive in ~@.\n',
428 [ID,format_rule(PragmaRule,N)]),
429 fail
430 ).
432 check_pragma(Pragma, PragmaRule, N) :-
433 Pragma = unique(_,_),
434 !,
435 format('CHR compiler WARNING: undocument pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
436 format(' `--> Only use this pragma if you know what you are doing.\n',[]).
438 check_pragma(Pragma, PragmaRule, N) :-
439 Pragma = already_in_heads,
440 !,
441 format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
442 format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
444 check_pragma(Pragma, PragmaRule, N) :-
445 Pragma = already_in_head(_),
446 !,
447 format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
448 format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
450 check_pragma(Pragma,PragmaRule,N) :-
451 format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
452 format(' `--> Pragma should be one of passive/1!\n',[]),
453 fail.
455 format_rule(PragmaRule,N) :-
456 PragmaRule = pragma(_,_,_,MaybeName),
457 ( MaybeName = yes(Name) ->
458 write('rule '), write(Name)
459 ;
460 write('rule number '), write(N)
461 ).
463 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
465 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
466 % Global Options
467 %
469 handle_option(Var,Value) :-
470 var(Var), !,
471 format('CHR compiler ERROR: ~w.\n',[option(Var,Value)]),
472 format(' `--> First argument should be an atom, not a variable.\n',[]),
473 fail.
475 handle_option(Name,Value) :-
476 var(Value), !,
477 format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
478 format(' `--> Second argument should be a nonvariable.\n',[]),
479 fail.
481 handle_option(Name,Value) :-
482 option_definition(Name,Value,Flags),
483 !,
484 set_chr_pp_flags(Flags).
486 handle_option(Name,Value) :-
487 \+ option_definition(Name,_,_), !.
489 handle_option(Name,Value) :-
490 findall(V,option_definition(Name,V,_),Vs),
491 format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
492 format(' `--> Invalid value ~w: should be one of ~w.\n',[Value,Vs]),
493 fail.
495 option_definition(optimize,experimental,Flags) :-
496 Flags = [ unique_analyse_optimise - on,
497 check_unnecessary_active - full,
498 reorder_heads - on,
499 set_semantics_rule - on,
500 check_attachments - on,
501 guard_via_reschedule - on
502 ].
503 option_definition(optimize,full,Flags) :-
504 Flags = [ unique_analyse_optimise - on,
505 check_unnecessary_active - full,
506 reorder_heads - on,
507 set_semantics_rule - on,
508 check_attachments - on,
509 guard_via_reschedule - on
510 ].
512 option_definition(optimize,sicstus,Flags) :-
513 Flags = [ unique_analyse_optimise - off,
514 check_unnecessary_active - simplification,
515 reorder_heads - off,
516 set_semantics_rule - off,
517 check_attachments - off,
518 guard_via_reschedule - off
519 ].
521 option_definition(optimize,off,Flags) :-
522 Flags = [ unique_analyse_optimise - off,
523 check_unnecessary_active - off,
524 reorder_heads - off,
525 set_semantics_rule - off,
526 check_attachments - off,
527 guard_via_reschedule - off
528 ].
530 option_definition(debug,off,Flags) :-
531 Flags = [ debugable - off ].
532 option_definition(debug,on,Flags) :-
533 Flags = [ debugable - on ].
535 option_definition(check_guard_bindings,on,Flags) :-
536 Flags = [ guard_locks - on ].
538 option_definition(check_guard_bindings,off,Flags) :-
539 Flags = [ guard_locks - off ].
541 init_chr_pp_flags :-
542 chr_pp_flag_definition(Name,[DefaultValue|_]),
543 set_chr_pp_flag(Name,DefaultValue),
544 fail.
545 init_chr_pp_flags.
547 set_chr_pp_flags([]).
548 set_chr_pp_flags([Name-Value|Flags]) :-
549 set_chr_pp_flag(Name,Value),
550 set_chr_pp_flags(Flags).
552 set_chr_pp_flag(Name,Value) :-
553 atom_concat('$chr_pp_',Name,GlobalVar),
554 nb_setval(GlobalVar,Value).
556 chr_pp_flag_definition(unique_analyse_optimise,[on,off]).
557 chr_pp_flag_definition(check_unnecessary_active,[full,simplification,off]).
558 chr_pp_flag_definition(reorder_heads,[on,off]).
559 chr_pp_flag_definition(set_semantics_rule,[on,off]).
560 chr_pp_flag_definition(guard_via_reschedule,[on,off]).
561 chr_pp_flag_definition(guard_locks,[on,off]).
562 chr_pp_flag_definition(check_attachments,[on,off]).
563 chr_pp_flag_definition(debugable,[off,on]).
565 chr_pp_flag(Name,Value) :-
566 atom_concat('$chr_pp_',Name,GlobalVar),
567 nb_getval(GlobalVar,V),
568 ( V == [] ->
569 chr_pp_flag_definition(Name,[Value|_])
570 ;
571 V = Value
572 ).
573 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
575 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
576 %%
577 %% Generated predicates
578 %% attach_$CONSTRAINT
579 %% attach_increment
580 %% detach_$CONSTRAINT
581 %% attr_unify_hook
583 %% attach_$CONSTRAINT
584 generate_attach_detach_a_constraint_all([],[]).
585 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
586 ( is_attached(Constraint) ->
587 generate_attach_a_constraint(Constraint,Clauses1),
588 generate_detach_a_constraint(Constraint,Clauses2)
589 ;
590 Clauses1 = [],
591 Clauses2 = []
592 ),
593 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
594 append_lists([Clauses1,Clauses2,Clauses3],Clauses).
596 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
597 generate_attach_a_constraint_empty_list(Constraint,Clause1),
598 get_max_constraint_index(N),
599 ( N == 1 ->
600 generate_attach_a_constraint_1_1(Constraint,Clause2)
601 ;
602 generate_attach_a_constraint_t_p(Constraint,Clause2)
603 ).
605 generate_attach_a_constraint_empty_list(CFct / CAty,Clause) :-
606 atom_concat_list(['attach_',CFct, (/) ,CAty],Fct),
607 Args = [[],_],
608 Head =.. [Fct | Args],
609 Clause = ( Head :- true).
611 generate_attach_a_constraint_1_1(CFct / CAty,Clause) :-
612 atom_concat_list(['attach_',CFct, (/) ,CAty],Fct),
613 Args = [[Var|Vars],Susp],
614 Head =.. [Fct | Args],
615 RecursiveCall =.. [Fct,Vars,Susp],
616 get_target_module(Mod),
617 Body =
618 (
619 ( get_attr(Var, Mod, Susps) ->
620 NewSusps=[Susp|Susps],
621 put_attr(Var, Mod, NewSusps)
622 ;
623 put_attr(Var, Mod, [Susp])
624 ),
625 RecursiveCall
626 ),
627 Clause = (Head :- Body).
629 generate_attach_a_constraint_t_p(CFct / CAty,Clause) :-
630 atom_concat_list(['attach_',CFct, (/) ,CAty],Fct),
631 Args = [[Var|Vars],Susp],
632 Head =.. [Fct | Args],
633 RecursiveCall =.. [Fct,Vars,Susp],
634 get_constraint_index(CFct/CAty,Position),
635 or_pattern(Position,Pattern),
636 get_max_constraint_index(Total),
637 make_attr(Total,Mask,SuspsList,Attr),
638 nth(Position,SuspsList,Susps),
639 substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
640 make_attr(Total,Mask,SuspsList1,NewAttr1),
641 substitute(Susps,SuspsList,[Susp],SuspsList2),
642 make_attr(Total,NewMask,SuspsList2,NewAttr2),
643 copy_term(SuspsList,SuspsList3),
644 nth(Position,SuspsList3,[Susp]),
645 chr_delete(SuspsList3,[Susp],RestSuspsList),
646 set_elems(RestSuspsList,[]),
647 make_attr(Total,Pattern,SuspsList3,NewAttr3),
648 get_target_module(Mod),
649 Body =
650 (
651 ( get_attr(Var,Mod,TAttr) ->
652 TAttr = Attr,
653 ( Mask /\ Pattern =:= Pattern ->
654 put_attr(Var, Mod, NewAttr1)
655 ;
656 NewMask is Mask \/ Pattern,
657 put_attr(Var, Mod, NewAttr2)
658 )
659 ;
660 put_attr(Var,Mod,NewAttr3)
661 ),
662 RecursiveCall
663 ),
664 Clause = (Head :- Body).
666 %% detach_$CONSTRAINT
667 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
668 generate_detach_a_constraint_empty_list(Constraint,Clause1),
669 get_max_constraint_index(N),
670 ( N == 1 ->
671 generate_detach_a_constraint_1_1(Constraint,Clause2)
672 ;
673 generate_detach_a_constraint_t_p(Constraint,Clause2)
674 ).
676 generate_detach_a_constraint_empty_list(CFct / CAty,Clause) :-
677 atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
678 Args = [[],_],
679 Head =.. [Fct | Args],
680 Clause = ( Head :- true).
682 generate_detach_a_constraint_1_1(CFct / CAty,Clause) :-
683 atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
684 Args = [[Var|Vars],Susp],
685 Head =.. [Fct | Args],
686 RecursiveCall =.. [Fct,Vars,Susp],
687 get_target_module(Mod),
688 Body =
689 (
690 ( get_attr(Var,Mod,Susps) ->
691 'chr sbag_del_element'(Susps,Susp,NewSusps),
692 ( NewSusps == [] ->
693 del_attr(Var,Mod)
694 ;
695 put_attr(Var,Mod,NewSusps)
696 )
697 ;
698 true
699 ),
700 RecursiveCall
701 ),
702 Clause = (Head :- Body).
704 generate_detach_a_constraint_t_p(CFct / CAty,Clause) :-
705 atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
706 Args = [[Var|Vars],Susp],
707 Head =.. [Fct | Args],
708 RecursiveCall =.. [Fct,Vars,Susp],
709 get_constraint_index(CFct/CAty,Position),
710 or_pattern(Position,Pattern),
711 and_pattern(Position,DelPattern),
712 get_max_constraint_index(Total),
713 make_attr(Total,Mask,SuspsList,Attr),
714 nth(Position,SuspsList,Susps),
715 substitute(Susps,SuspsList,[],SuspsList1),
716 make_attr(Total,NewMask,SuspsList1,Attr1),
717 substitute(Susps,SuspsList,NewSusps,SuspsList2),
718 make_attr(Total,Mask,SuspsList2,Attr2),
719 get_target_module(Mod),
720 Body =
721 (
722 ( get_attr(Var,Mod,TAttr) ->
723 TAttr = Attr,
724 ( Mask /\ Pattern =:= Pattern ->
725 'chr sbag_del_element'(Susps,Susp,NewSusps),
726 ( NewSusps == [] ->
727 NewMask is Mask /\ DelPattern,
728 ( NewMask == 0 ->
729 del_attr(Var,Mod)
730 ;
731 put_attr(Var,Mod,Attr1)
732 )
733 ;
734 put_attr(Var,Mod,Attr2)
735 )
736 ;
737 true
738 )
739 ;
740 true
741 ),
742 RecursiveCall
743 ),
744 Clause = (Head :- Body).
746 %% detach_$CONSTRAINT
747 generate_attach_increment([Clause1,Clause2]) :-
748 generate_attach_increment_empty(Clause1),
749 get_max_constraint_index(N),
750 ( N == 1 ->
751 generate_attach_increment_one(Clause2)
752 ;
753 generate_attach_increment_many(N,Clause2)
754 ).
756 generate_attach_increment_empty((attach_increment([],_) :- true)).
758 generate_attach_increment_one(Clause) :-
759 Head = attach_increment([Var|Vars],Susps),
760 get_target_module(Mod),
761 Body =
762 (
763 'chr not_locked'(Var),
764 ( get_attr(Var,Mod,VarSusps) ->
765 sort(VarSusps,SortedVarSusps),
766 merge(Susps,SortedVarSusps,MergedSusps),
767 put_attr(Var,Mod,MergedSusps)
768 ;
769 put_attr(Var,Mod,Susps)
770 ),
771 attach_increment(Vars,Susps)
772 ),
773 Clause = (Head :- Body).
775 generate_attach_increment_many(N,Clause) :-
776 make_attr(N,Mask,SuspsList,Attr),
777 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
778 Head = attach_increment([Var|Vars],Attr),
779 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
780 list2conj(Gs,SortGoals),
781 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
782 make_attr(N,MergedMask,MergedSuspsList,NewAttr),
783 get_target_module(Mod),
784 Body =
785 (
786 'chr not_locked'(Var),
787 ( get_attr(Var,Mod,TOtherAttr) ->
788 TOtherAttr = OtherAttr,
789 SortGoals,
790 MergedMask is Mask \/ OtherMask,
791 put_attr(Var,Mod,NewAttr)
792 ;
793 put_attr(Var,Mod,Attr)
794 ),
795 attach_increment(Vars,Attr)
796 ),
797 Clause = (Head :- Body).
799 %% attr_unify_hook
800 generate_attr_unify_hook([Clause]) :-
801 get_max_constraint_index(N),
802 ( N == 1 ->
803 generate_attr_unify_hook_one(Clause)
804 ;
805 generate_attr_unify_hook_many(N,Clause)
806 ).
808 generate_attr_unify_hook_one(Clause) :-
809 Head = Mod:attr_unify_hook(Susps,Other),
810 get_target_module(Mod),
811 make_run_suspensions(NewSusps,WakeNewSusps),
812 make_run_suspensions(Susps,WakeSusps),
813 Body =
814 (
815 sort(Susps, SortedSusps),
816 ( var(Other) ->
817 ( get_attr(Other,Mod,OtherSusps) ->
818 true
819 ;
820 OtherSusps = []
821 ),
822 sort(OtherSusps,SortedOtherSusps),
823 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
824 put_attr(Other,Mod,NewSusps),
825 WakeNewSusps
826 ;
827 ( compound(Other) ->
828 term_variables(Other,OtherVars),
829 attach_increment(OtherVars, SortedSusps)
830 ;
831 true
832 ),
833 WakeSusps
834 )
835 ),
836 Clause = (Head :- Body).
838 generate_attr_unify_hook_many(N,Clause) :-
839 make_attr(N,Mask,SuspsList,Attr),
840 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
841 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
842 list2conj(SortGoalList,SortGoals),
843 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
844 bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
845 C = (sort(E,F),
846 'chr merge_attributes'(D,F,G)) ),
847 SortMergeGoalList),
848 bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
849 list2conj(SortMergeGoalList,SortMergeGoals),
850 make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
851 make_attr(N,Mask,SortedSuspsList,SortedAttr),
852 Head = Mod:attr_unify_hook(Attr,Other),
853 get_target_module(Mod),
854 make_run_suspensions_loop(MergedSuspsList,WakeMergedSusps),
855 make_run_suspensions_loop(SortedSuspsList,WakeSortedSusps),
856 Body =
857 (
858 SortGoals,
859 ( var(Other) ->
860 ( get_attr(Other,Mod,TOtherAttr) ->
861 TOtherAttr = OtherAttr,
862 SortMergeGoals,
863 MergedMask is Mask \/ OtherMask,
864 put_attr(Other,Mod,MergedAttr),
865 WakeMergedSusps
866 ;
867 put_attr(Other,Mod,SortedAttr),
868 WakeSortedSusps
869 )
870 ;
871 ( compound(Other) ->
872 term_variables(Other,OtherVars),
873 attach_increment(OtherVars,SortedAttr)
874 ;
875 true
876 ),
877 WakeSortedSusps
878 )
879 ),
880 Clause = (Head :- Body).
882 make_run_suspensions(Susps,Goal) :-
883 ( chr_pp_flag(debugable,on) ->
884 Goal = 'chr run_suspensions_d'(Susps)
885 ;
886 Goal = 'chr run_suspensions'(Susps)
887 ).
889 make_run_suspensions_loop(SuspsList,Goal) :-
890 ( chr_pp_flag(debugable,on) ->
891 Goal = 'chr run_suspensions_loop_d'(SuspsList)
892 ;
893 Goal = 'chr run_suspensions_loop'(SuspsList)
894 ).
896 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
898 check_attachments(Rules) :-
899 ( chr_pp_flag(check_attachments,on) ->
900 check_attachments_(Rules)
901 ;
902 true
903 ).
905 check_attachments_([]).
906 check_attachments_([R|Rs]) :-
907 check_attachment(R),
908 check_attachments_(Rs).
910 check_attachment(R) :-
911 R = pragma(Rule,_,_,_),
912 Rule = rule(H1,H2,G,B),
913 check_attachment_heads1(H1,H1,H2,G),
914 check_attachment_heads2(H2,H1,B).
916 check_attachment_heads1([],_,_,_).
917 check_attachment_heads1([C|Cs],H1,H2,G) :-
918 functor(C,F,A),
919 ( H1 == [C],
920 H2 == [],
921 G == true,
922 C =.. [_|L],
923 no_matching(L,[]) ->
924 attached(F/A,no)
925 ;
926 attached(F/A,maybe)
927 ),
928 check_attachment_heads1(Cs,H1,H2,G).
930 no_matching([],_).
931 no_matching([X|Xs],Prev) :-
932 var(X),
933 \+ memberchk_eq(X,Prev),
934 no_matching(Xs,[X|Prev]).
936 check_attachment_heads2([],_,_).
937 check_attachment_heads2([C|Cs],H1,B) :-
938 functor(C,F,A),
939 ( H1 \== [],
940 B == true ->
941 attached(F/A,maybe)
942 ;
943 attached(F/A,yes)
944 ),
945 check_attachment_heads2(Cs,H1,B).
947 all_attached([]).
948 all_attached([C|Cs]) :-
949 functor(C,F,A),
950 is_attached(F/A),
951 all_attached(Cs).
953 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
955 set_constraint_indices([],M) :-
956 N is M - 1,
957 max_constraint_index(N).
958 set_constraint_indices([C|Cs],N) :-
959 ( is_attached(C) ->
960 constraint_index(C,N),
961 M is N + 1,
962 set_constraint_indices(Cs,M)
963 ;
964 set_constraint_indices(Cs,N)
965 ).
967 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
968 %% ____ _ ____ _ _ _ _
969 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
970 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
971 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
972 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
973 %% |_|
975 constraints_code(Constraints,Rules,Clauses) :-
976 post_constraints(Constraints,1),
977 constraints_code1(1,Rules,L,[]),
978 clean_clauses(L,Clauses).
980 %% Add global data
981 post_constraints([],MaxIndex1) :-
982 MaxIndex is MaxIndex1 - 1,
983 constraint_count(MaxIndex).
984 post_constraints([F/A|Cs],N) :-
985 constraint(F/A,N),
986 M is N + 1,
987 post_constraints(Cs,M).
988 constraints_code1(I,Rules,L,T) :-
989 constraint_count(N),
990 ( I > N ->
991 T = L
992 ;
993 constraint_code(I,Rules,L,T1),
994 J is I + 1,
995 constraints_code1(J,Rules,T1,T)
996 ).
998 %% Generate code for a single CHR constraint
999 constraint_code(I, Rules, L, T) :-
1000 constraint(Constraint,I),
1001 constraint_prelude(Constraint,Clause),
1002 L = [Clause | L1],
1003 Id1 = [0],
1004 rules_code(Rules,1,I,Id1,Id2,L1,L2),
1005 gen_cond_attach_clause(Constraint,Id2,L2,T).
1007 %% Generate prelude predicate for a constraint.
1008 %% f(...) :- f/a_0(...,Susp).
1009 constraint_prelude(F/A, Clause) :-
1010 vars_susp(A,Vars,Susp,VarsSusp),
1011 Head =.. [ F | Vars],
1012 build_head(F,A,[0],VarsSusp,Delegate),
1013 get_target_module(Mod),
1014 ( chr_pp_flag(debugable,on) ->
1015 Clause =
1016 ( Head :-
1017 'chr allocate_constraint'(Mod : Delegate, Susp, F, Vars),
1018 (
1019 'chr debug_event'(call(Susp)),
1020 Delegate
1021 ;
1022 'chr debug_event'(fail(Susp)), !,
1023 fail
1024 ),
1025 (
1026 'chr debug_event'(exit(Susp))
1027 ;
1028 'chr debug_event'(redo(Susp)),
1029 fail
1030 )
1031 )
1032 ;
1033 Clause = ( Head :- Delegate )
1034 ).
1036 gen_cond_attach_clause(F/A,Id,L,T) :-
1037 ( is_attached(F/A) ->
1038 ( Id == [0] ->
1039 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
1040 ; vars_susp(A,Args,Susp,AllArgs),
1041 gen_uncond_attach_goal(F/A,Susp,Body,_)
1042 ),
1043 ( chr_pp_flag(debugable,on) ->
1044 Constraint =.. [F|Args],
1045 DebugEvent = 'chr debug_event'(insert(Constraint#Susp))
1046 ;
1047 DebugEvent = true
1048 ),
1049 build_head(F,A,Id,AllArgs,Head),
1050 Clause = ( Head :- DebugEvent,Body ),
1051 L = [Clause | T]
1052 ;
1053 L = T
1054 ).
1056 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
1057 vars_susp(A,Args,Susp,AllArgs),
1058 build_head(F,A,[0],AllArgs,Closure),
1059 atom_concat_list(['attach_',F, (/) ,A],AttachF),
1060 Attach =.. [AttachF,Vars,Susp],
1061 get_target_module(Mod),
1062 Goal =
1063 (
1064 ( var(Susp) ->
1065 'chr insert_constraint_internal'(Vars,Susp,Mod:Closure,F,Args)
1066 ;
1067 'chr activate_constraint'(Vars,Susp,_)
1068 ),
1069 Attach
1070 ).
1072 gen_uncond_attach_goal(F/A,Susp,AttachGoal,Generation) :-
1073 atom_concat_list(['attach_',F, (/) ,A],AttachF),
1074 Attach =.. [AttachF,Vars,Susp],
1075 AttachGoal =
1076 (
1077 'chr activate_constraint'(Vars, Susp, Generation),
1078 Attach
1079 ).
1081 %% Generate all the code for a constraint based on all CHR rules
1082 rules_code([],_,_,Id,Id,L,L).
1083 rules_code([R |Rs],RuleNb,I,Id1,Id3,L,T) :-
1084 rule_code(R,RuleNb,I,Id1,Id2,L,T1),
1085 NextRuleNb is RuleNb + 1,
1086 rules_code(Rs,NextRuleNb,I,Id2,Id3,T1,T).
1088 %% Generate code for a constraint based on a single CHR rule
1089 rule_code(PragmaRule,RuleNb,I,Id1,Id2,L,T) :-
1090 PragmaRule = pragma(Rule,HeadIDs,_Pragmas,_Name),
1091 HeadIDs = ids(Head1IDs,Head2IDs),
1092 Rule = rule(Head1,Head2,_,_),
1093 heads1_code(Head1,[],Head1IDs,[],PragmaRule,I,Id1,L,L1),
1094 heads2_code(Head2,[],Head2IDs,[],PragmaRule,RuleNb,I,Id1,Id2,L1,T).
1096 %% Generate code based on all the removed heads of a CHR rule
1097 heads1_code([],_,_,_,_,_,_,L,L).
1098 heads1_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id,L,T) :-
1099 PragmaRule = pragma(Rule,_,Pragmas,_Name),
1100 constraint(F/A,I),
1101 ( functor(Head,F,A),
1102 \+ check_unnecessary_active(Head,RestHeads,Rule),
1103 \+ memberchk_eq(passive(HeadID),Pragmas),
1104 all_attached(Heads),
1105 all_attached(RestHeads),
1106 Rule = rule(_,Heads2,_,_),
1107 all_attached(Heads2) ->
1108 append(Heads,RestHeads,OtherHeads),
1109 append(HeadIDs,RestIDs,OtherIDs),
1110 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,F/A,I,Id,L,L1)
1111 ;
1112 L = L1
1113 ),
1114 heads1_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id,L1,T).
1116 %% Generate code based on one removed head of a CHR rule
1117 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,Id,L,T) :-
1118 PragmaRule = pragma(Rule,_,_,_Name),
1119 Rule = rule(_,Head2,_,_),
1120 ( Head2 == [] ->
1121 reorder_heads(Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
1122 simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,Id,L,T)
1123 ;
1124 simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
1125 ).
1127 %% Generate code based on all the persistent heads of a CHR rule
1128 heads2_code([],_,_,_,_,_,_,Id,Id,L,L).
1129 heads2_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,RuleNb,I,Id1,Id3,L,T) :-
1130 PragmaRule = pragma(Rule,_,Pragmas,_Name),
1131 constraint(F/A,I),
1132 ( functor(Head,F,A),
1133 \+ check_unnecessary_active(Head,RestHeads,Rule),
1134 \+ memberchk_eq(passive(HeadID),Pragmas),
1135 \+ set_semantics_rule(PragmaRule),
1136 all_attached(Heads),
1137 all_attached(RestHeads),
1138 Rule = rule(Heads1,_,_,_),
1139 all_attached(Heads1) ->
1140 append(Heads,RestHeads,OtherHeads),
1141 append(HeadIDs,RestIDs,OtherIDs),
1142 length(Heads,RestHeadNb),
1143 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RuleNb,RestHeadNb,F/A,Id1,L,L0),
1144 inc_id(Id1,Id2),
1145 gen_alloc_inc_clause(F/A,Id1,L0,L1)
1146 ;
1147 L = L1,
1148 Id2 = Id1
1149 ),
1150 heads2_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,RuleNb,I,Id2,Id3,L1,T).
1152 %% Generate code based on one persistent head of a CHR rule
1153 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RuleNb,RestHeadNb,FA,Id,L,T) :-
1154 PragmaRule = pragma(Rule,_,_,_Name),
1155 Rule = rule(Head1,_,_,_),
1156 ( Head1 == [] ->
1157 reorder_heads(Head,OtherHeads,NOtherHeads),
1158 propagation_code(Head,NOtherHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
1159 ;
1160 simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
1161 ).
1163 gen_alloc_inc_clause(F/A,Id,L,T) :-
1164 vars_susp(A,Vars,Susp,VarsSusp),
1165 build_head(F,A,Id,VarsSusp,Head),
1166 inc_id(Id,IncId),
1167 build_head(F,A,IncId,VarsSusp,CallHead),
1168 ( Id == [0] ->
1169 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,ConditionalAlloc)
1170 ;
1171 ConditionalAlloc = true
1172 ),
1173 Clause =
1174 (
1175 Head :-
1176 ConditionalAlloc,
1177 CallHead
1178 ),
1179 L = [Clause|T].
1181 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal) :-
1182 build_head(F,A,[0],VarsSusp,Term),
1183 get_target_module(Mod),
1184 ConstraintAllocationGoal =
1185 ( var(Susp) ->
1186 'chr allocate_constraint'(Mod : Term, Susp, F, Vars)
1187 ;
1188 true
1189 ).
1191 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1194 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1196 guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :-
1197 ( chr_pp_flag(guard_via_reschedule,on) ->
1198 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal)
1199 ;
1200 append(Retrievals,GuardList,GoalList),
1201 list2conj(GoalList,Goal)
1202 ).
1204 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :-
1205 initialize_unit_dictionary(Prelude,Dict),
1206 build_units(Retrievals,GuardList,Dict,Units),
1207 dependency_reorder(Units,NUnits),
1208 units2goal(NUnits,Goal).
1210 units2goal([],true).
1211 units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :-
1212 units2goal(Units,Goals).
1214 dependency_reorder(Units,NUnits) :-
1215 dependency_reorder(Units,[],NUnits).
1217 dependency_reorder([],Acc,Result) :-
1218 reverse(Acc,Result).
1220 dependency_reorder([Unit|Units],Acc,Result) :-
1221 Unit = unit(_GID,_Goal,Type,GIDs),
1222 ( Type == fixed ->
1223 NAcc = [Unit|Acc]
1224 ;
1225 dependency_insert(Acc,Unit,GIDs,NAcc)
1226 ),
1227 dependency_reorder(Units,NAcc,Result).
1229 dependency_insert([],Unit,_,[Unit]).
1230 dependency_insert([X|Xs],Unit,GIDs,L) :-
1231 X = unit(GID,_,_,_),
1232 ( memberchk(GID,GIDs) ->
1233 L = [Unit,X|Xs]
1234 ;
1235 L = [X | T],
1236 dependency_insert(Xs,Unit,GIDs,T)
1237 ).
1239 build_units(Retrievals,Guard,InitialDict,Units) :-
1240 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
1241 build_guard_units(Guard,N,Dict,Tail).
1243 build_retrieval_units([],N,N,Dict,Dict,L,L).
1244 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
1245 term_variables(U,Vs),
1246 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
1247 L = [unit(N,U,movable,GIDs)|L1],
1248 N1 is N + 1,
1249 build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T).
1251 build_retrieval_units2([],N,N,Dict,Dict,L,L).
1252 build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :-
1253 term_variables(U,Vs),
1254 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
1255 L = [unit(N,U,fixed,GIDs)|L1],
1256 N1 is N + 1,
1257 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
1259 initialize_unit_dictionary(Term,Dict) :-
1260 term_variables(Term,Vars),
1261 pair_all_with(Vars,0,Dict).
1263 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
1264 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
1265 ( lookup_eq(Dict,V,GID) ->
1266 ( (GID == This ; memberchk(GID,GIDs) ) ->
1267 GIDs1 = GIDs
1268 ;
1269 GIDs1 = [GID|GIDs]
1270 ),
1271 Dict1 = Dict
1272 ;
1273 Dict1 = [V - This|Dict],
1274 GIDs1 = GIDs
1275 ),
1276 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
1278 build_guard_units(Guard,N,Dict,Units) :-
1279 ( Guard = [Goal] ->
1280 Units = [unit(N,Goal,fixed,[])]
1281 ; Guard = [Goal|Goals] ->
1282 term_variables(Goal,Vs),
1283 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
1284 Units = [unit(N,Goal,movable,GIDs)|RUnits],
1285 N1 is N + 1,
1286 build_guard_units(Goals,N1,NDict,RUnits)
1287 ).
1289 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
1290 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
1291 ( lookup_eq(Dict,V,GID) ->
1292 ( (GID == This ; memberchk(GID,GIDs) ) ->
1293 GIDs1 = GIDs
1294 ;
1295 GIDs1 = [GID|GIDs]
1296 ),
1297 Dict1 = [V - This|Dict]
1298 ;
1299 Dict1 = [V - This|Dict],
1300 GIDs1 = GIDs
1301 ),
1302 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
1304 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1306 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1307 %% ____ _ ____ _ _
1308 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
1309 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
1310 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
1311 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
1312 %%
1313 %% _ _ _ ___ __
1314 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
1315 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
1316 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
1317 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
1318 %% |_|
1319 unique_analyse_optimise(Rules,NRules) :-
1320 ( chr_pp_flag(unique_analyse_optimise,on) ->
1321 unique_analyse_optimise_main(Rules,1,[],NRules)
1322 ;
1323 NRules = Rules
1324 ).
1326 unique_analyse_optimise_main([],_,_,[]).
1327 unique_analyse_optimise_main([PRule|PRules],N,PatternList,[NPRule|NPRules]) :-
1328 ( discover_unique_pattern(PRule,N,Pattern) ->
1329 NPatternList = [Pattern|PatternList]
1330 ;
1331 NPatternList = PatternList
1332 ),
1333 PRule = pragma(Rule,Ids,Pragmas,Name),
1334 Rule = rule(H1,H2,_,_),
1335 Ids = ids(Ids1,Ids2),
1336 apply_unique_patterns_to_constraints(H1,Ids1,NPatternList,MorePragmas1),
1337 apply_unique_patterns_to_constraints(H2,Ids2,NPatternList,MorePragmas2),
1338 append_lists([MorePragmas1,MorePragmas2,Pragmas],NPragmas),
1339 NPRule = pragma(Rule,Ids,NPragmas,Name),
1340 N1 is N + 1,
1341 unique_analyse_optimise_main(PRules,N1,NPatternList,NPRules).
1343 apply_unique_patterns_to_constraints([],_,_,[]).
1344 apply_unique_patterns_to_constraints([C|Cs],[Id|Ids],Patterns,Pragmas) :-
1345 ( member(Pattern,Patterns),
1346 apply_unique_pattern(C,Id,Pattern,Pragma) ->
1347 Pragmas = [Pragma | RPragmas]
1348 ;
1349 Pragmas = RPragmas
1350 ),
1351 apply_unique_patterns_to_constraints(Cs,Ids,Patterns,RPragmas).
1353 apply_unique_pattern(Constraint,Id,Pattern,Pragma) :-
1354 Pattern = unique(PatternConstraint,PatternKey),
1355 subsumes(Constraint,PatternConstraint,Unifier),
1356 ( setof( V,
1357 T^Term^Vs^(
1358 member(T,PatternKey),
1359 lookup_eq(Unifier,T,Term),
1360 term_variables(Term,Vs),
1361 member(V,Vs)
1362 ),
1363 Vars) ->
1364 true
1365 ;
1366 Vars = []
1367 ),
1368 Pragma = unique(Id,Vars).
1370 % subsumes(+Term1, +Term2, -Unifier)
1371 %
1372 % If Term1 is a more general term than Term2 (e.g. has a larger
1373 % part instantiated), unify Unifier with a list Var-Value of
1374 % variables from Term2 and their corresponding values in Term1.
1376 subsumes(Term1,Term2,Unifier) :-
1377 empty_assoc(S0),
1378 subsumes_aux(Term1,Term2,S0,S),
1379 assoc_to_list(S,L),
1380 build_unifier(L,Unifier).
1382 subsumes_aux(Term1, Term2, S0, S) :-
1383 ( compound(Term2),
1384 functor(Term2, F, N)
1385 -> compound(Term1), functor(Term1, F, N),
1386 subsumes_aux(N, Term1, Term2, S0, S)
1387 ; Term1 == Term2
1388 -> S = S0
1389 ; var(Term2),
1390 get_assoc(Term1,S0,V)
1391 -> V == Term2, S = S0
1392 ; var(Term2),
1393 put_assoc(Term1, S0, Term2, S)
1394 ).
1396 subsumes_aux(0, _, _, S, S) :- ! .
1397 subsumes_aux(N, T1, T2, S0, S) :-
1398 arg(N, T1, T1x),
1399 arg(N, T2, T2x),
1400 subsumes_aux(T1x, T2x, S0, S1),
1401 M is N-1,
1402 subsumes_aux(M, T1, T2, S1, S).
1404 build_unifier([],[]).
1405 build_unifier([X-V|R],[V - X | T]) :-
1406 build_unifier(R,T).
1408 discover_unique_pattern(PragmaRule,RuleNb,Pattern) :-
1409 PragmaRule = pragma(Rule,_,Pragmas,Name),
1410 ( Rule = rule([C1],[C2],Guard,Body) ->
1411 true
1412 ;
1413 Rule = rule([C1,C2],[],Guard,Body)
1414 ),
1415 check_unique_constraints(C1,C2,Guard,Body,Pragmas,List),
1416 term_variables(C1,Vs),
1417 select_pragma_unique_variables(List,Vs,Key),
1418 Pattern0 = unique(C1,Key),
1419 copy_term(Pattern0,Pattern),
1420 ( prolog_flag(verbose,V), V == yes ->
1421 format('Found unique pattern ~w in rule ~d~@\n',
1422 [Pattern,RuleNb,(Name=yes(N) -> write(": "),write(N) ; true)])
1423 ;
1424 true
1425 ).
1427 select_pragma_unique_variables([],_,[]).
1428 select_pragma_unique_variables([X-Y|R],Vs,L) :-
1429 ( X == Y ->
1430 L = [X|T]
1431 ;
1432 once((
1433 \+ memberchk_eq(X,Vs)
1434 ;
1435 \+ memberchk_eq(Y,Vs)
1436 )),
1437 L = T
1438 ),
1439 select_pragma_unique_variables(R,Vs,T).
1441 check_unique_constraints(C1,C2,G,_Body,Pragmas,List) :-
1442 \+ member(passive(_),Pragmas),
1443 variable_replacement(C1-C2,C2-C1,List),
1444 copy_with_variable_replacement(G,OtherG,List),
1445 negate(G,NotG),
1446 once(entails(NotG,OtherG)).
1448 negate(true,fail).
1449 negate(fail,true).
1450 negate(X =< Y, Y < X).
1451 negate(X > Y, Y >= X).
1452 negate(X >= Y, Y > X).
1453 negate(X < Y, Y =< X).
1454 negate(var(X),nonvar(X)).
1455 negate(nonvar(X),var(X)).
1457 entails(X,X1) :- X1 == X.
1458 entails(fail,_).
1459 entails(X > Y, X1 >= Y1) :- X1 == X, Y1 == Y.
1460 entails(X < Y, X1 =< Y1) :- X1 == X, Y1 == Y.
1461 entails(ground(X),nonvar(X1)) :- X1 == X.
1462 entails(compound(X),nonvar(X1)) :- X1 == X.
1463 entails(atomic(X),nonvar(X1)) :- X1 == X.
1464 entails(number(X),nonvar(X1)) :- X1 == X.
1465 entails(atom(X),nonvar(X1)) :- X1 == X.
1467 check_unnecessary_active(Constraint,Previous,Rule) :-
1468 ( chr_pp_flag(check_unnecessary_active,full) ->
1469 check_unnecessary_active_main(Constraint,Previous,Rule)
1470 ; chr_pp_flag(check_unnecessary_active,simplification),
1471 Rule = rule(_,[],_,_) ->
1472 check_unnecessary_active_main(Constraint,Previous,Rule)
1473 ;
1474 fail
1475 ).
1477 check_unnecessary_active_main(Constraint,Previous,Rule) :-
1478 member(Other,Previous),
1479 variable_replacement(Other,Constraint,List),
1480 copy_with_variable_replacement(Rule,Rule2,List),
1481 identical_rules(Rule,Rule2), ! .
1483 set_semantics_rule(PragmaRule) :-
1484 ( chr_pp_flag(set_semantics_rule,on) ->
1485 set_semantics_rule_main(PragmaRule)
1486 ;
1487 fail
1488 ).
1490 set_semantics_rule_main(PragmaRule) :-
1491 PragmaRule = pragma(Rule,IDs,Pragmas,_),
1492 Rule = rule([C1],[C2],true,_),
1493 IDs = ids([ID1],[ID2]),
1494 once(member(unique(ID1,L1),Pragmas)),
1495 once(member(unique(ID2,L2),Pragmas)),
1496 L1 == L2,
1497 \+ memberchk_eq(passive(ID1),Pragmas).
1498 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1500 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1501 %% ____ _ _____ _ _
1502 %% | _ \ _ _| | ___ | ____|__ _ _ _(_)_ ____ _| | ___ _ __ ___ ___
1503 %% | |_) | | | | |/ _ \ | _| / _` | | | | \ \ / / _` | |/ _ \ '_ \ / __/ _ \
1504 %% | _ <| |_| | | __/ | |__| (_| | |_| | |\ V / (_| | | __/ | | | (_| __/
1505 %% |_| \_\\__,_|_|\___| |_____\__, |\__,_|_| \_/ \__,_|_|\___|_| |_|\___\___|
1506 %% |_|
1507 % have to check for no duplicates in value list
1509 % check wether two rules are identical
1511 identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :-
1512 G1 == G2,
1513 identical_bodies(B1,B2),
1514 permutation(H11,P1),
1515 P1 == H12,
1516 permutation(H21,P2),
1517 P2 == H22.
1519 identical_bodies(B1,B2) :-
1520 ( B1 = (X1 = Y1),
1521 B2 = (X2 = Y2) ->
1522 ( X1 == X2,
1523 Y1 == Y2
1524 ; X1 == Y2,
1525 X2 == Y1
1526 ),
1527 !
1528 ; B1 == B2
1529 ).
1531 % replace variables in list
1533 copy_with_variable_replacement(X,Y,L) :-
1534 ( var(X) ->
1535 ( lookup_eq(L,X,Y) ->
1536 true
1537 ; X = Y
1538 )
1539 ; functor(X,F,A),
1540 functor(Y,F,A),
1541 X =.. [_|XArgs],
1542 Y =.. [_|YArgs],
1543 copy_with_variable_replacement_l(XArgs,YArgs,L)
1544 ).
1546 copy_with_variable_replacement_l([],[],_).
1547 copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :-
1548 copy_with_variable_replacement(X,Y,L),
1549 copy_with_variable_replacement_l(Xs,Ys,L).
1551 %% build variable replacement list
1553 variable_replacement(X,Y,L) :-
1554 variable_replacement(X,Y,[],L).
1556 variable_replacement(X,Y,L1,L2) :-
1557 ( var(X) ->
1558 var(Y),
1559 ( lookup_eq(L1,X,Z) ->
1560 Z == Y,
1561 L2 = L1
1562 ; L2 = [X-Y|L1]
1563 )
1564 ; X =.. [F|XArgs],
1565 nonvar(Y),
1566 Y =.. [F|YArgs],
1567 variable_replacement_l(XArgs,YArgs,L1,L2)
1568 ).
1570 variable_replacement_l([],[],L,L).
1571 variable_replacement_l([X|Xs],[Y|Ys],L1,L3) :-
1572 variable_replacement(X,Y,L1,L2),
1573 variable_replacement_l(Xs,Ys,L2,L3).
1574 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1576 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1577 %% ____ _ _ _ __ _ _ _
1578 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
1579 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
1580 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
1581 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
1582 %% |_|
1584 simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,Id,L,T) :-
1585 PragmaRule = pragma(Rule,_,Pragmas,_),
1586 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
1587 build_head(F,A,Id,HeadVars,ClauseHead),
1588 head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
1590 ( RestHeads == [] ->
1591 Susps = [],
1592 VarDict = VarDict1,
1593 GetRestHeads = []
1594 ;
1595 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict)
1596 ),
1598 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
1599 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
1601 gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
1602 gen_cond_susp_detachment(Susp,F/A,SuspDetachment),
1604 ( chr_pp_flag(debugable,on) ->
1605 Rule = rule(_,_,Guard,Body),
1606 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
1607 DebugTry = 'chr debug_event'( try([Susp|RestSusps],[],DebugGuard,DebugBody)),
1608 DebugApply = 'chr debug_event'(apply([Susp|RestSusps],[],DebugGuard,DebugBody))
1609 ;
1610 DebugTry = true,
1611 DebugApply = true
1612 ),
1614 Clause = ( ClauseHead :-
1615 FirstMatching,
1616 RescheduledTest,
1617 DebugTry,
1618 !,
1619 DebugApply,
1620 SuspsDetachments,
1621 SuspDetachment,
1622 BodyCopy
1623 ),
1624 L = [Clause | T].
1626 head_arg_matches(Pairs,VarDict,Goal,NVarDict) :-
1627 head_arg_matches_(Pairs,VarDict,GoalList,NVarDict),
1628 list2conj(GoalList,Goal).
1630 head_arg_matches_([],VarDict,[],VarDict).
1631 head_arg_matches_([Arg-Var| Rest],VarDict,GoalList,NVarDict) :-
1632 ( var(Arg) ->
1633 ( lookup_eq(VarDict,Arg,OtherVar) ->
1634 GoalList = [Var == OtherVar | RestGoalList],
1635 VarDict1 = VarDict
1636 ; VarDict1 = [Arg-Var | VarDict],
1637 GoalList = RestGoalList
1638 ),
1639 Pairs = Rest
1640 ; atomic(Arg) ->
1641 GoalList = [ Var == Arg | RestGoalList],
1642 VarDict = VarDict1,
1643 Pairs = Rest
1644 ; Arg =.. [_|Args],
1645 functor(Arg,Fct,N),
1646 functor(Term,Fct,N),
1647 Term =.. [_|Vars],
1648 GoalList =[ nonvar(Var), Var = Term | RestGoalList ],
1649 pairup(Args,Vars,NewPairs),
1650 append(NewPairs,Rest,Pairs),
1651 VarDict1 = VarDict
1652 ),
1653 head_arg_matches_(Pairs,VarDict1,RestGoalList,NVarDict).
1655 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict):-
1656 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,[],[],[]).
1658 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict,PrevHs,PrevSusps,AttrDict) :-
1659 ( Heads = [_|_] ->
1660 rest_heads_retrieval_and_matching_n(Heads,IDs,Pragmas,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict)
1661 ;
1662 GoalList = [],
1663 Susps = [],
1664 VarDict = NVarDict
1665 ).
1667 rest_heads_retrieval_and_matching_n([],_,_,_,_,_,[],[],VarDict,VarDict,AttrDict) :-
1668 instantiate_pattern_goals(AttrDict).
1669 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,ActiveHead,[ViaGoal,Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict) :-
1670 passive_head_via(H,[ActiveHead|PrevHs],AttrDict,VarDict,ViaGoal,Attr,NewAttrDict),
1671 functor(H,Fct,Aty),
1672 head_info(H,Aty,Vars,_,_,Pairs),
1673 head_arg_matches(Pairs,VarDict,MatchingGoal,VarDict1),
1674 Suspension =.. [suspension,_,State,_,_,_,_|Vars],
1675 get_max_constraint_index(N),
1676 ( N == 1 ->
1677 VarSusps = Attr
1678 ;
1679 get_constraint_index(Fct/Aty,Pos),
1680 make_attr(N,_Mask,SuspsList,Attr),
1681 nth(Pos,SuspsList,VarSusps)
1682 ),
1683 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
1684 create_get_mutable(active,State,GetMutable),
1685 Goal1 =
1686 (
1687 'chr sbag_member'(Susp,VarSusps),
1688 Susp = Suspension,
1689 GetMutable,
1690 DiffSuspGoals,
1691 MatchingGoal
1692 ),
1693 ( member(unique(ID,UniqueKeus),Pragmas),
1694 check_unique_keys(UniqueKeus,VarDict) ->
1695 Goal = (Goal1 -> true)
1696 ;
1697 Goal = Goal1
1698 ),
1699 rest_heads_retrieval_and_matching_n(Hs,IDs,Pragmas,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,NewAttrDict).
1701 instantiate_pattern_goals([]).
1702 instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest]) :-
1703 get_max_constraint_index(N),
1704 ( N == 1 ->
1705 Goal = true
1706 ;
1707 make_attr(N,Mask,_,Attr),
1708 or_list(Bits,Pattern), !,
1709 Goal = (Mask /\ Pattern =:= Pattern)
1710 ),
1711 instantiate_pattern_goals(Rest).
1714 check_unique_keys([],_).
1715 check_unique_keys([V|Vs],Dict) :-
1716 lookup_eq(Dict,V,_),
1717 check_unique_keys(Vs,Dict).
1719 % Generates tests to ensure the found constraint differs from previously found constraints
1720 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
1721 ( bagof(DiffSuspGoal, Pos ^ ( nth(Pos,Heads,PreHead), \+ Head \= PreHead, nth(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
1722 list2conj(DiffSuspGoalList,DiffSuspGoals)
1723 ;
1724 DiffSuspGoals = true
1725 ).
1727 passive_head_via(Head,PrevHeads,AttrDict,VarDict,Goal,Attr,NewAttrDict) :-
1728 functor(Head,F,A),
1729 get_constraint_index(F/A,Pos),
1730 common_variables(Head,PrevHeads,CommonVars),
1731 translate(CommonVars,VarDict,Vars),
1732 or_pattern(Pos,Bit),
1733 ( permutation(Vars,PermutedVars),
1734 lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) ->
1735 member(Bit,Positions), !,
1736 NewAttrDict = AttrDict,
1737 Goal = true
1738 ;
1739 Goal = (Goal1, PatternGoal),
1740 gen_get_mod_constraints(Vars,Goal1,Attr),
1741 NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict]
1742 ).
1744 common_variables(T,Ts,Vs) :-
1745 term_variables(T,V1),
1746 term_variables(Ts,V2),
1747 intersect_eq(V1,V2,Vs).
1749 gen_get_mod_constraints(L,Goal,Susps) :-
1750 get_target_module(Mod),
1751 ( L == [] ->
1752 Goal =
1753 ( 'chr global_term_ref_1'(Global),
1754 get_attr(Global,Mod,TSusps),
1755 TSusps = Susps
1756 )
1757 ;
1758 ( L = [A] ->
1759 VIA = 'chr via_1'(A,V)
1760 ; ( L = [A,B] ->
1761 VIA = 'chr via_2'(A,B,V)
1762 ; VIA = 'chr via'(L,V)
1763 )
1764 ),
1765 Goal =
1766 ( VIA,
1767 get_attr(V,Mod,TSusps),
1768 TSusps = Susps
1769 )
1770 ).
1772 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
1773 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
1774 list2conj(GuardCopyList,GuardCopy).
1776 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
1777 Rule = rule(_,_,Guard,Body),
1778 conj2list(Guard,GuardList),
1779 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
1780 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
1782 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
1783 term_variables(RestGuardList,GuardVars),
1784 term_variables(RestGuardListCopyCore,GuardCopyVars),
1785 ( chr_pp_flag(guard_locks,on),
1786 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
1787 X ^ (member(X,GuardVars), % X is a variable appearing in the original guard
1788 lookup_eq(VarDict,X,Y), % translate X into new variable
1789 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
1790 ),
1791 LocksUnlocks) ->
1792 once(pairup(Locks,Unlocks,LocksUnlocks))
1793 ;
1794 Locks = [],
1795 Unlocks = []
1796 ),
1797 list2conj(Locks,LockPhase),
1798 list2conj(Unlocks,UnlockPhase),
1799 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
1800 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
1801 my_term_copy(Body,VarDict2,BodyCopy).
1804 split_off_simple_guard([],_,[],[]).
1805 split_off_simple_guard([G|Gs],VarDict,S,C) :-
1806 ( simple_guard(G,VarDict) ->
1807 S = [G|Ss],
1808 split_off_simple_guard(Gs,VarDict,Ss,C)
1809 ;
1810 S = [],
1811 C = [G|Gs]
1812 ).
1814 % simple guard: cheap and benign (does not bind variables)
1816 simple_guard(var(_), _).
1817 simple_guard(nonvar(_), _).
1818 simple_guard(ground(_), _).
1819 simple_guard(number(_), _).
1820 simple_guard(atom(_), _).
1821 simple_guard(integer(_), _).
1822 simple_guard(float(_), _).
1824 simple_guard(_ > _ , _).
1825 simple_guard(_ < _ , _).
1826 simple_guard(_ =< _, _).
1827 simple_guard(_ >= _, _).
1828 simple_guard(_ =:= _, _).
1829 simple_guard(_ == _, _).
1831 simple_guard(X is _, VarDict) :-
1832 \+ lookup_eq(VarDict,X,_).
1834 simple_guard((G1,G2),VarDict) :-
1835 simple_guard(G1,VarDict),
1836 simple_guard(G2,VarDict).
1838 simple_guard(\+ G, VarDict) :-
1839 simple_guard(G, VarDict).
1841 my_term_copy(X,Dict,Y) :-
1842 my_term_copy(X,Dict,_,Y).
1844 my_term_copy(X,Dict1,Dict2,Y) :-
1845 ( var(X) ->
1846 ( lookup_eq(Dict1,X,Y) ->
1847 Dict2 = Dict1
1848 ; Dict2 = [X-Y|Dict1]
1849 )
1850 ; functor(X,XF,XA),
1851 functor(Y,XF,XA),
1852 X =.. [_|XArgs],
1853 Y =.. [_|YArgs],
1854 my_term_copy_list(XArgs,Dict1,Dict2,YArgs)
1855 ).
1857 my_term_copy_list([],Dict,Dict,[]).
1858 my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :-
1859 my_term_copy(X,Dict1,Dict2,Y),
1860 my_term_copy_list(Xs,Dict2,Dict3,Ys).
1862 gen_cond_susp_detachment(Susp,FA,SuspDetachment) :-
1863 ( is_attached(FA) ->
1864 gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
1865 SuspDetachment =
1866 ( var(Susp) ->
1867 true
1868 ; UnCondSuspDetachment
1869 )
1870 ;
1871 SuspDetachment = true
1872 ).
1874 gen_uncond_susp_detachment(Susp,CFct/CAty,SuspDetachment) :-
1875 ( is_attached(CFct/CAty) ->
1876 atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
1877 Detach =.. [Fct,Vars,Susp],
1878 ( chr_pp_flag(debugable,on) ->
1879 DebugEvent = 'chr debug_event'(remove(Susp))
1880 ;
1881 DebugEvent = true
1882 ),
1883 SuspDetachment =
1884 (
1885 DebugEvent,
1886 'chr remove_constraint_internal'(Susp, Vars),
1887 Detach
1888 )
1889 ;
1890 SuspDetachment = true
1891 ).
1893 gen_uncond_susps_detachments([],[],true).
1894 gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
1895 functor(Term,F,A),
1896 gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
1897 gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
1899 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1901 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1902 %% ____ _ _ _ _
1903 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
1904 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
1905 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
1906 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
1907 %% |_| |___/
1909 simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
1910 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name),
1911 Rule = rule(_Heads,Heads2,Guard,Body),
1913 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
1914 head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
1916 build_head(F,A,Id,HeadVars,ClauseHead),
1918 append(RestHeads,Heads2,Heads),
1919 append(OtherIDs,Heads2IDs,IDs),
1920 reorder_heads(Head,Heads,IDs,NHeads,NIDs),
1921 rest_heads_retrieval_and_matching(NHeads,NIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict),
1922 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps2),
1924 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
1925 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
1927 gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments),
1928 gen_cond_susp_detachment(Susp,F/A,SuspDetachment),
1930 ( chr_pp_flag(debugable,on) ->
1931 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
1932 DebugTry = 'chr debug_event'( try([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
1933 DebugApply = 'chr debug_event'(apply([Susp|Susps1],Susps2,DebugGuard,DebugBody))
1934 ;
1935 DebugTry = true,
1936 DebugApply = true
1937 ),
1939 Clause = ( ClauseHead :-
1940 FirstMatching,
1941 RescheduledTest,
1942 DebugTry,
1943 !,
1944 DebugApply,
1945 SuspsDetachments,
1946 SuspDetachment,
1947 BodyCopy
1948 ),
1949 L = [Clause | T].
1951 split_by_ids([],[],_,[],[]).
1952 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
1953 ( memberchk_eq(I,I1s) ->
1954 S1s = [S | R1s],
1955 S2s = R2s
1956 ;
1957 S1s = R1s,
1958 S2s = [S | R2s]
1959 ),
1960 split_by_ids(Is,Ss,I1s,R1s,R2s).
1962 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1965 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1966 %% ____ _ _ _ ____
1967 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
1968 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
1969 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
1970 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
1971 %% |_| |___/
1973 %% Genereate prelude + worker predicate
1974 %% prelude calls worker
1975 %% worker iterates over one type of removed constraints
1976 simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,Id,L,T) :-
1977 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_Name),
1978 Rule = rule(Heads1,_,Guard,Body),
1979 reorder_heads(Head2,Heads1,IDs1,[Head1|RestHeads1],[ID1|RestIDs1]), % Heads1 = [Head1|RestHeads1],
1980 % IDs1 = [ID1|RestIDs1],
1981 simpagation_head2_prelude(Head2,Head1,[RestHeads2,Heads1,Guard,Body],FA,Id,L,L1),
1982 extend_id(Id,Id2),
1983 simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,RestIDs1,RestHeads2,RestIDs,Rule,Pragmas,FA,Id2,L1,T).
1985 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1986 simpagation_head2_prelude(Head,Head1,Rest,F/A,Id1,L,T) :-
1987 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
1988 build_head(F,A,Id1,VarsSusp,ClauseHead),
1989 head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
1991 passive_head_via(Head1,[Head],[],VarDict,ModConstraintsGoal,Attr,AttrDict),
1992 instantiate_pattern_goals(AttrDict),
1993 get_max_constraint_index(N),
1994 ( N == 1 ->
1995 AllSusps = Attr
1996 ;
1997 functor(Head1,F1,A1),
1998 get_constraint_index(F1/A1,Pos),
1999 make_attr(N,_,SuspsList,Attr),
2000 nth(Pos,SuspsList,AllSusps)
2001 ),
2003 ( Id1 == [0] -> % create suspension
2004 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal)
2005 ; ConstraintAllocationGoal = true
2006 ),
2008 extend_id(Id1,DelegateId),
2009 extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
2010 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
2011 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
2013 PreludeClause =
2014 ( ClauseHead :-
2015 FirstMatching,
2016 ModConstraintsGoal,
2017 !,
2018 ConstraintAllocationGoal,
2019 Delegate
2020 ),
2021 L = [PreludeClause|T].
2023 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
2024 Term =.. [_|Args],
2025 delegate_variables(Term,Terms,VarDict,Args,Vars).
2027 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
2028 term_variables(PrevTerms,PrevVars),
2029 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
2031 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
2032 term_variables(Term,V1),
2033 term_variables(Terms,V2),
2034 intersect_eq(V1,V2,V3),
2035 list_difference_eq(V3,PrevVars,V4),
2036 translate(V4,VarDict,Vars).
2039 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2040 simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,FA,Id,L,T) :-
2041 Rule = rule(_,_,Guard,Body),
2042 simpagation_head2_worker_end(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],FA,Id,L,L1),
2043 simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,FA,Id,L1,T).
2045 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2046 simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,F/A,Id,L,T) :-
2047 gen_var(OtherSusp),
2048 gen_var(OtherSusps),
2050 head_info(Head2,A,_Vars,Susp,VarsSusp,Head2Pairs),
2051 head_arg_matches(Head2Pairs,[],_,VarDict1),
2053 Rule = rule(_,_,Guard,Body),
2054 extra_active_delegate_variables(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],VarDict1,ExtraVars),
2055 append([[OtherSusp|OtherSusps]|VarsSusp],ExtraVars,HeadVars),
2056 build_head(F,A,Id,HeadVars,ClauseHead),
2058 functor(Head1,_OtherF,OtherA),
2059 head_info(Head1,OtherA,OtherVars,_,_,Head1Pairs),
2060 head_arg_matches(Head1Pairs,VarDict1,FirstMatching,VarDict2),
2062 OtherSuspension =.. [suspension,_,OtherState,_,_,_,_|OtherVars],
2063 create_get_mutable(active,OtherState,GetMutable),
2064 IteratorSuspTest =
2065 ( OtherSusp = OtherSuspension,
2066 GetMutable
2067 ),
2069 ( (RestHeads1 \== [] ; RestHeads2 \== []) ->
2070 append(RestHeads1,RestHeads2,RestHeads),
2071 append(IDs1,IDs2,IDs),
2072 reorder_heads(Head1-Head2,RestHeads,IDs,NRestHeads,NIDs),
2073 rest_heads_retrieval_and_matching(NRestHeads,NIDs,Pragmas,[Head1,Head2],RestSuspsRetrieval,Susps,VarDict2,VarDict,[Head1],[OtherSusp],[]),
2074 split_by_ids(NIDs,Susps,IDs1,Susps1,Susps2)
2075 ; RestSuspsRetrieval = [],
2076 Susps1 = [],
2077 Susps2 = [],
2078 VarDict = VarDict2
2079 ),
2081 gen_uncond_susps_detachments([OtherSusp | Susps1],[Head1|RestHeads1],Susps1Detachments),
2083 append([OtherSusps|VarsSusp],ExtraVars,RecursiveVars),
2084 build_head(F,A,Id,RecursiveVars,RecursiveCall),
2085 append([[]|VarsSusp],ExtraVars,RecursiveVars2),
2086 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
2088 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2089 guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,IteratorSuspTest,FirstMatching),RescheduledTest),
2090 ( BodyCopy \== true ->
2091 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
2092 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
2093 gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
2094 ; Attachment = true,
2095 ConditionalRecursiveCall = RecursiveCall,
2096 ConditionalRecursiveCall2 = RecursiveCall2
2097 ),
2099 ( chr_pp_flag(debugable,on) ->
2100 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2101 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
2102 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
2103 ;
2104 DebugTry = true,
2105 DebugApply = true
2106 ),
2108 ( member(unique(ID1,UniqueKeys), Pragmas),
2109 check_unique_keys(UniqueKeys,VarDict1) ->
2110 Clause =
2111 ( ClauseHead :-
2112 ( IteratorSuspTest,
2113 FirstMatching ->
2114 ( RescheduledTest,
2115 DebugTry ->
2116 DebugApply,
2117 Susps1Detachments,
2118 Attachment,
2119 BodyCopy,
2120 ConditionalRecursiveCall2
2121 ;
2122 RecursiveCall2
2123 )
2124 ;
2125 RecursiveCall
2126 )
2127 )
2128 ;
2129 Clause =
2130 ( ClauseHead :-
2131 ( IteratorSuspTest,
2132 FirstMatching,
2133 RescheduledTest,
2134 DebugTry ->
2135 DebugApply,
2136 Susps1Detachments,
2137 Attachment,
2138 BodyCopy,
2139 ConditionalRecursiveCall
2140 ;
2141 RecursiveCall
2142 )
2143 )
2144 ),
2145 L = [Clause | T].
2147 gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
2148 length(Args,N),
2149 Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
2150 create_get_mutable(active,State,GetState),
2151 create_get_mutable(Generation,NewGeneration,GetGeneration),
2152 ConditionalCall =
2153 ( Susp = Suspension,
2154 GetState,
2155 GetGeneration ->
2156 'chr update_mutable'(inactive,State),
2157 Call
2158 ; true
2159 ).
2161 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2162 simpagation_head2_worker_end(Head,Rest,F/A,Id,L,T) :-
2163 head_info(Head,A,_Vars,_Susp,VarsSusp,Pairs),
2164 head_arg_matches(Pairs,[],_,VarDict),
2165 extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
2166 append([[]|VarsSusp],ExtraVars,HeadVars),
2167 build_head(F,A,Id,HeadVars,ClauseHead),
2168 next_id(Id,ContinuationId),
2169 build_head(F,A,ContinuationId,VarsSusp,ContinuationHead),
2170 Clause = ( ClauseHead :- ContinuationHead ),
2171 L = [Clause | T].
2173 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2176 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2177 %% ____ _ _
2178 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
2179 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
2180 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
2181 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
2182 %% |_| |___/
2184 propagation_code(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
2185 ( RestHeads == [] ->
2186 propagation_single_headed(Head,Rule,RuleNb,FA,Id,L,T)
2187 ;
2188 propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
2189 ).
2190 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2191 %% Single headed propagation
2192 %% everything in a single clause
2193 propagation_single_headed(Head,Rule,RuleNb,F/A,Id,L,T) :-
2194 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
2195 build_head(F,A,Id,VarsSusp,ClauseHead),
2197 inc_id(Id,NextId),
2198 build_head(F,A,NextId,VarsSusp,NextHead),
2200 NextCall = NextHead,
2202 head_arg_matches(HeadPairs,[],HeadMatching,VarDict),
2203 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
2204 ( Id == [0] ->
2205 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Allocation),
2206 Allocation1 = Allocation
2207 ;
2208 Allocation1 = true
2209 ),
2210 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
2212 gen_state_cond_call(Susp,A,NextCall,Generation,ConditionalNextCall),
2214 ( chr_pp_flag(debugable,on) ->
2215 Rule = rule(_,_,Guard,Body),
2216 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2217 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
2218 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody))
2219 ;
2220 DebugTry = true,
2221 DebugApply = true
2222 ),
2224 Clause = (
2225 ClauseHead :-
2226 HeadMatching,
2227 Allocation1,
2228 'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
2229 GuardCopy,
2230 DebugTry,
2231 !,
2232 DebugApply,
2233 'chr extend_history'(Susp,RuleNb),
2234 Attachment,
2235 BodyCopy,
2236 ConditionalNextCall
2237 ),
2238 L = [Clause | T].
2240 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2241 %% multi headed propagation
2242 %% prelude + predicates to accumulate the necessary combinations of suspended
2243 %% constraints + predicate to execute the body
2244 propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
2245 RestHeads = [First|Rest],
2246 propagation_prelude(Head,RestHeads,Rule,FA,Id,L,L1),
2247 extend_id(Id,ExtendedId),
2248 propagation_nested_code(Rest,[First,Head],Rule,RuleNb,RestHeadNb,FA,ExtendedId,L1,T).
2250 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2251 propagation_prelude(Head,[First|Rest],Rule,F/A,Id,L,T) :-
2252 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
2253 build_head(F,A,Id,VarsSusp,PreludeHead),
2254 head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
2255 Rule = rule(_,_,Guard,Body),
2256 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
2258 passive_head_via(First,[Head],[],VarDict,FirstSuspGoal,Attr,AttrDict),
2259 instantiate_pattern_goals(AttrDict),
2260 get_max_constraint_index(N),
2261 ( N == 1 ->
2262 Susps = Attr
2263 ;
2264 functor(First,FirstFct,FirstAty),
2265 make_attr(N,_Mask,SuspsList,Attr),
2266 get_constraint_index(FirstFct/FirstAty,Pos),
2267 nth(Pos,SuspsList,Susps)
2268 ),
2270 ( Id == [0] ->
2271 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,CondAllocation)
2272 ; CondAllocation = true
2273 ),
2275 extend_id(Id,NestedId),
2276 append([Susps|VarsSusp],ExtraVars,NestedVars),
2277 build_head(F,A,NestedId,NestedVars,NestedHead),
2278 NestedCall = NestedHead,
2280 Prelude = (
2281 PreludeHead :-
2282 FirstMatching,
2283 FirstSuspGoal,
2284 !,
2285 CondAllocation,
2286 NestedCall
2287 ),
2288 L = [Prelude|T].
2290 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2291 propagation_nested_code([],[CurrentHead|PreHeads],Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
2292 propagation_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
2293 propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L1,T).
2295 propagation_nested_code([Head|RestHeads],PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
2296 propagation_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
2297 propagation_accumulator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
2298 inc_id(Id,IncId),
2299 propagation_nested_code(RestHeads,[Head|PreHeads],Rule,RuleNb,RestHeadNb,FA,IncId,L2,T).
2301 propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,F/A,Id,L,T) :-
2302 Rule = rule(_,_,Guard,Body),
2303 get_prop_inner_loop_vars(PreHeads,[CurrentHead,Guard,Body],PreVarsAndSusps,VarDict1,Susp,RestSusps),
2304 gen_var(OtherSusp),
2305 gen_var(OtherSusps),
2306 functor(CurrentHead,_OtherF,OtherA),
2307 gen_vars(OtherA,OtherVars),
2308 Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
2309 create_get_mutable(active,State,GetMutable),
2310 CurrentSuspTest = (
2311 OtherSusp = Suspension,
2312 GetMutable
2313 ),
2314 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
2315 build_head(F,A,Id,ClauseVars,ClauseHead),
2316 RecursiveVars = [OtherSusps|PreVarsAndSusps],
2317 build_head(F,A,Id,RecursiveVars,RecursiveHead),
2318 RecursiveCall = RecursiveHead,
2319 CurrentHead =.. [_|OtherArgs],
2320 pairup(OtherArgs,OtherVars,OtherPairs),
2321 head_arg_matches(OtherPairs,VarDict1,Matching,VarDict),
2323 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
2325 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
2326 gen_uncond_attach_goal(F/A,Susp,Attach,Generation),
2327 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
2329 history_susps(RestHeadNb,[OtherSusp|RestSusps],Susp,[],HistorySusps),
2330 bagof('chr novel_production'(X,Y),( member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList),
2331 list2conj(NovelProductionsList,NovelProductions),
2332 Tuple =.. [t,RuleNb|HistorySusps],
2334 ( chr_pp_flag(debugable,on) ->
2335 Rule = rule(_,_,Guard,Body),
2336 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2337 DebugTry = 'chr debug_event'( try([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody)),
2338 DebugApply = 'chr debug_event'(apply([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody))
2339 ;
2340 DebugTry = true,
2341 DebugApply = true
2342 ),
2344 Clause = (
2345 ClauseHead :-
2346 ( CurrentSuspTest,
2347 DiffSuspGoals,
2348 Matching,
2349 TupleVar = Tuple,
2350 NovelProductions,
2351 GuardCopy,
2352 DebugTry ->
2353 DebugApply,
2354 'chr extend_history'(Susp,TupleVar),
2355 Attach,
2356 BodyCopy,
2357 ConditionalRecursiveCall
2358 ; RecursiveCall
2359 )
2360 ),
2361 L = [Clause|T].
2364 history_susps(Count,OtherSusps,Susp,Acc,HistorySusps) :-
2365 ( Count == 0 ->
2366 reverse(OtherSusps,ReversedSusps),
2367 append(ReversedSusps,[Susp|Acc],HistorySusps)
2368 ;
2369 OtherSusps = [OtherSusp|RestOtherSusps],
2370 NCount is Count - 1,
2371 history_susps(NCount,RestOtherSusps,Susp,[OtherSusp|Acc],HistorySusps)
2372 ).
2375 get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :-
2376 !,
2377 functor(Head,_F,A),
2378 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),
2379 head_arg_matches(Pairs,[],_,VarDict),
2380 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
2381 append(VarsSusp,ExtraVars,HeadVars).
2382 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :-
2383 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps),
2384 functor(Head,_F,A),
2385 gen_var(Susps),
2386 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
2387 head_arg_matches(Pairs,VarDict,_,NVarDict),
2388 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
2389 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
2391 propagation_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
2392 Rule = rule(_,_,Guard,Body),
2393 gen_var_susp_list_for(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSusps,AllButFirst,FirstSusp),
2395 Vars = [ [] | VarsAndSusps],
2397 build_head(F,A,Id,Vars,Head),
2399 ( Id = [0|_] ->
2400 next_id(Id,PrevId),
2401 PrevVarsAndSusps = AllButFirst
2402 ;
2403 dec_id(Id,PrevId),
2404 PrevVarsAndSusps = [FirstSusp|AllButFirst]
2405 ),
2407 build_head(F,A,PrevId,PrevVarsAndSusps,PrevHead),
2408 PredecessorCall = PrevHead,
2410 Clause = (
2411 Head :-
2412 PredecessorCall
2413 ),
2414 L = [Clause | T].
2416 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
2417 !,
2418 functor(Head,_F,A),
2419 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
2420 head_arg_matches(HeadPairs,[],_,VarDict),
2421 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
2422 append(VarsSusp,ExtraVars,HeadVars).
2423 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
2424 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
2425 functor(Head,_F,A),
2426 gen_var(Susps),
2427 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
2428 head_arg_matches(HeadPairs,VarDict,_,NVarDict),
2429 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
2430 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
2432 propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
2433 Rule = rule(_,_,Guard,Body),
2434 pre_vars_and_susps(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],PreVarsAndSusps,VarDict,PreSusps),
2435 gen_var(OtherSusps),
2436 functor(CurrentHead,_OtherF,OtherA),
2437 gen_vars(OtherA,OtherVars),
2438 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
2439 head_arg_matches(HeadPairs,VarDict,FirstMatching,VarDict1),
2441 OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
2443 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
2444 create_get_mutable(active,State,GetMutable),
2445 CurrentSuspTest = (
2446 OtherSusp = OtherSuspension,
2447 GetMutable,
2448 DiffSuspGoals,
2449 FirstMatching
2450 ),
2451 functor(NextHead,NextF,NextA),
2452 passive_head_via(NextHead,[CurrentHead|PreHeads],[],VarDict1,NextSuspGoal,Attr,AttrDict),
2453 instantiate_pattern_goals(AttrDict),
2454 get_max_constraint_index(N),
2455 ( N == 1 ->
2456 NextSusps = Attr
2457 ;
2458 get_constraint_index(NextF/NextA,Position),
2459 make_attr(N,_Mask,SuspsList,Attr),
2460 nth(Position,SuspsList,NextSusps)
2461 ),
2462 inc_id(Id,NestedId),
2463 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
2464 build_head(F,A,Id,ClauseVars,ClauseHead),
2465 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
2466 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
2467 build_head(F,A,NestedId,NestedVars,NestedHead),
2469 RecursiveVars = [OtherSusps|PreVarsAndSusps],
2470 build_head(F,A,Id,RecursiveVars,RecursiveHead),
2471 Clause = (
2472 ClauseHead :-
2473 ( CurrentSuspTest,
2474 NextSuspGoal
2475 ->
2476 NestedHead
2477 ; RecursiveHead
2478 )
2479 ),
2480 L = [Clause|T].
2482 pre_vars_and_susps([Head],Terms,HeadVars,VarDict,[]) :-
2483 !,
2484 functor(Head,_F,A),
2485 head_info(Head,A,_Vars,_Susp,VarsSusp,HeadPairs),
2486 head_arg_matches(HeadPairs,[],_,VarDict),
2487 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
2488 append(VarsSusp,ExtraVars,HeadVars).
2489 pre_vars_and_susps([Head|Heads],Terms,NVSs,NVarDict,[Susp|Susps]) :-
2490 pre_vars_and_susps(Heads,[Head|Terms],VSs,VarDict,Susps),
2491 functor(Head,_F,A),
2492 gen_var(NextSusps),
2493 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
2494 head_arg_matches(HeadPairs,VarDict,_,NVarDict),
2495 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
2496 append(HeadVars,[Susp,NextSusps|VSs],NVSs).
2498 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2500 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2501 %% ____ _ _ _ _
2502 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
2503 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
2504 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
2505 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
2506 %%
2507 %% ____ _ _ _
2508 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
2509 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
2510 %% | _ < __/ |_| | | | __/\ V / (_| | |
2511 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
2512 %%
2513 %% ____ _ _
2514 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
2515 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
2516 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
2517 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
2518 %% |___/
2520 reorder_heads(Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
2521 ( chr_pp_flag(reorder_heads,on) ->
2522 reorder_heads_main(Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
2523 ;
2524 NRestHeads = RestHeads,
2525 NRestIDs = RestIDs
2526 ).
2528 reorder_heads_main(Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
2529 term_variables(Head,KnownVars),
2530 reorder_heads1(RestHeads,RestIDs,KnownVars,NRestHeads,NRestIDs).
2532 reorder_heads1(Heads,IDs,KnownVars,NHeads,NIDs) :-
2533 ( Heads == [] ->
2534 NHeads = [],
2535 NIDs = []
2536 ;
2537 NHeads = [BestHead|BestTail],
2538 NIDs = [BestID | BestIDs],
2539 select_best_head(Heads,IDs,KnownVars,BestHead,BestID,RestHeads,RestIDs,NKnownVars),
2540 reorder_heads1(RestHeads,RestIDs,NKnownVars,BestTail,BestIDs)
2541 ).
2543 select_best_head(Heads,IDs,KnownVars,BestHead,BestID,RestHeads,RestIDs,NKnownVars) :-
2544 ( bagof(tuple(Score,Head,ID,Rest,RIDs), (
2545 select2(Head,ID, Heads,IDs,Rest,RIDs) ,
2546 order_score(Head,KnownVars,Rest,Score)
2547 ),
2548 Scores) -> true ; Scores = []),
2549 max_go_list(Scores,tuple(_,BestHead,BestID,RestHeads,RestIDs)),
2550 term_variables(BestHead,BestHeadVars),
2551 ( setof(V, (
2552 member(V,BestHeadVars),
2553 \+ memberchk_eq(V,KnownVars)
2554 ),
2555 NewVars) -> true ; NewVars = []),
2556 append(NewVars,KnownVars,NKnownVars).
2558 reorder_heads(Head,RestHeads,NRestHeads) :-
2559 term_variables(Head,KnownVars),
2560 reorder_heads1(RestHeads,KnownVars,NRestHeads).
2562 reorder_heads1(Heads,KnownVars,NHeads) :-
2563 ( Heads == [] ->
2564 NHeads = []
2565 ;
2566 NHeads = [BestHead|BestTail],
2567 select_best_head(Heads,KnownVars,BestHead,RestHeads,NKnownVars),
2568 reorder_heads1(RestHeads,NKnownVars,BestTail)
2569 ).
2571 select_best_head(Heads,KnownVars,BestHead,RestHeads,NKnownVars) :-
2572 ( bagof(tuple(Score,Head,Rest), (
2573 select(Head,Heads,Rest) ,
2574 order_score(Head,KnownVars,Rest,Score)
2575 ),
2576 Scores) -> true ; Scores = []),
2577 max_go_list(Scores,tuple(_,BestHead,RestHeads)),
2578 term_variables(BestHead,BestHeadVars),
2579 ( setof(V, (
2580 member(V,BestHeadVars),
2581 \+ memberchk_eq(V,KnownVars)
2582 ),
2583 NewVars) -> true ; NewVars = []),
2584 append(NewVars,KnownVars,NKnownVars).
2586 order_score(Head,KnownVars,Rest,Score) :-
2587 term_variables(Head,HeadVars),
2588 term_variables(Rest,RestVars),
2589 order_score_vars(HeadVars,KnownVars,RestVars,0,Score).
2591 order_score_vars([],_,_,Score,NScore) :-
2592 ( Score == 0 ->
2593 NScore = 99999
2594 ;
2595 NScore = Score
2596 ).
2597 order_score_vars([V|Vs],KnownVars,RestVars,Score,NScore) :-
2598 ( memberchk_eq(V,KnownVars) ->
2599 TScore is Score + 1
2600 ; memberchk_eq(V,RestVars) ->
2601 TScore is Score + 1
2602 ;
2603 TScore = Score
2604 ),
2605 order_score_vars(Vs,KnownVars,RestVars,TScore,NScore).
2607 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2608 %% ___ _ _ _
2609 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
2610 %% | || '_ \| | | '_ \| | '_ \ / _` |
2611 %% | || | | | | | | | | | | | | (_| |
2612 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
2613 %% |___/
2615 create_get_mutable(V,M,GM) :-
2616 GM = (M = mutable(V)).
2617 % GM = 'chr get_mutable'(V,M)
2618 %( ground(V) ->
2619 % GM = (M == mutable(V))
2620 %;
2621 % GM = (M = mutable(V))
2622 %).
2624 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2626 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2627 %% ____ _ ____ _ _
2628 %% / ___|___ __| | ___ / ___| | ___ __ _ _ __ (_)_ __ __ _
2629 %% | | / _ \ / _` |/ _ \ | | | |/ _ \/ _` | '_ \| | '_ \ / _` |
2630 %% | |__| (_) | (_| | __/ | |___| | __/ (_| | | | | | | | | (_| |
2631 %% \____\___/ \__,_|\___| \____|_|\___|\__,_|_| |_|_|_| |_|\__, |
2632 %% |___/
2633 %%
2634 %% removes redundant 'true's and other trivial but potentially non-free constructs
2636 clean_clauses([],[]).
2637 clean_clauses([C|Cs],[NC|NCs]) :-
2638 clean_clause(C,NC),
2639 clean_clauses(Cs,NCs).
2641 clean_clause(Clause,NClause) :-
2642 ( Clause = (Head :- Body) ->
2643 clean_goal(Body,NBody),
2644 ( NBody == true ->
2645 NClause = Head
2646 ;
2647 NClause = (Head :- NBody)
2648 )
2649 ;
2650 NClause = Clause
2651 ).
2653 clean_goal(Goal,NGoal) :-
2654 var(Goal), !,
2655 NGoal = Goal.
2656 clean_goal((G1,G2),NGoal) :-
2657 !,
2658 clean_goal(G1,NG1),
2659 clean_goal(G2,NG2),
2660 ( NG1 == true ->
2661 NGoal = NG2
2662 ; NG2 == true ->
2663 NGoal = NG1
2664 ;
2665 NGoal = (NG1,NG2)
2666 ).
2667 clean_goal((If -> Then ; Else),NGoal) :-
2668 !,
2669 clean_goal(If,NIf),
2670 ( NIf == true ->
2671 clean_goal(Then,NThen),
2672 NGoal = NThen
2673 ; NIf == fail ->
2674 clean_goal(Else,NElse),
2675 NGoal = NElse
2676 ;
2677 clean_goal(Then,NThen),
2678 clean_goal(Else,NElse),
2679 NGoal = (NIf -> NThen; NElse)
2680 ).
2681 clean_goal((G1 ; G2),NGoal) :-
2682 !,
2683 clean_goal(G1,NG1),
2684 clean_goal(G2,NG2),
2685 ( NG1 == fail ->
2686 NGoal = NG2
2687 ; NG2 == fail ->
2688 NGoal = NG1
2689 ;
2690 NGoal = (NG1 ; NG2)
2691 ).
2692 clean_goal(once(G),NGoal) :-
2693 !,
2694 clean_goal(G,NG),
2695 ( NG == true ->
2696 NGoal = true
2697 ; NG == fail ->
2698 NGoal = fail
2699 ;
2700 NGoal = once(NG)
2701 ).
2702 clean_goal((G1 -> G2),NGoal) :-
2703 !,
2704 clean_goal(G1,NG1),
2705 ( NG1 == true ->
2706 clean_goal(G2,NGoal)
2707 ; NG1 == fail ->
2708 NGoal = fail
2709 ;
2710 clean_goal(G2,NG2),
2711 NGoal = (NG1 -> NG2)
2712 ).
2713 clean_goal(Goal,Goal).
2714 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2716 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2717 %% _ _ _ _ _ _ _
2718 %% | | | | |_(_) (_) |_ _ _
2719 %% | | | | __| | | | __| | | |
2720 %% | |_| | |_| | | | |_| |_| |
2721 %% \___/ \__|_|_|_|\__|\__, |
2722 %% |___/
2724 gen_var(_).
2725 gen_vars(N,Xs) :-
2726 length(Xs,N).
2728 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
2729 vars_susp(A,Vars,Susp,VarsSusp),
2730 Head =.. [_|Args],
2731 pairup(Args,Vars,HeadPairs).
2733 inc_id([N|Ns],[O|Ns]) :-
2734 O is N + 1.
2735 dec_id([N|Ns],[M|Ns]) :-
2736 M is N - 1.
2738 extend_id(Id,[0|Id]).
2740 next_id([_,N|Ns],[O|Ns]) :-
2741 O is N + 1.
2743 build_head(F,A,Id,Args,Head) :-
2744 buildName(F,A,Id,Name),
2745 Head =.. [Name|Args].
2747 buildName(Fct,Aty,List,Result) :-
2748 atom_concat(Fct, (/) ,FctSlash),
2749 atom_concat(FctSlash,Aty,FctSlashAty),
2750 buildName_(List,FctSlashAty,Result).
2752 buildName_([],Name,Name).
2753 buildName_([N|Ns],Name,Result) :-
2754 buildName_(Ns,Name,Name1),
2755 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
2756 atom_concat(NameDash,N,Result).
2758 vars_susp(A,Vars,Susp,VarsSusp) :-
2759 length(Vars,A),
2760 append(Vars,[Susp],VarsSusp).
2762 make_attr(N,Mask,SuspsList,Attr) :-
2763 length(SuspsList,N),
2764 Attr =.. [v,Mask|SuspsList].
2766 or_pattern(Pos,Pat) :-
2767 Pow is Pos - 1,
2768 Pat is 1 << Pow. % was 2 ** X
2770 and_pattern(Pos,Pat) :-
2771 X is Pos - 1,
2772 Y is 1 << X, % was 2 ** X
2773 Pat is (-1)*(Y + 1). % because fx (-) is redefined
2775 conj2list(Conj,L) :- %% transform conjunctions to list
2776 conj2list(Conj,L,[]).
2778 conj2list(Conj,L,T) :-
2779 Conj = (G1,G2), !,
2780 conj2list(G1,L,T1),
2781 conj2list(G2,T1,T).
2782 conj2list(G,[G | T],T).
2784 list2conj([],true).
2785 list2conj([G],X) :- !, X = G.
2786 list2conj([G|Gs],C) :-
2787 ( G == true -> %% remove some redundant trues
2788 list2conj(Gs,C)
2789 ;
2790 C = (G,R),
2791 list2conj(Gs,R)
2792 ).
2794 atom_concat_list([X],X) :- ! .
2795 atom_concat_list([X|Xs],A) :-
2796 atom_concat_list(Xs,B),
2797 atom_concat(X,B,A).
2799 set_elems([],_).
2800 set_elems([X|Xs],X) :-
2801 set_elems(Xs,X).
2803 member2([X|_],[Y|_],X-Y).
2804 member2([_|Xs],[_|Ys],P) :-
2805 member2(Xs,Ys,P).
2807 select2(X, Y, [X|Xs], [Y|Ys], Xs, Ys).
2808 select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :-
2809 select2(X, Y, Xs, Ys, NXs, NYs).
2811 pair_all_with([],_,[]).
2812 pair_all_with([X|Xs],Y,[X-Y|Rest]) :-
2813 pair_all_with(Xs,Y,Rest).
2815 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%