| blob | f8dcb362ec73e3e840a6e49ad6b8dcbe6f853896 |
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_op).
131 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
132 :- constraints
133 constraint/2,
134 constraint_count/1,
135 constraint_index/2,
136 get_constraint_index/2,
137 max_constraint_index/1,
138 get_max_constraint_index/1,
139 target_module/1,
140 get_target_module/1,
141 attached/2,
142 is_attached/1,
143 chr_clear/0.
145 constraint(FA,Number) \ constraint(FA,Query)
146 <=> Query = Number.
147 constraint(FA,Index) # ID \ constraint(Query,Index)
148 <=> Query = FA pragma passive(ID).
150 constraint_count(Index) # ID \ constraint_count(Query)
151 <=> Query = Index pragma passive(ID).
153 target_module(Mod) # ID \ get_target_module(Query)
154 <=> Query = Mod
155 pragma passive(ID).
156 get_target_module(Query)
157 <=> Query = user.
159 constraint_index(C,Index) # ID \ get_constraint_index(C,Query)
160 <=> Query = Index
161 pragma passive(ID).
162 get_constraint_index(C,Query)
163 <=> fail.
165 max_constraint_index(Index) # ID \ get_max_constraint_index(Query)
166 <=> Query = Index
167 pragma passive(ID).
168 get_max_constraint_index(Query)
169 <=> fail.
171 attached(Constr,yes) \ attached(Constr,_) <=> true.
172 attached(Constr,no) \ attached(Constr,_) <=> true.
173 attached(Constr,maybe) \ attached(Constr,maybe) <=> true.
175 attached(Constr,Type) # ID \ is_attached(Constr)
176 <=> true |
177 ( Type == no ->
178 fail
179 ;
180 true
181 )
182 pragma passive(ID).
183 is_attached(C) <=> true.
185 chr_clear \ constraint(_,_) # ID
186 <=> true pragma passive(ID).
187 chr_clear \ constraint_count(_) # ID
188 <=> true pragma passive(ID).
189 chr_clear \ constraint_index(_,_) # ID
190 <=> true pragma passive(ID).
191 chr_clear \ max_constraint_index(_) # ID
192 <=> true pragma passive(ID).
193 chr_clear \ target_module(_) # ID
194 <=> true pragma passive(ID).
195 chr_clear \ attached(_,_) # ID
196 <=> true pragma passive(ID).
197 chr_clear
198 <=> true.
199 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
201 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
202 %%
203 %% Translation
205 chr_translate(Declarations,NewDeclarations) :-
206 init_chr_pp_flags,
207 partition_clauses(Declarations,Decls,Rules,OtherClauses),
208 ( Decls == [] ->
209 NewDeclarations = OtherClauses
210 ;
211 check_rules(Rules,Decls),
212 unique_analyse_optimise(Rules,NRules),
213 check_attachments(NRules),
214 set_constraint_indices(Decls,1),
215 store_management_preds(Decls,StoreClauses),
216 constraints_code(Decls,NRules,ConstraintClauses),
217 append_lists([OtherClauses,
218 StoreClauses,
219 ConstraintClauses
220 ],
221 NewDeclarations)
222 ),
223 chr_clear.
225 store_management_preds(Constraints,Clauses) :-
226 generate_attach_detach_a_constraint_all(Constraints,AttachAConstraintClauses),
227 generate_attach_increment(AttachIncrementClauses),
228 generate_attr_unify_hook(AttrUnifyHookClauses),
229 append_lists([AttachAConstraintClauses
230 ,AttachIncrementClauses
231 ,AttrUnifyHookClauses]
232 ,Clauses).
235 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
236 %%
237 %% Partitioning of clauses into constraint declarations, chr rules and other
238 %% clauses
240 partition_clauses([],[],[],[]).
241 partition_clauses([C|Cs],Ds,Rs,OCs) :-
242 ( rule(C,R) ->
243 Ds = RDs,
244 Rs = [R | RRs],
245 OCs = ROCs
246 ; is_declaration(C,D) ->
247 append(D,RDs,Ds),
248 Rs = RRs,
249 OCs = ROCs
250 ; is_module_declaration(C,Mod) ->
251 target_module(Mod),
252 Ds = RDs,
253 Rs = RRs,
254 OCs = [C|ROCs]
255 ; C = (handler _) ->
256 format('CHR compiler WARNING: ~w.\n',[C]),
257 format(' `--> SICStus compatibility: ignoring handler/1 declaration.\n',[]),
258 Ds = RDs,
259 Rs = RRs,
260 OCs = ROCs
261 ; C = (rules _) ->
262 format('CHR compiler WARNING: ~w.\n',[C]),
263 format(' `--> SICStus compatibility: ignoring rules/1 declaration.\n',[]),
264 Ds = RDs,
265 Rs = RRs,
266 OCs = ROCs
267 ; C = option(OptionName,OptionValue) ->
268 handle_option(OptionName,OptionValue),
269 Ds = RDs,
270 Rs = RRs,
271 OCs = ROCs
272 ; Ds = RDs,
273 Rs = RRs,
274 OCs = [C|ROCs]
275 ),
276 partition_clauses(Cs,RDs,RRs,ROCs).
278 is_declaration(D, Constraints) :- %% constraint declaration
279 ( D = (:- Decl) ->
280 true
281 ;
282 D = Decl
283 ),
284 Decl =.. [constraints,Cs],
285 conj2list(Cs,Constraints).
287 %% Data Declaration
288 %%
289 %% pragma_rule
290 %% -> pragma(
291 %% rule,
292 %% ids,
293 %% list(pragma),
294 %% yesno(string)
295 %% )
296 %%
297 %% ids -> ids(
298 %% list(int),
299 %% list(int)
300 %% )
301 %%
302 %% rule -> rule(
303 %% list(constraint), :: constraints to be removed
304 %% list(constraint), :: surviving constraints
305 %% goal, :: guard
306 %% goal :: body
307 %% )
309 rule(RI,R) :- %% name @ rule
310 RI = (Name @ RI2), !,
311 rule(RI2,yes(Name),R).
312 rule(RI,R) :-
313 rule(RI,no,R).
315 rule(RI,Name,R) :-
316 RI = (RI2 pragma P), !, %% pragmas
317 is_rule(RI2,R1,IDs),
318 conj2list(P,Ps),
319 R = pragma(R1,IDs,Ps,Name).
320 rule(RI,Name,R) :-
321 is_rule(RI,R1,IDs),
322 R = pragma(R1,IDs,[],Name).
324 is_rule(RI,R,IDs) :- %% propagation rule
325 RI = (H ==> B), !,
326 conj2list(H,Head2i),
327 get_ids(Head2i,IDs2,Head2),
328 IDs = ids([],IDs2),
329 ( B = (G | RB) ->
330 R = rule([],Head2,G,RB)
331 ;
332 R = rule([],Head2,true,B)
333 ).
334 is_rule(RI,R,IDs) :- %% simplification/simpagation rule
335 RI = (H <=> B), !,
336 ( B = (G | RB) ->
337 Guard = G,
338 Body = RB
339 ; Guard = true,
340 Body = B
341 ),
342 ( H = (H1 \ H2) ->
343 conj2list(H1,Head2i),
344 conj2list(H2,Head1i),
345 get_ids(Head2i,IDs2,Head2,0,N),
346 get_ids(Head1i,IDs1,Head1,N,_),
347 IDs = ids(IDs1,IDs2)
348 ; conj2list(H,Head1i),
349 Head2 = [],
350 get_ids(Head1i,IDs1,Head1),
351 IDs = ids(IDs1,[])
352 ),
353 R = rule(Head1,Head2,Guard,Body).
355 get_ids(Cs,IDs,NCs) :-
356 get_ids(Cs,IDs,NCs,0,_).
358 get_ids([],[],[],N,N).
359 get_ids([C|Cs],[N|IDs],[NC|NCs],N,NN) :-
360 ( C = (NC # N) ->
361 true
362 ;
363 NC = C
364 ),
365 M is N + 1,
366 get_ids(Cs,IDs,NCs, M,NN).
368 is_module_declaration((:- module(Mod)),Mod).
369 is_module_declaration((:- module(Mod,_)),Mod).
371 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
373 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
374 %% Some input verification:
375 %% - all constraints in heads are declared constraints
377 check_rules(Rules,Decls) :-
378 check_rules(Rules,Decls,1).
380 check_rules([],_,_).
381 check_rules([PragmaRule|Rest],Decls,N) :-
382 check_rule(PragmaRule,Decls,N),
383 N1 is N + 1,
384 check_rules(Rest,Decls,N1).
386 check_rule(PragmaRule,Decls,N) :-
387 PragmaRule = pragma(Rule,_IDs,Pragmas,_Name),
388 Rule = rule(H1,H2,_,_),
389 append(H1,H2,HeadConstraints),
390 check_head_constraints(HeadConstraints,Decls,PragmaRule,N),
391 check_pragmas(Pragmas,PragmaRule,N).
393 check_head_constraints([],_,_,_).
394 check_head_constraints([Constr|Rest],Decls,PragmaRule,N) :-
395 functor(Constr,F,A),
396 ( member(F/A,Decls) ->
397 check_head_constraints(Rest,Decls,PragmaRule,N)
398 ;
399 format('CHR compiler ERROR: Undeclared constraint ~w in head of ~@.\n',
400 [F/A,format_rule(PragmaRule,N)]),
401 format(' `--> Constraint should be on of ~w.\n',[Decls]),
402 fail
403 ).
405 check_pragmas([],_,_).
406 check_pragmas([Pragma|Pragmas],PragmaRule,N) :-
407 check_pragma(Pragma,PragmaRule,N),
408 check_pragmas(Pragmas,PragmaRule,N).
410 check_pragma(Pragma,PragmaRule,N) :-
411 var(Pragma), !,
412 format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',
413 [Pragma,format_rule(PragmaRule,N)]),
414 format(' `--> Pragma should not be a variable!\n',[]),
415 fail.
417 check_pragma(passive(ID), PragmaRule, N) :-
418 !,
419 PragmaRule = pragma(_,ids(IDs1,IDs2),_,_),
420 ( memberchk_eq(ID,IDs1) ->
421 true
422 ; memberchk_eq(ID,IDs2) ->
423 true
424 ;
425 format('CHR compiler ERROR: invalid identifier ~w in pragma passive in ~@.\n',
426 [ID,format_rule(PragmaRule,N)]),
427 fail
428 ).
430 check_pragma(Pragma, PragmaRule, N) :-
431 Pragma = unique(_,_),
432 !,
433 format('CHR compiler WARNING: undocument pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
434 format(' `--> Only use this pragma if you know what you are doing.\n',[]).
436 check_pragma(Pragma, PragmaRule, N) :-
437 Pragma = already_in_heads,
438 !,
439 format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
440 format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
442 check_pragma(Pragma, PragmaRule, N) :-
443 Pragma = already_in_head(_),
444 !,
445 format('CHR compiler WARNING: currently unsupported pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
446 format(' `--> Pragma is ignored. Termination and correctness may be affected \n',[]).
448 check_pragma(Pragma,PragmaRule,N) :-
449 format('CHR compiler ERROR: invalid pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
450 format(' `--> Pragma should be one of passive/1!\n',[]),
451 fail.
453 format_rule(PragmaRule,N) :-
454 PragmaRule = pragma(_,_,_,MaybeName),
455 ( MaybeName = yes(Name) ->
456 write('rule '), write(Name)
457 ;
458 write('rule number '), write(N)
459 ).
461 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
463 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
464 % Global Options
465 %
467 handle_option(Var,Value) :-
468 var(Var), !,
469 format('CHR compiler ERROR: ~w.\n',[option(Var,Value)]),
470 format(' `--> First argument should be an atom, not a variable.\n',[]),
471 fail.
473 handle_option(Name,Value) :-
474 var(Value), !,
475 format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
476 format(' `--> Second argument should be a nonvariable.\n',[]),
477 fail.
479 handle_option(Name,Value) :-
480 option_definition(Name,Value,Flags),
481 !,
482 set_chr_pp_flags(Flags).
484 handle_option(Name,Value) :-
485 \+ option_definition(Name,_,_), !.
487 handle_option(Name,Value) :-
488 findall(V,option_definition(Name,V,_),Vs),
489 format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
490 format(' `--> Invalid value ~w: should be one of ~w.\n',[Value,Vs]),
491 fail.
493 option_definition(optimize,experimental,Flags) :-
494 Flags = [ unique_analyse_optimise - on,
495 check_unnecessary_active - full,
496 reorder_heads - on,
497 set_semantics_rule - on,
498 check_attachments - on,
499 guard_via_reschedule - on
500 ].
501 option_definition(optimize,full,Flags) :-
502 Flags = [ unique_analyse_optimise - on,
503 check_unnecessary_active - full,
504 reorder_heads - on,
505 set_semantics_rule - on,
506 check_attachments - on,
507 guard_via_reschedule - on
508 ].
510 option_definition(optimize,sicstus,Flags) :-
511 Flags = [ unique_analyse_optimise - off,
512 check_unnecessary_active - simplification,
513 reorder_heads - off,
514 set_semantics_rule - off,
515 check_attachments - off,
516 guard_via_reschedule - off
517 ].
519 option_definition(optimize,off,Flags) :-
520 Flags = [ unique_analyse_optimise - off,
521 check_unnecessary_active - off,
522 reorder_heads - off,
523 set_semantics_rule - off,
524 check_attachments - off,
525 guard_via_reschedule - off
526 ].
528 option_definition(debug,off,Flags) :-
529 Flags = [ debugable - off ].
530 option_definition(debug,on,Flags) :-
531 Flags = [ debugable - on ].
533 option_definition(check_guard_bindings,on,Flags) :-
534 Flags = [ guard_locks - on ].
536 option_definition(check_guard_bindings,off,Flags) :-
537 Flags = [ guard_locks - off ].
539 init_chr_pp_flags :-
540 chr_pp_flag_definition(Name,[DefaultValue|_]),
541 set_chr_pp_flag(Name,DefaultValue),
542 fail.
543 init_chr_pp_flags.
545 set_chr_pp_flags([]).
546 set_chr_pp_flags([Name-Value|Flags]) :-
547 set_chr_pp_flag(Name,Value),
548 set_chr_pp_flags(Flags).
550 set_chr_pp_flag(Name,Value) :-
551 atom_concat('$chr_pp_',Name,GlobalVar),
552 nb_setval(GlobalVar,Value).
554 chr_pp_flag_definition(unique_analyse_optimise,[on,off]).
555 chr_pp_flag_definition(check_unnecessary_active,[full,simplification,off]).
556 chr_pp_flag_definition(reorder_heads,[on,off]).
557 chr_pp_flag_definition(set_semantics_rule,[on,off]).
558 chr_pp_flag_definition(guard_via_reschedule,[on,off]).
559 chr_pp_flag_definition(guard_locks,[on,off]).
560 chr_pp_flag_definition(check_attachments,[on,off]).
561 chr_pp_flag_definition(debugable,[off,on]).
563 chr_pp_flag(Name,Value) :-
564 atom_concat('$chr_pp_',Name,GlobalVar),
565 nb_getval(GlobalVar,V),
566 ( V == [] ->
567 chr_pp_flag_definition(Name,[Value|_])
568 ;
569 V = Value
570 ).
571 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
573 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
574 %%
575 %% Generated predicates
576 %% attach_$CONSTRAINT
577 %% attach_increment
578 %% detach_$CONSTRAINT
579 %% attr_unify_hook
581 %% attach_$CONSTRAINT
582 generate_attach_detach_a_constraint_all([],[]).
583 generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
584 ( is_attached(Constraint) ->
585 generate_attach_a_constraint(Constraint,Clauses1),
586 generate_detach_a_constraint(Constraint,Clauses2)
587 ;
588 Clauses1 = [],
589 Clauses2 = []
590 ),
591 generate_attach_detach_a_constraint_all(Constraints,Clauses3),
592 append_lists([Clauses1,Clauses2,Clauses3],Clauses).
594 generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
595 generate_attach_a_constraint_empty_list(Constraint,Clause1),
596 get_max_constraint_index(N),
597 ( N == 1 ->
598 generate_attach_a_constraint_1_1(Constraint,Clause2)
599 ;
600 generate_attach_a_constraint_t_p(Constraint,Clause2)
601 ).
603 generate_attach_a_constraint_empty_list(CFct / CAty,Clause) :-
604 atom_concat_list(['attach_',CFct, (/) ,CAty],Fct),
605 Args = [[],_],
606 Head =.. [Fct | Args],
607 Clause = ( Head :- true).
609 generate_attach_a_constraint_1_1(CFct / CAty,Clause) :-
610 atom_concat_list(['attach_',CFct, (/) ,CAty],Fct),
611 Args = [[Var|Vars],Susp],
612 Head =.. [Fct | Args],
613 RecursiveCall =.. [Fct,Vars,Susp],
614 get_target_module(Mod),
615 Body =
616 (
617 ( get_attr(Var, Mod, Susps) ->
618 NewSusps=[Susp|Susps],
619 put_attr(Var, Mod, NewSusps)
620 ;
621 put_attr(Var, Mod, [Susp])
622 ),
623 RecursiveCall
624 ),
625 Clause = (Head :- Body).
627 generate_attach_a_constraint_t_p(CFct / CAty,Clause) :-
628 atom_concat_list(['attach_',CFct, (/) ,CAty],Fct),
629 Args = [[Var|Vars],Susp],
630 Head =.. [Fct | Args],
631 RecursiveCall =.. [Fct,Vars,Susp],
632 get_constraint_index(CFct/CAty,Position),
633 or_pattern(Position,Pattern),
634 get_max_constraint_index(Total),
635 make_attr(Total,Mask,SuspsList,Attr),
636 nth(Position,SuspsList,Susps),
637 substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
638 make_attr(Total,Mask,SuspsList1,NewAttr1),
639 substitute(Susps,SuspsList,[Susp],SuspsList2),
640 make_attr(Total,NewMask,SuspsList2,NewAttr2),
641 copy_term(SuspsList,SuspsList3),
642 nth(Position,SuspsList3,[Susp]),
643 chr_delete(SuspsList3,[Susp],RestSuspsList),
644 set_elems(RestSuspsList,[]),
645 make_attr(Total,Pattern,SuspsList3,NewAttr3),
646 get_target_module(Mod),
647 Body =
648 (
649 ( get_attr(Var,Mod,TAttr) ->
650 TAttr = Attr,
651 ( Mask /\ Pattern =:= Pattern ->
652 put_attr(Var, Mod, NewAttr1)
653 ;
654 NewMask is Mask \/ Pattern,
655 put_attr(Var, Mod, NewAttr2)
656 )
657 ;
658 put_attr(Var,Mod,NewAttr3)
659 ),
660 RecursiveCall
661 ),
662 Clause = (Head :- Body).
664 %% detach_$CONSTRAINT
665 generate_detach_a_constraint(Constraint,[Clause1,Clause2]) :-
666 generate_detach_a_constraint_empty_list(Constraint,Clause1),
667 get_max_constraint_index(N),
668 ( N == 1 ->
669 generate_detach_a_constraint_1_1(Constraint,Clause2)
670 ;
671 generate_detach_a_constraint_t_p(Constraint,Clause2)
672 ).
674 generate_detach_a_constraint_empty_list(CFct / CAty,Clause) :-
675 atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
676 Args = [[],_],
677 Head =.. [Fct | Args],
678 Clause = ( Head :- true).
680 generate_detach_a_constraint_1_1(CFct / CAty,Clause) :-
681 atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
682 Args = [[Var|Vars],Susp],
683 Head =.. [Fct | Args],
684 RecursiveCall =.. [Fct,Vars,Susp],
685 get_target_module(Mod),
686 Body =
687 (
688 ( get_attr(Var,Mod,Susps) ->
689 'chr sbag_del_element'(Susps,Susp,NewSusps),
690 ( NewSusps == [] ->
691 del_attr(Var,Mod)
692 ;
693 put_attr(Var,Mod,NewSusps)
694 )
695 ;
696 true
697 ),
698 RecursiveCall
699 ),
700 Clause = (Head :- Body).
702 generate_detach_a_constraint_t_p(CFct / CAty,Clause) :-
703 atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
704 Args = [[Var|Vars],Susp],
705 Head =.. [Fct | Args],
706 RecursiveCall =.. [Fct,Vars,Susp],
707 get_constraint_index(CFct/CAty,Position),
708 or_pattern(Position,Pattern),
709 and_pattern(Position,DelPattern),
710 get_max_constraint_index(Total),
711 make_attr(Total,Mask,SuspsList,Attr),
712 nth(Position,SuspsList,Susps),
713 substitute(Susps,SuspsList,[],SuspsList1),
714 make_attr(Total,NewMask,SuspsList1,Attr1),
715 substitute(Susps,SuspsList,NewSusps,SuspsList2),
716 make_attr(Total,Mask,SuspsList2,Attr2),
717 get_target_module(Mod),
718 Body =
719 (
720 ( get_attr(Var,Mod,TAttr) ->
721 TAttr = Attr,
722 ( Mask /\ Pattern =:= Pattern ->
723 'chr sbag_del_element'(Susps,Susp,NewSusps),
724 ( NewSusps == [] ->
725 NewMask is Mask /\ DelPattern,
726 ( NewMask == 0 ->
727 del_attr(Var,Mod)
728 ;
729 put_attr(Var,Mod,Attr1)
730 )
731 ;
732 put_attr(Var,Mod,Attr2)
733 )
734 ;
735 true
736 )
737 ;
738 true
739 ),
740 RecursiveCall
741 ),
742 Clause = (Head :- Body).
744 %% detach_$CONSTRAINT
745 generate_attach_increment([Clause1,Clause2]) :-
746 generate_attach_increment_empty(Clause1),
747 get_max_constraint_index(N),
748 ( N == 1 ->
749 generate_attach_increment_one(Clause2)
750 ;
751 generate_attach_increment_many(N,Clause2)
752 ).
754 generate_attach_increment_empty((attach_increment([],_) :- true)).
756 generate_attach_increment_one(Clause) :-
757 Head = attach_increment([Var|Vars],Susps),
758 get_target_module(Mod),
759 Body =
760 (
761 'chr not_locked'(Var),
762 ( get_attr(Var,Mod,VarSusps) ->
763 sort(VarSusps,SortedVarSusps),
764 merge(Susps,SortedVarSusps,MergedSusps),
765 put_attr(Var,Mod,MergedSusps)
766 ;
767 put_attr(Var,Mod,Susps)
768 ),
769 attach_increment(Vars,Susps)
770 ),
771 Clause = (Head :- Body).
773 generate_attach_increment_many(N,Clause) :-
774 make_attr(N,Mask,SuspsList,Attr),
775 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
776 Head = attach_increment([Var|Vars],Attr),
777 bagof(G,X ^ Y ^ SY ^ M ^ (member2(SuspsList,OtherSuspsList,X-Y),G = (sort(Y,SY),'chr merge_attributes'(X,SY,M))),Gs),
778 list2conj(Gs,SortGoals),
779 bagof(MS,A ^ B ^ C ^ member((A,'chr merge_attributes'(B,C,MS)),Gs), MergedSuspsList),
780 make_attr(N,MergedMask,MergedSuspsList,NewAttr),
781 get_target_module(Mod),
782 Body =
783 (
784 'chr not_locked'(Var),
785 ( get_attr(Var,Mod,TOtherAttr) ->
786 TOtherAttr = OtherAttr,
787 SortGoals,
788 MergedMask is Mask \/ OtherMask,
789 put_attr(Var,Mod,NewAttr)
790 ;
791 put_attr(Var,Mod,Attr)
792 ),
793 attach_increment(Vars,Attr)
794 ),
795 Clause = (Head :- Body).
797 %% attr_unify_hook
798 generate_attr_unify_hook([Clause]) :-
799 get_max_constraint_index(N),
800 ( N == 1 ->
801 generate_attr_unify_hook_one(Clause)
802 ;
803 generate_attr_unify_hook_many(N,Clause)
804 ).
806 generate_attr_unify_hook_one(Clause) :-
807 Head = Mod:attr_unify_hook(Susps,Other),
808 get_target_module(Mod),
809 make_run_suspensions(NewSusps,WakeNewSusps),
810 make_run_suspensions(Susps,WakeSusps),
811 Body =
812 (
813 sort(Susps, SortedSusps),
814 ( var(Other) ->
815 ( get_attr(Other,Mod,OtherSusps) ->
816 true
817 ;
818 OtherSusps = []
819 ),
820 sort(OtherSusps,SortedOtherSusps),
821 'chr merge_attributes'(SortedSusps,SortedOtherSusps,NewSusps),
822 put_attr(Other,Mod,NewSusps),
823 WakeNewSusps
824 ;
825 ( compound(Other) ->
826 term_variables(Other,OtherVars),
827 attach_increment(OtherVars, SortedSusps)
828 ;
829 true
830 ),
831 WakeSusps
832 )
833 ),
834 Clause = (Head :- Body).
836 generate_attr_unify_hook_many(N,Clause) :-
837 make_attr(N,Mask,SuspsList,Attr),
838 make_attr(N,OtherMask,OtherSuspsList,OtherAttr),
839 bagof(Sort,A ^ B ^ ( member(A,SuspsList) , Sort = sort(A,B) ) , SortGoalList),
840 list2conj(SortGoalList,SortGoals),
841 bagof(B, A ^ member(sort(A,B),SortGoalList), SortedSuspsList),
842 bagof(C, D ^ E ^ F ^ G ^ (member2(SortedSuspsList,OtherSuspsList,D-E),
843 C = (sort(E,F),
844 'chr merge_attributes'(D,F,G)) ),
845 SortMergeGoalList),
846 bagof(G, D ^ F ^ H ^ member((H,'chr merge_attributes'(D,F,G)),SortMergeGoalList) , MergedSuspsList),
847 list2conj(SortMergeGoalList,SortMergeGoals),
848 make_attr(N,MergedMask,MergedSuspsList,MergedAttr),
849 make_attr(N,Mask,SortedSuspsList,SortedAttr),
850 Head = Mod:attr_unify_hook(Attr,Other),
851 get_target_module(Mod),
852 make_run_suspensions_loop(MergedSuspsList,WakeMergedSusps),
853 make_run_suspensions_loop(SortedSuspsList,WakeSortedSusps),
854 Body =
855 (
856 SortGoals,
857 ( var(Other) ->
858 ( get_attr(Other,Mod,TOtherAttr) ->
859 TOtherAttr = OtherAttr,
860 SortMergeGoals,
861 MergedMask is Mask \/ OtherMask,
862 put_attr(Other,Mod,MergedAttr),
863 WakeMergedSusps
864 ;
865 put_attr(Other,Mod,SortedAttr),
866 WakeSortedSusps
867 )
868 ;
869 ( compound(Other) ->
870 term_variables(Other,OtherVars),
871 attach_increment(OtherVars,SortedAttr)
872 ;
873 true
874 ),
875 WakeSortedSusps
876 )
877 ),
878 Clause = (Head :- Body).
880 make_run_suspensions(Susps,Goal) :-
881 ( chr_pp_flag(debugable,on) ->
882 Goal = 'chr run_suspensions_d'(Susps)
883 ;
884 Goal = 'chr run_suspensions'(Susps)
885 ).
887 make_run_suspensions_loop(SuspsList,Goal) :-
888 ( chr_pp_flag(debugable,on) ->
889 Goal = 'chr run_suspensions_loop_d'(SuspsList)
890 ;
891 Goal = 'chr run_suspensions_loop'(SuspsList)
892 ).
894 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
896 check_attachments(Rules) :-
897 ( chr_pp_flag(check_attachments,on) ->
898 check_attachments_(Rules)
899 ;
900 true
901 ).
903 check_attachments_([]).
904 check_attachments_([R|Rs]) :-
905 check_attachment(R),
906 check_attachments_(Rs).
908 check_attachment(R) :-
909 R = pragma(Rule,_,_,_),
910 Rule = rule(H1,H2,G,B),
911 check_attachment_heads1(H1,H1,H2,G),
912 check_attachment_heads2(H2,H1,B).
914 check_attachment_heads1([],_,_,_).
915 check_attachment_heads1([C|Cs],H1,H2,G) :-
916 functor(C,F,A),
917 ( H1 == [C],
918 H2 == [],
919 G == true,
920 C =.. [_|L],
921 no_matching(L,[]) ->
922 attached(F/A,no)
923 ;
924 attached(F/A,maybe)
925 ),
926 check_attachment_heads1(Cs,H1,H2,G).
928 no_matching([],_).
929 no_matching([X|Xs],Prev) :-
930 var(X),
931 \+ memberchk_eq(X,Prev),
932 no_matching(Xs,[X|Prev]).
934 check_attachment_heads2([],_,_).
935 check_attachment_heads2([C|Cs],H1,B) :-
936 functor(C,F,A),
937 ( H1 \== [],
938 B == true ->
939 attached(F/A,maybe)
940 ;
941 attached(F/A,yes)
942 ),
943 check_attachment_heads2(Cs,H1,B).
945 all_attached([]).
946 all_attached([C|Cs]) :-
947 functor(C,F,A),
948 is_attached(F/A),
949 all_attached(Cs).
951 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
953 set_constraint_indices([],M) :-
954 N is M - 1,
955 max_constraint_index(N).
956 set_constraint_indices([C|Cs],N) :-
957 ( is_attached(C) ->
958 constraint_index(C,N),
959 M is N + 1,
960 set_constraint_indices(Cs,M)
961 ;
962 set_constraint_indices(Cs,N)
963 ).
965 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
966 %% ____ _ ____ _ _ _ _
967 %% | _ \ _ _| | ___ / ___|___ _ __ ___ _ __ (_) | __ _| |_(_) ___ _ __
968 %% | |_) | | | | |/ _ \ | | / _ \| '_ ` _ \| '_ \| | |/ _` | __| |/ _ \| '_ \
969 %% | _ <| |_| | | __/ | |__| (_) | | | | | | |_) | | | (_| | |_| | (_) | | | |
970 %% |_| \_\\__,_|_|\___| \____\___/|_| |_| |_| .__/|_|_|\__,_|\__|_|\___/|_| |_|
971 %% |_|
973 constraints_code(Constraints,Rules,Clauses) :-
974 post_constraints(Constraints,1),
975 constraints_code1(1,Rules,L,[]),
976 clean_clauses(L,Clauses).
978 %% Add global data
979 post_constraints([],MaxIndex1) :-
980 MaxIndex is MaxIndex1 - 1,
981 constraint_count(MaxIndex).
982 post_constraints([F/A|Cs],N) :-
983 constraint(F/A,N),
984 M is N + 1,
985 post_constraints(Cs,M).
986 constraints_code1(I,Rules,L,T) :-
987 constraint_count(N),
988 ( I > N ->
989 T = L
990 ;
991 constraint_code(I,Rules,L,T1),
992 J is I + 1,
993 constraints_code1(J,Rules,T1,T)
994 ).
996 %% Generate code for a single CHR constraint
997 constraint_code(I, Rules, L, T) :-
998 constraint(Constraint,I),
999 constraint_prelude(Constraint,Clause),
1000 L = [Clause | L1],
1001 Id1 = [0],
1002 rules_code(Rules,1,I,Id1,Id2,L1,L2),
1003 gen_cond_attach_clause(Constraint,Id2,L2,T).
1005 %% Generate prelude predicate for a constraint.
1006 %% f(...) :- f/a_0(...,Susp).
1007 constraint_prelude(F/A, Clause) :-
1008 vars_susp(A,Vars,Susp,VarsSusp),
1009 Head =.. [ F | Vars],
1010 build_head(F,A,[0],VarsSusp,Delegate),
1011 get_target_module(Mod),
1012 ( chr_pp_flag(debugable,on) ->
1013 Clause =
1014 ( Head :-
1015 'chr allocate_constraint'(Mod : Delegate, Susp, F, Vars),
1016 (
1017 'chr debug_event'(call(Susp)),
1018 Delegate
1019 ;
1020 'chr debug_event'(fail(Susp)), !,
1021 fail
1022 ),
1023 (
1024 'chr debug_event'(exit(Susp))
1025 ;
1026 'chr debug_event'(redo(Susp)),
1027 fail
1028 )
1029 )
1030 ;
1031 Clause = ( Head :- Delegate )
1032 ).
1034 gen_cond_attach_clause(F/A,Id,L,T) :-
1035 ( is_attached(F/A) ->
1036 ( Id == [0] ->
1037 gen_cond_attach_goal(F/A,Body,AllArgs,Args,Susp)
1038 ; vars_susp(A,Args,Susp,AllArgs),
1039 gen_uncond_attach_goal(F/A,Susp,Body,_)
1040 ),
1041 ( chr_pp_flag(debugable,on) ->
1042 Constraint =.. [F|Args],
1043 DebugEvent = 'chr debug_event'(insert(Constraint#Susp))
1044 ;
1045 DebugEvent = true
1046 ),
1047 build_head(F,A,Id,AllArgs,Head),
1048 Clause = ( Head :- DebugEvent,Body ),
1049 L = [Clause | T]
1050 ;
1051 L = T
1052 ).
1054 gen_cond_attach_goal(F/A,Goal,AllArgs,Args,Susp) :-
1055 vars_susp(A,Args,Susp,AllArgs),
1056 build_head(F,A,[0],AllArgs,Closure),
1057 atom_concat_list(['attach_',F, (/) ,A],AttachF),
1058 Attach =.. [AttachF,Vars,Susp],
1059 get_target_module(Mod),
1060 Goal =
1061 (
1062 ( var(Susp) ->
1063 'chr insert_constraint_internal'(Vars,Susp,Mod:Closure,F,Args)
1064 ;
1065 'chr activate_constraint'(Vars,Susp,_)
1066 ),
1067 Attach
1068 ).
1070 gen_uncond_attach_goal(F/A,Susp,AttachGoal,Generation) :-
1071 atom_concat_list(['attach_',F, (/) ,A],AttachF),
1072 Attach =.. [AttachF,Vars,Susp],
1073 AttachGoal =
1074 (
1075 'chr activate_constraint'(Vars, Susp, Generation),
1076 Attach
1077 ).
1079 %% Generate all the code for a constraint based on all CHR rules
1080 rules_code([],_,_,Id,Id,L,L).
1081 rules_code([R |Rs],RuleNb,I,Id1,Id3,L,T) :-
1082 rule_code(R,RuleNb,I,Id1,Id2,L,T1),
1083 NextRuleNb is RuleNb + 1,
1084 rules_code(Rs,NextRuleNb,I,Id2,Id3,T1,T).
1086 %% Generate code for a constraint based on a single CHR rule
1087 rule_code(PragmaRule,RuleNb,I,Id1,Id2,L,T) :-
1088 PragmaRule = pragma(Rule,HeadIDs,_Pragmas,_Name),
1089 HeadIDs = ids(Head1IDs,Head2IDs),
1090 Rule = rule(Head1,Head2,_,_),
1091 heads1_code(Head1,[],Head1IDs,[],PragmaRule,I,Id1,L,L1),
1092 heads2_code(Head2,[],Head2IDs,[],PragmaRule,RuleNb,I,Id1,Id2,L1,T).
1094 %% Generate code based on all the removed heads of a CHR rule
1095 heads1_code([],_,_,_,_,_,_,L,L).
1096 heads1_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,I,Id,L,T) :-
1097 PragmaRule = pragma(Rule,_,Pragmas,_Name),
1098 constraint(F/A,I),
1099 ( functor(Head,F,A),
1100 \+ check_unnecessary_active(Head,RestHeads,Rule),
1101 \+ memberchk_eq(passive(HeadID),Pragmas),
1102 all_attached(Heads),
1103 all_attached(RestHeads),
1104 Rule = rule(_,Heads2,_,_),
1105 all_attached(Heads2) ->
1106 append(Heads,RestHeads,OtherHeads),
1107 append(HeadIDs,RestIDs,OtherIDs),
1108 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,F/A,I,Id,L,L1)
1109 ;
1110 L = L1
1111 ),
1112 heads1_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,I,Id,L1,T).
1114 %% Generate code based on one removed head of a CHR rule
1115 head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,I,Id,L,T) :-
1116 PragmaRule = pragma(Rule,_,_,_Name),
1117 Rule = rule(_,Head2,_,_),
1118 ( Head2 == [] ->
1119 reorder_heads(Head,OtherHeads,OtherIDs,NOtherHeads,NOtherIDs),
1120 simplification_code(Head,NOtherHeads,NOtherIDs,PragmaRule,FA,Id,L,T)
1121 ;
1122 simpagation_head1_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
1123 ).
1125 %% Generate code based on all the persistent heads of a CHR rule
1126 heads2_code([],_,_,_,_,_,_,Id,Id,L,L).
1127 heads2_code([Head|Heads],RestHeads,[HeadID|HeadIDs],RestIDs,PragmaRule,RuleNb,I,Id1,Id3,L,T) :-
1128 PragmaRule = pragma(Rule,_,Pragmas,_Name),
1129 constraint(F/A,I),
1130 ( functor(Head,F,A),
1131 \+ check_unnecessary_active(Head,RestHeads,Rule),
1132 \+ memberchk_eq(passive(HeadID),Pragmas),
1133 \+ set_semantics_rule(PragmaRule),
1134 all_attached(Heads),
1135 all_attached(RestHeads),
1136 Rule = rule(Heads1,_,_,_),
1137 all_attached(Heads1) ->
1138 append(Heads,RestHeads,OtherHeads),
1139 append(HeadIDs,RestIDs,OtherIDs),
1140 length(Heads,RestHeadNb),
1141 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RuleNb,RestHeadNb,F/A,Id1,L,L0),
1142 inc_id(Id1,Id2),
1143 gen_alloc_inc_clause(F/A,Id1,L0,L1)
1144 ;
1145 L = L1,
1146 Id2 = Id1
1147 ),
1148 heads2_code(Heads,[Head|RestHeads],HeadIDs,[HeadID|RestIDs],PragmaRule,RuleNb,I,Id2,Id3,L1,T).
1150 %% Generate code based on one persistent head of a CHR rule
1151 head2_code(Head,OtherHeads,OtherIDs,PragmaRule,RuleNb,RestHeadNb,FA,Id,L,T) :-
1152 PragmaRule = pragma(Rule,_,_,_Name),
1153 Rule = rule(Head1,_,_,_),
1154 ( Head1 == [] ->
1155 reorder_heads(Head,OtherHeads,NOtherHeads),
1156 propagation_code(Head,NOtherHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
1157 ;
1158 simpagation_head2_code(Head,OtherHeads,OtherIDs,PragmaRule,FA,Id,L,T)
1159 ).
1161 gen_alloc_inc_clause(F/A,Id,L,T) :-
1162 vars_susp(A,Vars,Susp,VarsSusp),
1163 build_head(F,A,Id,VarsSusp,Head),
1164 inc_id(Id,IncId),
1165 build_head(F,A,IncId,VarsSusp,CallHead),
1166 ( Id == [0] ->
1167 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,ConditionalAlloc)
1168 ;
1169 ConditionalAlloc = true
1170 ),
1171 Clause =
1172 (
1173 Head :-
1174 ConditionalAlloc,
1175 CallHead
1176 ),
1177 L = [Clause|T].
1179 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal) :-
1180 build_head(F,A,[0],VarsSusp,Term),
1181 get_target_module(Mod),
1182 ConstraintAllocationGoal =
1183 ( var(Susp) ->
1184 'chr allocate_constraint'(Mod : Term, Susp, F, Vars)
1185 ;
1186 true
1187 ).
1189 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1192 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1194 guard_via_reschedule(Retrievals,GuardList,Prelude,Goal) :-
1195 ( chr_pp_flag(guard_via_reschedule,on) ->
1196 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal)
1197 ;
1198 append(Retrievals,GuardList,GoalList),
1199 list2conj(GoalList,Goal)
1200 ).
1202 guard_via_reschedule_main(Retrievals,GuardList,Prelude,Goal) :-
1203 initialize_unit_dictionary(Prelude,Dict),
1204 build_units(Retrievals,GuardList,Dict,Units),
1205 dependency_reorder(Units,NUnits),
1206 units2goal(NUnits,Goal).
1208 units2goal([],true).
1209 units2goal([unit(_,Goal,_,_)|Units],(Goal,Goals)) :-
1210 units2goal(Units,Goals).
1212 dependency_reorder(Units,NUnits) :-
1213 dependency_reorder(Units,[],NUnits).
1215 dependency_reorder([],Acc,Result) :-
1216 reverse(Acc,Result).
1218 dependency_reorder([Unit|Units],Acc,Result) :-
1219 Unit = unit(_GID,_Goal,Type,GIDs),
1220 ( Type == fixed ->
1221 NAcc = [Unit|Acc]
1222 ;
1223 dependency_insert(Acc,Unit,GIDs,NAcc)
1224 ),
1225 dependency_reorder(Units,NAcc,Result).
1227 dependency_insert([],Unit,_,[Unit]).
1228 dependency_insert([X|Xs],Unit,GIDs,L) :-
1229 X = unit(GID,_,_,_),
1230 ( memberchk(GID,GIDs) ->
1231 L = [Unit,X|Xs]
1232 ;
1233 L = [X | T],
1234 dependency_insert(Xs,Unit,GIDs,T)
1235 ).
1237 build_units(Retrievals,Guard,InitialDict,Units) :-
1238 build_retrieval_units(Retrievals,1,N,InitialDict,Dict,Units,Tail),
1239 build_guard_units(Guard,N,Dict,Tail).
1241 build_retrieval_units([],N,N,Dict,Dict,L,L).
1242 build_retrieval_units([U|Us],N,M,Dict,NDict,L,T) :-
1243 term_variables(U,Vs),
1244 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
1245 L = [unit(N,U,movable,GIDs)|L1],
1246 N1 is N + 1,
1247 build_retrieval_units2(Us,N1,M,Dict1,NDict,L1,T).
1249 build_retrieval_units2([],N,N,Dict,Dict,L,L).
1250 build_retrieval_units2([U|Us],N,M,Dict,NDict,L,T) :-
1251 term_variables(U,Vs),
1252 update_unit_dictionary(Vs,N,Dict,Dict1,[],GIDs),
1253 L = [unit(N,U,fixed,GIDs)|L1],
1254 N1 is N + 1,
1255 build_retrieval_units(Us,N1,M,Dict1,NDict,L1,T).
1257 initialize_unit_dictionary(Term,Dict) :-
1258 term_variables(Term,Vars),
1259 pair_all_with(Vars,0,Dict).
1261 update_unit_dictionary([],_,Dict,Dict,GIDs,GIDs).
1262 update_unit_dictionary([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
1263 ( lookup_eq(Dict,V,GID) ->
1264 ( (GID == This ; memberchk(GID,GIDs) ) ->
1265 GIDs1 = GIDs
1266 ;
1267 GIDs1 = [GID|GIDs]
1268 ),
1269 Dict1 = Dict
1270 ;
1271 Dict1 = [V - This|Dict],
1272 GIDs1 = GIDs
1273 ),
1274 update_unit_dictionary(Vs,This,Dict1,NDict,GIDs1,NGIDs).
1276 build_guard_units(Guard,N,Dict,Units) :-
1277 ( Guard = [Goal] ->
1278 Units = [unit(N,Goal,fixed,[])]
1279 ; Guard = [Goal|Goals] ->
1280 term_variables(Goal,Vs),
1281 update_unit_dictionary2(Vs,N,Dict,NDict,[],GIDs),
1282 Units = [unit(N,Goal,movable,GIDs)|RUnits],
1283 N1 is N + 1,
1284 build_guard_units(Goals,N1,NDict,RUnits)
1285 ).
1287 update_unit_dictionary2([],_,Dict,Dict,GIDs,GIDs).
1288 update_unit_dictionary2([V|Vs],This,Dict,NDict,GIDs,NGIDs) :-
1289 ( lookup_eq(Dict,V,GID) ->
1290 ( (GID == This ; memberchk(GID,GIDs) ) ->
1291 GIDs1 = GIDs
1292 ;
1293 GIDs1 = [GID|GIDs]
1294 ),
1295 Dict1 = [V - This|Dict]
1296 ;
1297 Dict1 = [V - This|Dict],
1298 GIDs1 = GIDs
1299 ),
1300 update_unit_dictionary2(Vs,This,Dict1,NDict,GIDs1,NGIDs).
1302 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1304 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1305 %% ____ _ ____ _ _
1306 %% / ___| ___| |_ / ___| ___ _ __ ___ __ _ _ __ | |_(_) ___ ___ _
1307 %% \___ \ / _ \ __| \___ \ / _ \ '_ ` _ \ / _` | '_ \| __| |/ __/ __(_)
1308 %% ___) | __/ |_ ___) | __/ | | | | | (_| | | | | |_| | (__\__ \_
1309 %% |____/ \___|\__| |____/ \___|_| |_| |_|\__,_|_| |_|\__|_|\___|___(_)
1310 %%
1311 %% _ _ _ ___ __
1312 %% | | | |_ __ (_) __ _ _ _ ___ |_ _|_ __ / _| ___ _ __ ___ _ __ ___ ___
1313 %% | | | | '_ \| |/ _` | | | |/ _ \ | || '_ \| |_ / _ \ '__/ _ \ '_ \ / __/ _ \
1314 %% | |_| | | | | | (_| | |_| | __/ | || | | | _| __/ | | __/ | | | (_| __/
1315 %% \___/|_| |_|_|\__, |\__,_|\___| |___|_| |_|_| \___|_| \___|_| |_|\___\___|
1316 %% |_|
1317 unique_analyse_optimise(Rules,NRules) :-
1318 ( chr_pp_flag(unique_analyse_optimise,on) ->
1319 unique_analyse_optimise_main(Rules,1,[],NRules)
1320 ;
1321 NRules = Rules
1322 ).
1324 unique_analyse_optimise_main([],_,_,[]).
1325 unique_analyse_optimise_main([PRule|PRules],N,PatternList,[NPRule|NPRules]) :-
1326 ( discover_unique_pattern(PRule,N,Pattern) ->
1327 NPatternList = [Pattern|PatternList]
1328 ;
1329 NPatternList = PatternList
1330 ),
1331 PRule = pragma(Rule,Ids,Pragmas,Name),
1332 Rule = rule(H1,H2,_,_),
1333 Ids = ids(Ids1,Ids2),
1334 apply_unique_patterns_to_constraints(H1,Ids1,NPatternList,MorePragmas1),
1335 apply_unique_patterns_to_constraints(H2,Ids2,NPatternList,MorePragmas2),
1336 append_lists([MorePragmas1,MorePragmas2,Pragmas],NPragmas),
1337 NPRule = pragma(Rule,Ids,NPragmas,Name),
1338 N1 is N + 1,
1339 unique_analyse_optimise_main(PRules,N1,NPatternList,NPRules).
1341 apply_unique_patterns_to_constraints([],_,_,[]).
1342 apply_unique_patterns_to_constraints([C|Cs],[Id|Ids],Patterns,Pragmas) :-
1343 ( member(Pattern,Patterns),
1344 apply_unique_pattern(C,Id,Pattern,Pragma) ->
1345 Pragmas = [Pragma | RPragmas]
1346 ;
1347 Pragmas = RPragmas
1348 ),
1349 apply_unique_patterns_to_constraints(Cs,Ids,Patterns,RPragmas).
1351 apply_unique_pattern(Constraint,Id,Pattern,Pragma) :-
1352 Pattern = unique(PatternConstraint,PatternKey),
1353 subsumes(Constraint,PatternConstraint,Unifier),
1354 ( setof( V,
1355 T^Term^Vs^(
1356 member(T,PatternKey),
1357 lookup_eq(Unifier,T,Term),
1358 term_variables(Term,Vs),
1359 member(V,Vs)
1360 ),
1361 Vars) ->
1362 true
1363 ;
1364 Vars = []
1365 ),
1366 Pragma = unique(Id,Vars).
1368 % subsumes(+Term1, +Term2, -Unifier)
1369 %
1370 % If Term1 is a more general term than Term2 (e.g. has a larger
1371 % part instantiated), unify Unifier with a list Var-Value of
1372 % variables from Term2 and their corresponding values in Term1.
1374 subsumes(Term1,Term2,Unifier) :-
1375 empty_assoc(S0),
1376 subsumes_aux(Term1,Term2,S0,S),
1377 assoc_to_list(S,L),
1378 build_unifier(L,Unifier).
1380 subsumes_aux(Term1, Term2, S0, S) :-
1381 ( compound(Term2),
1382 functor(Term2, F, N)
1383 -> compound(Term1), functor(Term1, F, N),
1384 subsumes_aux(N, Term1, Term2, S0, S)
1385 ; Term1 == Term2
1386 -> S = S0
1387 ; var(Term2),
1388 get_assoc(Term1,S0,V)
1389 -> V == Term2, S = S0
1390 ; var(Term2),
1391 put_assoc(Term1, S0, Term2, S)
1392 ).
1394 subsumes_aux(0, _, _, S, S) :- ! .
1395 subsumes_aux(N, T1, T2, S0, S) :-
1396 arg(N, T1, T1x),
1397 arg(N, T2, T2x),
1398 subsumes_aux(T1x, T2x, S0, S1),
1399 M is N-1,
1400 subsumes_aux(M, T1, T2, S1, S).
1402 build_unifier([],[]).
1403 build_unifier([X-V|R],[V - X | T]) :-
1404 build_unifier(R,T).
1406 discover_unique_pattern(PragmaRule,RuleNb,Pattern) :-
1407 PragmaRule = pragma(Rule,_,Pragmas,Name),
1408 ( Rule = rule([C1],[C2],Guard,Body) ->
1409 true
1410 ;
1411 Rule = rule([C1,C2],[],Guard,Body)
1412 ),
1413 check_unique_constraints(C1,C2,Guard,Body,Pragmas,List),
1414 term_variables(C1,Vs),
1415 select_pragma_unique_variables(List,Vs,Key),
1416 Pattern0 = unique(C1,Key),
1417 copy_term(Pattern0,Pattern),
1418 ( prolog_flag(verbose,V), V == yes ->
1419 format('Found unique pattern ~w in rule ~d~@\n',
1420 [Pattern,RuleNb,(Name=yes(N) -> write(": "),write(N) ; true)])
1421 ;
1422 true
1423 ).
1425 select_pragma_unique_variables([],_,[]).
1426 select_pragma_unique_variables([X-Y|R],Vs,L) :-
1427 ( X == Y ->
1428 L = [X|T]
1429 ;
1430 once((
1431 \+ memberchk_eq(X,Vs)
1432 ;
1433 \+ memberchk_eq(Y,Vs)
1434 )),
1435 L = T
1436 ),
1437 select_pragma_unique_variables(R,Vs,T).
1439 check_unique_constraints(C1,C2,G,_Body,Pragmas,List) :-
1440 \+ member(passive(_),Pragmas),
1441 variable_replacement(C1-C2,C2-C1,List),
1442 copy_with_variable_replacement(G,OtherG,List),
1443 negate(G,NotG),
1444 once(entails(NotG,OtherG)).
1446 negate(true,fail).
1447 negate(fail,true).
1448 negate(X =< Y, Y < X).
1449 negate(X > Y, Y >= X).
1450 negate(X >= Y, Y > X).
1451 negate(X < Y, Y =< X).
1452 negate(var(X),nonvar(X)).
1453 negate(nonvar(X),var(X)).
1455 entails(X,X1) :- X1 == X.
1456 entails(fail,_).
1457 entails(X > Y, X1 >= Y1) :- X1 == X, Y1 == Y.
1458 entails(X < Y, X1 =< Y1) :- X1 == X, Y1 == Y.
1459 entails(ground(X),nonvar(X1)) :- X1 == X.
1460 entails(compound(X),nonvar(X1)) :- X1 == X.
1461 entails(atomic(X),nonvar(X1)) :- X1 == X.
1462 entails(number(X),nonvar(X1)) :- X1 == X.
1463 entails(atom(X),nonvar(X1)) :- X1 == X.
1465 check_unnecessary_active(Constraint,Previous,Rule) :-
1466 ( chr_pp_flag(check_unnecessary_active,full) ->
1467 check_unnecessary_active_main(Constraint,Previous,Rule)
1468 ; chr_pp_flag(check_unnecessary_active,simplification),
1469 Rule = rule(_,[],_,_) ->
1470 check_unnecessary_active_main(Constraint,Previous,Rule)
1471 ;
1472 fail
1473 ).
1475 check_unnecessary_active_main(Constraint,Previous,Rule) :-
1476 member(Other,Previous),
1477 variable_replacement(Other,Constraint,List),
1478 copy_with_variable_replacement(Rule,Rule2,List),
1479 identical_rules(Rule,Rule2), ! .
1481 set_semantics_rule(PragmaRule) :-
1482 ( chr_pp_flag(set_semantics_rule,on) ->
1483 set_semantics_rule_main(PragmaRule)
1484 ;
1485 fail
1486 ).
1488 set_semantics_rule_main(PragmaRule) :-
1489 PragmaRule = pragma(Rule,IDs,Pragmas,_),
1490 Rule = rule([C1],[C2],true,_),
1491 IDs = ids([ID1],[ID2]),
1492 once(member(unique(ID1,L1),Pragmas)),
1493 once(member(unique(ID2,L2),Pragmas)),
1494 L1 == L2,
1495 \+ memberchk_eq(passive(ID1),Pragmas).
1496 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1498 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1499 %% ____ _ _____ _ _
1500 %% | _ \ _ _| | ___ | ____|__ _ _ _(_)_ ____ _| | ___ _ __ ___ ___
1501 %% | |_) | | | | |/ _ \ | _| / _` | | | | \ \ / / _` | |/ _ \ '_ \ / __/ _ \
1502 %% | _ <| |_| | | __/ | |__| (_| | |_| | |\ V / (_| | | __/ | | | (_| __/
1503 %% |_| \_\\__,_|_|\___| |_____\__, |\__,_|_| \_/ \__,_|_|\___|_| |_|\___\___|
1504 %% |_|
1505 % have to check for no duplicates in value list
1507 % check wether two rules are identical
1509 identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :-
1510 G1 == G2,
1511 identical_bodies(B1,B2),
1512 permutation(H11,P1),
1513 P1 == H12,
1514 permutation(H21,P2),
1515 P2 == H22.
1517 identical_bodies(B1,B2) :-
1518 ( B1 = (X1 = Y1),
1519 B2 = (X2 = Y2) ->
1520 ( X1 == X2,
1521 Y1 == Y2
1522 ; X1 == Y2,
1523 X2 == Y1
1524 ),
1525 !
1526 ; B1 == B2
1527 ).
1529 % replace variables in list
1531 copy_with_variable_replacement(X,Y,L) :-
1532 ( var(X) ->
1533 ( lookup_eq(L,X,Y) ->
1534 true
1535 ; X = Y
1536 )
1537 ; functor(X,F,A),
1538 functor(Y,F,A),
1539 X =.. [_|XArgs],
1540 Y =.. [_|YArgs],
1541 copy_with_variable_replacement_l(XArgs,YArgs,L)
1542 ).
1544 copy_with_variable_replacement_l([],[],_).
1545 copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :-
1546 copy_with_variable_replacement(X,Y,L),
1547 copy_with_variable_replacement_l(Xs,Ys,L).
1549 %% build variable replacement list
1551 variable_replacement(X,Y,L) :-
1552 variable_replacement(X,Y,[],L).
1554 variable_replacement(X,Y,L1,L2) :-
1555 ( var(X) ->
1556 var(Y),
1557 ( lookup_eq(L1,X,Z) ->
1558 Z == Y,
1559 L2 = L1
1560 ; L2 = [X-Y|L1]
1561 )
1562 ; X =.. [F|XArgs],
1563 nonvar(Y),
1564 Y =.. [F|YArgs],
1565 variable_replacement_l(XArgs,YArgs,L1,L2)
1566 ).
1568 variable_replacement_l([],[],L,L).
1569 variable_replacement_l([X|Xs],[Y|Ys],L1,L3) :-
1570 variable_replacement(X,Y,L1,L2),
1571 variable_replacement_l(Xs,Ys,L2,L3).
1572 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1574 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1575 %% ____ _ _ _ __ _ _ _
1576 %% / ___|(_)_ __ ___ _ __ | (_)/ _(_) ___ __ _| |_(_) ___ _ __
1577 %% \___ \| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
1578 %% ___) | | | | | | | |_) | | | _| | (_| (_| | |_| | (_) | | | |
1579 %% |____/|_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
1580 %% |_|
1582 simplification_code(Head,RestHeads,RestIDs,PragmaRule,F/A,Id,L,T) :-
1583 PragmaRule = pragma(Rule,_,Pragmas,_),
1584 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
1585 build_head(F,A,Id,HeadVars,ClauseHead),
1586 head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
1588 ( RestHeads == [] ->
1589 Susps = [],
1590 VarDict = VarDict1,
1591 GetRestHeads = []
1592 ;
1593 rest_heads_retrieval_and_matching(RestHeads,RestIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict)
1594 ),
1596 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
1597 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
1599 gen_uncond_susps_detachments(Susps,RestHeads,SuspsDetachments),
1600 gen_cond_susp_detachment(Susp,F/A,SuspDetachment),
1602 ( chr_pp_flag(debugable,on) ->
1603 Rule = rule(_,_,Guard,Body),
1604 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
1605 DebugTry = 'chr debug_event'( try([Susp|RestSusps],[],DebugGuard,DebugBody)),
1606 DebugApply = 'chr debug_event'(apply([Susp|RestSusps],[],DebugGuard,DebugBody))
1607 ;
1608 DebugTry = true,
1609 DebugApply = true
1610 ),
1612 Clause = ( ClauseHead :-
1613 FirstMatching,
1614 RescheduledTest,
1615 DebugTry,
1616 !,
1617 DebugApply,
1618 SuspsDetachments,
1619 SuspDetachment,
1620 BodyCopy
1621 ),
1622 L = [Clause | T].
1624 head_arg_matches(Pairs,VarDict,Goal,NVarDict) :-
1625 head_arg_matches_(Pairs,VarDict,GoalList,NVarDict),
1626 list2conj(GoalList,Goal).
1628 head_arg_matches_([],VarDict,[],VarDict).
1629 head_arg_matches_([Arg-Var| Rest],VarDict,GoalList,NVarDict) :-
1630 ( var(Arg) ->
1631 ( lookup_eq(VarDict,Arg,OtherVar) ->
1632 GoalList = [Var == OtherVar | RestGoalList],
1633 VarDict1 = VarDict
1634 ; VarDict1 = [Arg-Var | VarDict],
1635 GoalList = RestGoalList
1636 ),
1637 Pairs = Rest
1638 ; atomic(Arg) ->
1639 GoalList = [ Var == Arg | RestGoalList],
1640 VarDict = VarDict1,
1641 Pairs = Rest
1642 ; Arg =.. [_|Args],
1643 functor(Arg,Fct,N),
1644 functor(Term,Fct,N),
1645 Term =.. [_|Vars],
1646 GoalList =[ nonvar(Var), Var = Term | RestGoalList ],
1647 pairup(Args,Vars,NewPairs),
1648 append(NewPairs,Rest,Pairs),
1649 VarDict1 = VarDict
1650 ),
1651 head_arg_matches_(Pairs,VarDict1,RestGoalList,NVarDict).
1653 rest_heads_retrieval_and_matching(Heads,IDs,Pragmas,ActiveHead,GoalList,Susps,VarDict,NVarDict):-
1654 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,PrevHs,PrevSusps,AttrDict) :-
1657 ( Heads = [_|_] ->
1658 rest_heads_retrieval_and_matching_n(Heads,IDs,Pragmas,PrevHs,PrevSusps,ActiveHead,GoalList,Susps,VarDict,NVarDict,AttrDict)
1659 ;
1660 GoalList = [],
1661 Susps = [],
1662 VarDict = NVarDict
1663 ).
1665 rest_heads_retrieval_and_matching_n([],_,_,_,_,_,[],[],VarDict,VarDict,AttrDict) :-
1666 instantiate_pattern_goals(AttrDict).
1667 rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,ActiveHead,[ViaGoal,Goal|Goals],[Susp|Susps],VarDict,NVarDict,AttrDict) :-
1668 passive_head_via(H,[ActiveHead|PrevHs],AttrDict,VarDict,ViaGoal,Attr,NewAttrDict),
1669 functor(H,Fct,Aty),
1670 head_info(H,Aty,Vars,_,_,Pairs),
1671 head_arg_matches(Pairs,VarDict,MatchingGoal,VarDict1),
1672 Suspension =.. [suspension,_,State,_,_,_,_|Vars],
1673 get_max_constraint_index(N),
1674 ( N == 1 ->
1675 VarSusps = Attr
1676 ;
1677 get_constraint_index(Fct/Aty,Pos),
1678 make_attr(N,_Mask,SuspsList,Attr),
1679 nth(Pos,SuspsList,VarSusps)
1680 ),
1681 different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
1682 create_get_mutable(active,State,GetMutable),
1683 Goal1 =
1684 (
1685 'chr sbag_member'(Susp,VarSusps),
1686 Susp = Suspension,
1687 GetMutable,
1688 DiffSuspGoals,
1689 MatchingGoal
1690 ),
1691 ( member(unique(ID,UniqueKeus),Pragmas),
1692 check_unique_keys(UniqueKeus,VarDict) ->
1693 Goal = (Goal1 -> true)
1694 ;
1695 Goal = Goal1
1696 ),
1697 rest_heads_retrieval_and_matching_n(Hs,IDs,Pragmas,[H|PrevHs],[Susp|PrevSusps],ActiveHead,Goals,Susps,VarDict1,NVarDict,NewAttrDict).
1699 instantiate_pattern_goals([]).
1700 instantiate_pattern_goals([_-attr(Attr,Bits,Goal)|Rest]) :-
1701 get_max_constraint_index(N),
1702 ( N == 1 ->
1703 Goal = true
1704 ;
1705 make_attr(N,Mask,_,Attr),
1706 or_list(Bits,Pattern), !,
1707 Goal = (Mask /\ Pattern =:= Pattern)
1708 ),
1709 instantiate_pattern_goals(Rest).
1712 check_unique_keys([],_).
1713 check_unique_keys([V|Vs],Dict) :-
1714 lookup_eq(Dict,V,_),
1715 check_unique_keys(Vs,Dict).
1717 % Generates tests to ensure the found constraint differs from previously found constraints
1718 different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
1719 ( bagof(DiffSuspGoal, Pos ^ ( nth(Pos,Heads,PreHead), \+ Head \= PreHead, nth(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
1720 list2conj(DiffSuspGoalList,DiffSuspGoals)
1721 ;
1722 DiffSuspGoals = true
1723 ).
1725 passive_head_via(Head,PrevHeads,AttrDict,VarDict,Goal,Attr,NewAttrDict) :-
1726 functor(Head,F,A),
1727 get_constraint_index(F/A,Pos),
1728 common_variables(Head,PrevHeads,CommonVars),
1729 translate(CommonVars,VarDict,Vars),
1730 or_pattern(Pos,Bit),
1731 ( permutation(Vars,PermutedVars),
1732 lookup_eq(AttrDict,PermutedVars,attr(Attr,Positions,_)) ->
1733 member(Bit,Positions), !,
1734 NewAttrDict = AttrDict,
1735 Goal = true
1736 ;
1737 Goal = (Goal1, PatternGoal),
1738 gen_get_mod_constraints(Vars,Goal1,Attr),
1739 NewAttrDict = [Vars - attr(Attr,[Bit|_],PatternGoal) | AttrDict]
1740 ).
1742 common_variables(T,Ts,Vs) :-
1743 term_variables(T,V1),
1744 term_variables(Ts,V2),
1745 intersect_eq(V1,V2,Vs).
1747 gen_get_mod_constraints(L,Goal,Susps) :-
1748 get_target_module(Mod),
1749 ( L == [] ->
1750 Goal =
1751 ( 'chr global_term_ref_1'(Global),
1752 get_attr(Global,Mod,TSusps),
1753 TSusps = Susps
1754 )
1755 ;
1756 ( L = [A] ->
1757 VIA = 'chr via_1'(A,V)
1758 ; ( L = [A,B] ->
1759 VIA = 'chr via_2'(A,B,V)
1760 ; VIA = 'chr via'(L,V)
1761 )
1762 ),
1763 Goal =
1764 ( VIA,
1765 get_attr(V,Mod,TSusps),
1766 TSusps = Susps
1767 )
1768 ).
1770 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy) :-
1771 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
1772 list2conj(GuardCopyList,GuardCopy).
1774 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
1775 Rule = rule(_,_,Guard,Body),
1776 conj2list(Guard,GuardList),
1777 split_off_simple_guard(GuardList,VarDict,GuardPrefix,RestGuardList),
1778 my_term_copy(GuardPrefix-RestGuardList,VarDict,VarDict2,GuardPrefixCopy-RestGuardListCopyCore),
1780 append(GuardPrefixCopy,[RestGuardCopy],GuardCopyList),
1781 term_variables(RestGuardList,GuardVars),
1782 term_variables(RestGuardListCopyCore,GuardCopyVars),
1783 ( chr_pp_flag(guard_locks,on),
1784 bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
1785 X ^ (member(X,GuardVars), % X is a variable appearing in the original guard
1786 lookup_eq(VarDict,X,Y), % translate X into new variable
1787 memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
1788 ),
1789 LocksUnlocks) ->
1790 once(pairup(Locks,Unlocks,LocksUnlocks))
1791 ;
1792 Locks = [],
1793 Unlocks = []
1794 ),
1795 list2conj(Locks,LockPhase),
1796 list2conj(Unlocks,UnlockPhase),
1797 list2conj(RestGuardListCopyCore,RestGuardCopyCore),
1798 RestGuardCopy = (LockPhase,(RestGuardCopyCore,UnlockPhase)),
1799 my_term_copy(Body,VarDict2,BodyCopy).
1802 split_off_simple_guard([],_,[],[]).
1803 split_off_simple_guard([G|Gs],VarDict,S,C) :-
1804 ( simple_guard(G,VarDict) ->
1805 S = [G|Ss],
1806 split_off_simple_guard(Gs,VarDict,Ss,C)
1807 ;
1808 S = [],
1809 C = [G|Gs]
1810 ).
1812 % simple guard: cheap and benign (does not bind variables)
1814 simple_guard(var(_), _).
1815 simple_guard(nonvar(_), _).
1816 simple_guard(ground(_), _).
1817 simple_guard(number(_), _).
1818 simple_guard(atom(_), _).
1819 simple_guard(integer(_), _).
1820 simple_guard(float(_), _).
1822 simple_guard(_ > _ , _).
1823 simple_guard(_ < _ , _).
1824 simple_guard(_ =< _, _).
1825 simple_guard(_ >= _, _).
1826 simple_guard(_ =:= _, _).
1827 simple_guard(_ == _, _).
1829 simple_guard(X is _, VarDict) :-
1830 \+ lookup_eq(VarDict,X,_).
1832 simple_guard((G1,G2),VarDict) :-
1833 simple_guard(G1,VarDict),
1834 simple_guard(G2,VarDict).
1836 simple_guard(\+ G, VarDict) :-
1837 simple_guard(G, VarDict).
1839 my_term_copy(X,Dict,Y) :-
1840 my_term_copy(X,Dict,_,Y).
1842 my_term_copy(X,Dict1,Dict2,Y) :-
1843 ( var(X) ->
1844 ( lookup_eq(Dict1,X,Y) ->
1845 Dict2 = Dict1
1846 ; Dict2 = [X-Y|Dict1]
1847 )
1848 ; functor(X,XF,XA),
1849 functor(Y,XF,XA),
1850 X =.. [_|XArgs],
1851 Y =.. [_|YArgs],
1852 my_term_copy_list(XArgs,Dict1,Dict2,YArgs)
1853 ).
1855 my_term_copy_list([],Dict,Dict,[]).
1856 my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :-
1857 my_term_copy(X,Dict1,Dict2,Y),
1858 my_term_copy_list(Xs,Dict2,Dict3,Ys).
1860 gen_cond_susp_detachment(Susp,FA,SuspDetachment) :-
1861 ( is_attached(FA) ->
1862 gen_uncond_susp_detachment(Susp,FA,UnCondSuspDetachment),
1863 SuspDetachment =
1864 ( var(Susp) ->
1865 true
1866 ; UnCondSuspDetachment
1867 )
1868 ;
1869 SuspDetachment = true
1870 ).
1872 gen_uncond_susp_detachment(Susp,CFct/CAty,SuspDetachment) :-
1873 ( is_attached(CFct/CAty) ->
1874 atom_concat_list(['detach_',CFct, (/) ,CAty],Fct),
1875 Detach =.. [Fct,Vars,Susp],
1876 ( chr_pp_flag(debugable,on) ->
1877 DebugEvent = 'chr debug_event'(remove(Susp))
1878 ;
1879 DebugEvent = true
1880 ),
1881 SuspDetachment =
1882 (
1883 DebugEvent,
1884 'chr remove_constraint_internal'(Susp, Vars),
1885 Detach
1886 )
1887 ;
1888 SuspDetachment = true
1889 ).
1891 gen_uncond_susps_detachments([],[],true).
1892 gen_uncond_susps_detachments([Susp|Susps],[Term|Terms],(SuspDetachment,SuspsDetachments)) :-
1893 functor(Term,F,A),
1894 gen_uncond_susp_detachment(Susp,F/A,SuspDetachment),
1895 gen_uncond_susps_detachments(Susps,Terms,SuspsDetachments).
1897 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1899 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1900 %% ____ _ _ _ _
1901 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ / |
1902 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ | |
1903 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | | |
1904 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_|
1905 %% |_| |___/
1907 simpagation_head1_code(Head,RestHeads,OtherIDs,PragmaRule,F/A,Id,L,T) :-
1908 PragmaRule = pragma(Rule,ids(_,Heads2IDs),Pragmas,_Name),
1909 Rule = rule(_Heads,Heads2,Guard,Body),
1911 head_info(Head,A,_Vars,Susp,HeadVars,HeadPairs),
1912 head_arg_matches(HeadPairs,[],FirstMatching,VarDict1),
1914 build_head(F,A,Id,HeadVars,ClauseHead),
1916 append(RestHeads,Heads2,Heads),
1917 append(OtherIDs,Heads2IDs,IDs),
1918 reorder_heads(Head,Heads,IDs,NHeads,NIDs),
1919 rest_heads_retrieval_and_matching(NHeads,NIDs,Pragmas,Head,GetRestHeads,Susps,VarDict1,VarDict),
1920 split_by_ids(NIDs,Susps,OtherIDs,Susps1,Susps2),
1922 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
1923 guard_via_reschedule(GetRestHeads,GuardCopyList,ClauseHead-FirstMatching,RescheduledTest),
1925 gen_uncond_susps_detachments(Susps1,RestHeads,SuspsDetachments),
1926 gen_cond_susp_detachment(Susp,F/A,SuspDetachment),
1928 ( chr_pp_flag(debugable,on) ->
1929 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
1930 DebugTry = 'chr debug_event'( try([Susp|Susps1],Susps2,DebugGuard,DebugBody)),
1931 DebugApply = 'chr debug_event'(apply([Susp|Susps1],Susps2,DebugGuard,DebugBody))
1932 ;
1933 DebugTry = true,
1934 DebugApply = true
1935 ),
1937 Clause = ( ClauseHead :-
1938 FirstMatching,
1939 RescheduledTest,
1940 DebugTry,
1941 !,
1942 DebugApply,
1943 SuspsDetachments,
1944 SuspDetachment,
1945 BodyCopy
1946 ),
1947 L = [Clause | T].
1949 split_by_ids([],[],_,[],[]).
1950 split_by_ids([I|Is],[S|Ss],I1s,S1s,S2s) :-
1951 ( memberchk_eq(I,I1s) ->
1952 S1s = [S | R1s],
1953 S2s = R2s
1954 ;
1955 S1s = R1s,
1956 S2s = [S | R2s]
1957 ),
1958 split_by_ids(Is,Ss,I1s,R1s,R2s).
1960 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1963 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1964 %% ____ _ _ _ ____
1965 %% / ___|(_)_ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __ |___ \
1966 %% \___ \| | '_ ` _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \ __) |
1967 %% ___) | | | | | | | |_) | (_| | (_| | (_| | |_| | (_) | | | | / __/
1968 %% |____/|_|_| |_| |_| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_| |_____|
1969 %% |_| |___/
1971 %% Genereate prelude + worker predicate
1972 %% prelude calls worker
1973 %% worker iterates over one type of removed constraints
1974 simpagation_head2_code(Head2,RestHeads2,RestIDs,PragmaRule,FA,Id,L,T) :-
1975 PragmaRule = pragma(Rule,ids(IDs1,_),Pragmas,_Name),
1976 Rule = rule(Heads1,_,Guard,Body),
1977 reorder_heads(Head2,Heads1,IDs1,[Head1|RestHeads1],[ID1|RestIDs1]), % Heads1 = [Head1|RestHeads1],
1978 % IDs1 = [ID1|RestIDs1],
1979 simpagation_head2_prelude(Head2,Head1,[RestHeads2,Heads1,Guard,Body],FA,Id,L,L1),
1980 extend_id(Id,Id2),
1981 simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,RestIDs1,RestHeads2,RestIDs,Rule,Pragmas,FA,Id2,L1,T).
1983 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
1984 simpagation_head2_prelude(Head,Head1,Rest,F/A,Id1,L,T) :-
1985 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
1986 build_head(F,A,Id1,VarsSusp,ClauseHead),
1987 head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
1989 passive_head_via(Head1,[Head],[],VarDict,ModConstraintsGoal,Attr,AttrDict),
1990 instantiate_pattern_goals(AttrDict),
1991 get_max_constraint_index(N),
1992 ( N == 1 ->
1993 AllSusps = Attr
1994 ;
1995 functor(Head1,F1,A1),
1996 get_constraint_index(F1/A1,Pos),
1997 make_attr(N,_,SuspsList,Attr),
1998 nth(Pos,SuspsList,AllSusps)
1999 ),
2001 ( Id1 == [0] -> % create suspension
2002 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,ConstraintAllocationGoal)
2003 ; ConstraintAllocationGoal = true
2004 ),
2006 extend_id(Id1,DelegateId),
2007 extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
2008 append([AllSusps|VarsSusp],ExtraVars,DelegateCallVars),
2009 build_head(F,A,DelegateId,DelegateCallVars,Delegate),
2011 PreludeClause =
2012 ( ClauseHead :-
2013 FirstMatching,
2014 ModConstraintsGoal,
2015 !,
2016 ConstraintAllocationGoal,
2017 Delegate
2018 ),
2019 L = [PreludeClause|T].
2021 extra_active_delegate_variables(Term,Terms,VarDict,Vars) :-
2022 Term =.. [_|Args],
2023 delegate_variables(Term,Terms,VarDict,Args,Vars).
2025 passive_delegate_variables(Term,PrevTerms,NextTerms,VarDict,Vars) :-
2026 term_variables(PrevTerms,PrevVars),
2027 delegate_variables(Term,NextTerms,VarDict,PrevVars,Vars).
2029 delegate_variables(Term,Terms,VarDict,PrevVars,Vars) :-
2030 term_variables(Term,V1),
2031 term_variables(Terms,V2),
2032 intersect_eq(V1,V2,V3),
2033 list_difference_eq(V3,PrevVars,V4),
2034 translate(V4,VarDict,Vars).
2037 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2038 simpagation_head2_worker(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,FA,Id,L,T) :-
2039 Rule = rule(_,_,Guard,Body),
2040 simpagation_head2_worker_end(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],FA,Id,L,L1),
2041 simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,FA,Id,L1,T).
2043 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2044 simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Rule,Pragmas,F/A,Id,L,T) :-
2045 gen_var(OtherSusp),
2046 gen_var(OtherSusps),
2048 head_info(Head2,A,_Vars,Susp,VarsSusp,Head2Pairs),
2049 head_arg_matches(Head2Pairs,[],_,VarDict1),
2051 Rule = rule(_,_,Guard,Body),
2052 extra_active_delegate_variables(Head2,[Head1,RestHeads1,RestHeads2,Guard,Body],VarDict1,ExtraVars),
2053 append([[OtherSusp|OtherSusps]|VarsSusp],ExtraVars,HeadVars),
2054 build_head(F,A,Id,HeadVars,ClauseHead),
2056 functor(Head1,_OtherF,OtherA),
2057 head_info(Head1,OtherA,OtherVars,_,_,Head1Pairs),
2058 head_arg_matches(Head1Pairs,VarDict1,FirstMatching,VarDict2),
2060 OtherSuspension =.. [suspension,_,OtherState,_,_,_,_|OtherVars],
2061 create_get_mutable(active,OtherState,GetMutable),
2062 IteratorSuspTest =
2063 ( OtherSusp = OtherSuspension,
2064 GetMutable
2065 ),
2067 ( (RestHeads1 \== [] ; RestHeads2 \== []) ->
2068 append(RestHeads1,RestHeads2,RestHeads),
2069 append(IDs1,IDs2,IDs),
2070 reorder_heads(Head1-Head2,RestHeads,IDs,NRestHeads,NIDs),
2071 rest_heads_retrieval_and_matching(NRestHeads,NIDs,Pragmas,[Head1,Head2],RestSuspsRetrieval,Susps,VarDict2,VarDict,[Head1],[OtherSusp],[]),
2072 split_by_ids(NIDs,Susps,IDs1,Susps1,Susps2)
2073 ; RestSuspsRetrieval = [],
2074 Susps1 = [],
2075 Susps2 = [],
2076 VarDict = VarDict2
2077 ),
2079 gen_uncond_susps_detachments([OtherSusp | Susps1],[Head1|RestHeads1],Susps1Detachments),
2081 append([OtherSusps|VarsSusp],ExtraVars,RecursiveVars),
2082 build_head(F,A,Id,RecursiveVars,RecursiveCall),
2083 append([[]|VarsSusp],ExtraVars,RecursiveVars2),
2084 build_head(F,A,Id,RecursiveVars2,RecursiveCall2),
2086 guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy),
2087 guard_via_reschedule(RestSuspsRetrieval,GuardCopyList,v(ClauseHead,IteratorSuspTest,FirstMatching),RescheduledTest),
2088 ( BodyCopy \== true ->
2089 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
2090 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
2091 gen_state_cond_call(Susp,A,RecursiveCall2,Generation,ConditionalRecursiveCall2)
2092 ; Attachment = true,
2093 ConditionalRecursiveCall = RecursiveCall,
2094 ConditionalRecursiveCall2 = RecursiveCall2
2095 ),
2097 ( chr_pp_flag(debugable,on) ->
2098 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2099 DebugTry = 'chr debug_event'( try([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody)),
2100 DebugApply = 'chr debug_event'(apply([OtherSusp|Susps1],[Susp|Susps2],DebugGuard,DebugBody))
2101 ;
2102 DebugTry = true,
2103 DebugApply = true
2104 ),
2106 ( member(unique(ID1,UniqueKeys), Pragmas),
2107 check_unique_keys(UniqueKeys,VarDict1) ->
2108 Clause =
2109 ( ClauseHead :-
2110 ( IteratorSuspTest,
2111 FirstMatching ->
2112 ( RescheduledTest,
2113 DebugTry ->
2114 DebugApply,
2115 Susps1Detachments,
2116 Attachment,
2117 BodyCopy,
2118 ConditionalRecursiveCall2
2119 ;
2120 RecursiveCall2
2121 )
2122 ;
2123 RecursiveCall
2124 )
2125 )
2126 ;
2127 Clause =
2128 ( ClauseHead :-
2129 ( IteratorSuspTest,
2130 FirstMatching,
2131 RescheduledTest,
2132 DebugTry ->
2133 DebugApply,
2134 Susps1Detachments,
2135 Attachment,
2136 BodyCopy,
2137 ConditionalRecursiveCall
2138 ;
2139 RecursiveCall
2140 )
2141 )
2142 ),
2143 L = [Clause | T].
2145 gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
2146 length(Args,N),
2147 Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
2148 create_get_mutable(active,State,GetState),
2149 create_get_mutable(Generation,NewGeneration,GetGeneration),
2150 ConditionalCall =
2151 ( Susp = Suspension,
2152 GetState,
2153 GetGeneration ->
2154 'chr update_mutable'(inactive,State),
2155 Call
2156 ; true
2157 ).
2159 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2160 simpagation_head2_worker_end(Head,Rest,F/A,Id,L,T) :-
2161 head_info(Head,A,_Vars,_Susp,VarsSusp,Pairs),
2162 head_arg_matches(Pairs,[],_,VarDict),
2163 extra_active_delegate_variables(Head,Rest,VarDict,ExtraVars),
2164 append([[]|VarsSusp],ExtraVars,HeadVars),
2165 build_head(F,A,Id,HeadVars,ClauseHead),
2166 next_id(Id,ContinuationId),
2167 build_head(F,A,ContinuationId,VarsSusp,ContinuationHead),
2168 Clause = ( ClauseHead :- ContinuationHead ),
2169 L = [Clause | T].
2171 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2174 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2175 %% ____ _ _
2176 %% | _ \ _ __ ___ _ __ __ _ __ _ __ _| |_(_) ___ _ __
2177 %% | |_) | '__/ _ \| '_ \ / _` |/ _` |/ _` | __| |/ _ \| '_ \
2178 %% | __/| | | (_) | |_) | (_| | (_| | (_| | |_| | (_) | | | |
2179 %% |_| |_| \___/| .__/ \__,_|\__, |\__,_|\__|_|\___/|_| |_|
2180 %% |_| |___/
2182 propagation_code(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
2183 ( RestHeads == [] ->
2184 propagation_single_headed(Head,Rule,RuleNb,FA,Id,L,T)
2185 ;
2186 propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T)
2187 ).
2188 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2189 %% Single headed propagation
2190 %% everything in a single clause
2191 propagation_single_headed(Head,Rule,RuleNb,F/A,Id,L,T) :-
2192 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
2193 build_head(F,A,Id,VarsSusp,ClauseHead),
2195 inc_id(Id,NextId),
2196 build_head(F,A,NextId,VarsSusp,NextHead),
2198 NextCall = NextHead,
2200 head_arg_matches(HeadPairs,[],HeadMatching,VarDict),
2201 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
2202 ( Id == [0] ->
2203 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,Allocation),
2204 Allocation1 = Allocation
2205 ;
2206 Allocation1 = true
2207 ),
2208 gen_uncond_attach_goal(F/A,Susp,Attachment,Generation),
2210 gen_state_cond_call(Susp,A,NextCall,Generation,ConditionalNextCall),
2212 ( chr_pp_flag(debugable,on) ->
2213 Rule = rule(_,_,Guard,Body),
2214 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2215 DebugTry = 'chr debug_event'( try([],[Susp],DebugGuard,DebugBody)),
2216 DebugApply = 'chr debug_event'(apply([],[Susp],DebugGuard,DebugBody))
2217 ;
2218 DebugTry = true,
2219 DebugApply = true
2220 ),
2222 Clause = (
2223 ClauseHead :-
2224 HeadMatching,
2225 Allocation1,
2226 'chr novel_production'(Susp,RuleNb), % optimisation of t(RuleNb,Susp)
2227 GuardCopy,
2228 DebugTry,
2229 !,
2230 DebugApply,
2231 'chr extend_history'(Susp,RuleNb),
2232 Attachment,
2233 BodyCopy,
2234 ConditionalNextCall
2235 ),
2236 L = [Clause | T].
2238 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2239 %% multi headed propagation
2240 %% prelude + predicates to accumulate the necessary combinations of suspended
2241 %% constraints + predicate to execute the body
2242 propagation_multi_headed(Head,RestHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
2243 RestHeads = [First|Rest],
2244 propagation_prelude(Head,RestHeads,Rule,FA,Id,L,L1),
2245 extend_id(Id,ExtendedId),
2246 propagation_nested_code(Rest,[First,Head],Rule,RuleNb,RestHeadNb,FA,ExtendedId,L1,T).
2248 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2249 propagation_prelude(Head,[First|Rest],Rule,F/A,Id,L,T) :-
2250 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs),
2251 build_head(F,A,Id,VarsSusp,PreludeHead),
2252 head_arg_matches(HeadPairs,[],FirstMatching,VarDict),
2253 Rule = rule(_,_,Guard,Body),
2254 extra_active_delegate_variables(Head,[First,Rest,Guard,Body],VarDict,ExtraVars),
2256 passive_head_via(First,[Head],[],VarDict,FirstSuspGoal,Attr,AttrDict),
2257 instantiate_pattern_goals(AttrDict),
2258 get_max_constraint_index(N),
2259 ( N == 1 ->
2260 Susps = Attr
2261 ;
2262 functor(First,FirstFct,FirstAty),
2263 make_attr(N,_Mask,SuspsList,Attr),
2264 get_constraint_index(FirstFct/FirstAty,Pos),
2265 nth(Pos,SuspsList,Susps)
2266 ),
2268 ( Id == [0] ->
2269 gen_cond_allocation(Vars,Susp,F/A,VarsSusp,CondAllocation)
2270 ; CondAllocation = true
2271 ),
2273 extend_id(Id,NestedId),
2274 append([Susps|VarsSusp],ExtraVars,NestedVars),
2275 build_head(F,A,NestedId,NestedVars,NestedHead),
2276 NestedCall = NestedHead,
2278 Prelude = (
2279 PreludeHead :-
2280 FirstMatching,
2281 FirstSuspGoal,
2282 !,
2283 CondAllocation,
2284 NestedCall
2285 ),
2286 L = [Prelude|T].
2288 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2289 propagation_nested_code([],[CurrentHead|PreHeads],Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
2290 propagation_end([CurrentHead|PreHeads],[],Rule,FA,Id,L,L1),
2291 propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L1,T).
2293 propagation_nested_code([Head|RestHeads],PreHeads,Rule,RuleNb,RestHeadNb,FA,Id,L,T) :-
2294 propagation_end(PreHeads,[Head|RestHeads],Rule,FA,Id,L,L1),
2295 propagation_accumulator([Head|RestHeads],PreHeads,Rule,FA,Id,L1,L2),
2296 inc_id(Id,IncId),
2297 propagation_nested_code(RestHeads,[Head|PreHeads],Rule,RuleNb,RestHeadNb,FA,IncId,L2,T).
2299 propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,F/A,Id,L,T) :-
2300 Rule = rule(_,_,Guard,Body),
2301 get_prop_inner_loop_vars(PreHeads,[CurrentHead,Guard,Body],PreVarsAndSusps,VarDict1,Susp,RestSusps),
2302 gen_var(OtherSusp),
2303 gen_var(OtherSusps),
2304 functor(CurrentHead,_OtherF,OtherA),
2305 gen_vars(OtherA,OtherVars),
2306 Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
2307 create_get_mutable(active,State,GetMutable),
2308 CurrentSuspTest = (
2309 OtherSusp = Suspension,
2310 GetMutable
2311 ),
2312 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
2313 build_head(F,A,Id,ClauseVars,ClauseHead),
2314 RecursiveVars = [OtherSusps|PreVarsAndSusps],
2315 build_head(F,A,Id,RecursiveVars,RecursiveHead),
2316 RecursiveCall = RecursiveHead,
2317 CurrentHead =.. [_|OtherArgs],
2318 pairup(OtherArgs,OtherVars,OtherPairs),
2319 head_arg_matches(OtherPairs,VarDict1,Matching,VarDict),
2321 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,RestSusps,DiffSuspGoals),
2323 guard_body_copies(Rule,VarDict,GuardCopy,BodyCopy),
2324 gen_uncond_attach_goal(F/A,Susp,Attach,Generation),
2325 gen_state_cond_call(Susp,A,RecursiveCall,Generation,ConditionalRecursiveCall),
2327 history_susps(RestHeadNb,[OtherSusp|RestSusps],Susp,[],HistorySusps),
2328 bagof('chr novel_production'(X,Y),( member(X,HistorySusps), Y = TupleVar) ,NovelProductionsList),
2329 list2conj(NovelProductionsList,NovelProductions),
2330 Tuple =.. [t,RuleNb|HistorySusps],
2332 ( chr_pp_flag(debugable,on) ->
2333 Rule = rule(_,_,Guard,Body),
2334 my_term_copy(Guard - Body, VarDict, _, DebugGuard - DebugBody),
2335 DebugTry = 'chr debug_event'( try([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody)),
2336 DebugApply = 'chr debug_event'(apply([],[Susp,OtherSusp|RestSusps],DebugGuard,DebugBody))
2337 ;
2338 DebugTry = true,
2339 DebugApply = true
2340 ),
2342 Clause = (
2343 ClauseHead :-
2344 ( CurrentSuspTest,
2345 DiffSuspGoals,
2346 Matching,
2347 TupleVar = Tuple,
2348 NovelProductions,
2349 GuardCopy,
2350 DebugTry ->
2351 DebugApply,
2352 'chr extend_history'(Susp,TupleVar),
2353 Attach,
2354 BodyCopy,
2355 ConditionalRecursiveCall
2356 ; RecursiveCall
2357 )
2358 ),
2359 L = [Clause|T].
2362 history_susps(Count,OtherSusps,Susp,Acc,HistorySusps) :-
2363 ( Count == 0 ->
2364 reverse(OtherSusps,ReversedSusps),
2365 append(ReversedSusps,[Susp|Acc],HistorySusps)
2366 ;
2367 OtherSusps = [OtherSusp|RestOtherSusps],
2368 NCount is Count - 1,
2369 history_susps(NCount,RestOtherSusps,Susp,[OtherSusp|Acc],HistorySusps)
2370 ).
2373 get_prop_inner_loop_vars([Head],Terms,HeadVars,VarDict,Susp,[]) :-
2374 !,
2375 functor(Head,_F,A),
2376 head_info(Head,A,_Vars,Susp,VarsSusp,Pairs),
2377 head_arg_matches(Pairs,[],_,VarDict),
2378 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
2379 append(VarsSusp,ExtraVars,HeadVars).
2380 get_prop_inner_loop_vars([Head|Heads],Terms,VarsSusps,NVarDict,MainSusp,[Susp|RestSusps]) :-
2381 get_prop_inner_loop_vars(Heads,[Head|Terms],RestVarsSusp,VarDict,MainSusp,RestSusps),
2382 functor(Head,_F,A),
2383 gen_var(Susps),
2384 head_info(Head,A,_Vars,Susp,_VarsSusp,Pairs),
2385 head_arg_matches(Pairs,VarDict,_,NVarDict),
2386 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
2387 append(HeadVars,[Susp,Susps|RestVarsSusp],VarsSusps).
2389 propagation_end([CurrentHead|PrevHeads],NextHeads,Rule,F/A,Id,L,T) :-
2390 Rule = rule(_,_,Guard,Body),
2391 gen_var_susp_list_for(PrevHeads,[CurrentHead,NextHeads,Guard,Body],_,VarsAndSusps,AllButFirst,FirstSusp),
2393 Vars = [ [] | VarsAndSusps],
2395 build_head(F,A,Id,Vars,Head),
2397 ( Id = [0|_] ->
2398 next_id(Id,PrevId),
2399 PrevVarsAndSusps = AllButFirst
2400 ;
2401 dec_id(Id,PrevId),
2402 PrevVarsAndSusps = [FirstSusp|AllButFirst]
2403 ),
2405 build_head(F,A,PrevId,PrevVarsAndSusps,PrevHead),
2406 PredecessorCall = PrevHead,
2408 Clause = (
2409 Head :-
2410 PredecessorCall
2411 ),
2412 L = [Clause | T].
2414 gen_var_susp_list_for([Head],Terms,VarDict,HeadVars,VarsSusp,Susp) :-
2415 !,
2416 functor(Head,_F,A),
2417 head_info(Head,A,_Vars,Susp,VarsSusp,HeadPairs),
2418 head_arg_matches(HeadPairs,[],_,VarDict),
2419 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
2420 append(VarsSusp,ExtraVars,HeadVars).
2421 gen_var_susp_list_for([Head|Heads],Terms,NVarDict,VarsSusps,Rest,Susps) :-
2422 gen_var_susp_list_for(Heads,[Head|Terms],VarDict,Rest,_,_),
2423 functor(Head,_F,A),
2424 gen_var(Susps),
2425 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
2426 head_arg_matches(HeadPairs,VarDict,_,NVarDict),
2427 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
2428 append(HeadVars,[Susp,Susps|Rest],VarsSusps).
2430 propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,L,T) :-
2431 Rule = rule(_,_,Guard,Body),
2432 pre_vars_and_susps(PreHeads,[CurrentHead,NextHead,RestHeads,Guard,Body],PreVarsAndSusps,VarDict,PreSusps),
2433 gen_var(OtherSusps),
2434 functor(CurrentHead,_OtherF,OtherA),
2435 gen_vars(OtherA,OtherVars),
2436 head_info(CurrentHead,OtherA,OtherVars,OtherSusp,_VarsSusp,HeadPairs),
2437 head_arg_matches(HeadPairs,VarDict,FirstMatching,VarDict1),
2439 OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
2441 different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
2442 create_get_mutable(active,State,GetMutable),
2443 CurrentSuspTest = (
2444 OtherSusp = OtherSuspension,
2445 GetMutable,
2446 DiffSuspGoals,
2447 FirstMatching
2448 ),
2449 functor(NextHead,NextF,NextA),
2450 passive_head_via(NextHead,[CurrentHead|PreHeads],[],VarDict1,NextSuspGoal,Attr,AttrDict),
2451 instantiate_pattern_goals(AttrDict),
2452 get_max_constraint_index(N),
2453 ( N == 1 ->
2454 NextSusps = Attr
2455 ;
2456 get_constraint_index(NextF/NextA,Position),
2457 make_attr(N,_Mask,SuspsList,Attr),
2458 nth(Position,SuspsList,NextSusps)
2459 ),
2460 inc_id(Id,NestedId),
2461 ClauseVars = [[OtherSusp|OtherSusps]|PreVarsAndSusps],
2462 build_head(F,A,Id,ClauseVars,ClauseHead),
2463 passive_delegate_variables(CurrentHead,PreHeads,[NextHead,RestHeads,Guard,Body],VarDict1,CurrentHeadVars),
2464 append([NextSusps|CurrentHeadVars],[OtherSusp,OtherSusps|PreVarsAndSusps],NestedVars),
2465 build_head(F,A,NestedId,NestedVars,NestedHead),
2467 RecursiveVars = [OtherSusps|PreVarsAndSusps],
2468 build_head(F,A,Id,RecursiveVars,RecursiveHead),
2469 Clause = (
2470 ClauseHead :-
2471 ( CurrentSuspTest,
2472 NextSuspGoal
2473 ->
2474 NestedHead
2475 ; RecursiveHead
2476 )
2477 ),
2478 L = [Clause|T].
2480 pre_vars_and_susps([Head],Terms,HeadVars,VarDict,[]) :-
2481 !,
2482 functor(Head,_F,A),
2483 head_info(Head,A,_Vars,_Susp,VarsSusp,HeadPairs),
2484 head_arg_matches(HeadPairs,[],_,VarDict),
2485 extra_active_delegate_variables(Head,Terms,VarDict,ExtraVars),
2486 append(VarsSusp,ExtraVars,HeadVars).
2487 pre_vars_and_susps([Head|Heads],Terms,NVSs,NVarDict,[Susp|Susps]) :-
2488 pre_vars_and_susps(Heads,[Head|Terms],VSs,VarDict,Susps),
2489 functor(Head,_F,A),
2490 gen_var(NextSusps),
2491 head_info(Head,A,_Vars,Susp,_VarsSusp,HeadPairs),
2492 head_arg_matches(HeadPairs,VarDict,_,NVarDict),
2493 passive_delegate_variables(Head,Heads,Terms,NVarDict,HeadVars),
2494 append(HeadVars,[Susp,NextSusps|VSs],NVSs).
2496 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2498 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2499 %% ____ _ _ _ _
2500 %% | _ \ __ _ ___ ___(_)_ _____ | | | | ___ __ _ __| |
2501 %% | |_) / _` / __/ __| \ \ / / _ \ | |_| |/ _ \/ _` |/ _` |
2502 %% | __/ (_| \__ \__ \ |\ V / __/ | _ | __/ (_| | (_| |
2503 %% |_| \__,_|___/___/_| \_/ \___| |_| |_|\___|\__,_|\__,_|
2504 %%
2505 %% ____ _ _ _
2506 %% | _ \ ___| |_ _ __(_) _____ ____ _| |
2507 %% | |_) / _ \ __| '__| |/ _ \ \ / / _` | |
2508 %% | _ < __/ |_| | | | __/\ V / (_| | |
2509 %% |_| \_\___|\__|_| |_|\___| \_/ \__,_|_|
2510 %%
2511 %% ____ _ _
2512 %% | _ \ ___ ___ _ __ __| | ___ _ __(_)_ __ __ _
2513 %% | |_) / _ \/ _ \| '__/ _` |/ _ \ '__| | '_ \ / _` |
2514 %% | _ < __/ (_) | | | (_| | __/ | | | | | | (_| |
2515 %% |_| \_\___|\___/|_| \__,_|\___|_| |_|_| |_|\__, |
2516 %% |___/
2518 reorder_heads(Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
2519 ( chr_pp_flag(reorder_heads,on) ->
2520 reorder_heads_main(Head,RestHeads,RestIDs,NRestHeads,NRestIDs)
2521 ;
2522 NRestHeads = RestHeads,
2523 NRestIDs = RestIDs
2524 ).
2526 reorder_heads_main(Head,RestHeads,RestIDs,NRestHeads,NRestIDs) :-
2527 term_variables(Head,KnownVars),
2528 reorder_heads1(RestHeads,RestIDs,KnownVars,NRestHeads,NRestIDs).
2530 reorder_heads1(Heads,IDs,KnownVars,NHeads,NIDs) :-
2531 ( Heads == [] ->
2532 NHeads = [],
2533 NIDs = []
2534 ;
2535 NHeads = [BestHead|BestTail],
2536 NIDs = [BestID | BestIDs],
2537 select_best_head(Heads,IDs,KnownVars,BestHead,BestID,RestHeads,RestIDs,NKnownVars),
2538 reorder_heads1(RestHeads,RestIDs,NKnownVars,BestTail,BestIDs)
2539 ).
2541 select_best_head(Heads,IDs,KnownVars,BestHead,BestID,RestHeads,RestIDs,NKnownVars) :-
2542 ( bagof(tuple(Score,Head,ID,Rest,RIDs), (
2543 select2(Head,ID, Heads,IDs,Rest,RIDs) ,
2544 order_score(Head,KnownVars,Rest,Score)
2545 ),
2546 Scores) -> true ; Scores = []),
2547 max_go_list(Scores,tuple(_,BestHead,BestID,RestHeads,RestIDs)),
2548 term_variables(BestHead,BestHeadVars),
2549 ( setof(V, (
2550 member(V,BestHeadVars),
2551 \+ memberchk_eq(V,KnownVars)
2552 ),
2553 NewVars) -> true ; NewVars = []),
2554 append(NewVars,KnownVars,NKnownVars).
2556 reorder_heads(Head,RestHeads,NRestHeads) :-
2557 term_variables(Head,KnownVars),
2558 reorder_heads1(RestHeads,KnownVars,NRestHeads).
2560 reorder_heads1(Heads,KnownVars,NHeads) :-
2561 ( Heads == [] ->
2562 NHeads = []
2563 ;
2564 NHeads = [BestHead|BestTail],
2565 select_best_head(Heads,KnownVars,BestHead,RestHeads,NKnownVars),
2566 reorder_heads1(RestHeads,NKnownVars,BestTail)
2567 ).
2569 select_best_head(Heads,KnownVars,BestHead,RestHeads,NKnownVars) :-
2570 ( bagof(tuple(Score,Head,Rest), (
2571 select(Head,Heads,Rest) ,
2572 order_score(Head,KnownVars,Rest,Score)
2573 ),
2574 Scores) -> true ; Scores = []),
2575 max_go_list(Scores,tuple(_,BestHead,RestHeads)),
2576 term_variables(BestHead,BestHeadVars),
2577 ( setof(V, (
2578 member(V,BestHeadVars),
2579 \+ memberchk_eq(V,KnownVars)
2580 ),
2581 NewVars) -> true ; NewVars = []),
2582 append(NewVars,KnownVars,NKnownVars).
2584 order_score(Head,KnownVars,Rest,Score) :-
2585 term_variables(Head,HeadVars),
2586 term_variables(Rest,RestVars),
2587 order_score_vars(HeadVars,KnownVars,RestVars,0,Score).
2589 order_score_vars([],_,_,Score,NScore) :-
2590 ( Score == 0 ->
2591 NScore = 99999
2592 ;
2593 NScore = Score
2594 ).
2595 order_score_vars([V|Vs],KnownVars,RestVars,Score,NScore) :-
2596 ( memberchk_eq(V,KnownVars) ->
2597 TScore is Score + 1
2598 ; memberchk_eq(V,RestVars) ->
2599 TScore is Score + 1
2600 ;
2601 TScore = Score
2602 ),
2603 order_score_vars(Vs,KnownVars,RestVars,TScore,NScore).
2605 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2606 %% ___ _ _ _
2607 %% |_ _|_ __ | (_)_ __ (_)_ __ __ _
2608 %% | || '_ \| | | '_ \| | '_ \ / _` |
2609 %% | || | | | | | | | | | | | | (_| |
2610 %% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
2611 %% |___/
2613 create_get_mutable(V,M,GM) :-
2614 GM = (M = mutable(V)).
2615 % GM = 'chr get_mutable'(V,M)
2616 %( ground(V) ->
2617 % GM = (M == mutable(V))
2618 %;
2619 % GM = (M = mutable(V))
2620 %).
2622 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2624 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2625 %% ____ _ ____ _ _
2626 %% / ___|___ __| | ___ / ___| | ___ __ _ _ __ (_)_ __ __ _
2627 %% | | / _ \ / _` |/ _ \ | | | |/ _ \/ _` | '_ \| | '_ \ / _` |
2628 %% | |__| (_) | (_| | __/ | |___| | __/ (_| | | | | | | | | (_| |
2629 %% \____\___/ \__,_|\___| \____|_|\___|\__,_|_| |_|_|_| |_|\__, |
2630 %% |___/
2631 %%
2632 %% removes redundant 'true's and other trivial but potentially non-free constructs
2634 clean_clauses([],[]).
2635 clean_clauses([C|Cs],[NC|NCs]) :-
2636 clean_clause(C,NC),
2637 clean_clauses(Cs,NCs).
2639 clean_clause(Clause,NClause) :-
2640 ( Clause = (Head :- Body) ->
2641 clean_goal(Body,NBody),
2642 ( NBody == true ->
2643 NClause = Head
2644 ;
2645 NClause = (Head :- NBody)
2646 )
2647 ;
2648 NClause = Clause
2649 ).
2651 clean_goal(Goal,NGoal) :-
2652 var(Goal), !,
2653 NGoal = Goal.
2654 clean_goal((G1,G2),NGoal) :-
2655 !,
2656 clean_goal(G1,NG1),
2657 clean_goal(G2,NG2),
2658 ( NG1 == true ->
2659 NGoal = NG2
2660 ; NG2 == true ->
2661 NGoal = NG1
2662 ;
2663 NGoal = (NG1,NG2)
2664 ).
2665 clean_goal((If -> Then ; Else),NGoal) :-
2666 !,
2667 clean_goal(If,NIf),
2668 ( NIf == true ->
2669 clean_goal(Then,NThen),
2670 NGoal = NThen
2671 ; NIf == fail ->
2672 clean_goal(Else,NElse),
2673 NGoal = NElse
2674 ;
2675 clean_goal(Then,NThen),
2676 clean_goal(Else,NElse),
2677 NGoal = (NIf -> NThen; NElse)
2678 ).
2679 clean_goal((G1 ; G2),NGoal) :-
2680 !,
2681 clean_goal(G1,NG1),
2682 clean_goal(G2,NG2),
2683 ( NG1 == fail ->
2684 NGoal = NG2
2685 ; NG2 == fail ->
2686 NGoal = NG1
2687 ;
2688 NGoal = (NG1 ; NG2)
2689 ).
2690 clean_goal(once(G),NGoal) :-
2691 !,
2692 clean_goal(G,NG),
2693 ( NG == true ->
2694 NGoal = true
2695 ; NG == fail ->
2696 NGoal = fail
2697 ;
2698 NGoal = once(NG)
2699 ).
2700 clean_goal((G1 -> G2),NGoal) :-
2701 !,
2702 clean_goal(G1,NG1),
2703 ( NG1 == true ->
2704 clean_goal(G2,NGoal)
2705 ; NG1 == fail ->
2706 NGoal = fail
2707 ;
2708 clean_goal(G2,NG2),
2709 NGoal = (NG1 -> NG2)
2710 ).
2711 clean_goal(Goal,Goal).
2712 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2714 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2715 %% _ _ _ _ _ _ _
2716 %% | | | | |_(_) (_) |_ _ _
2717 %% | | | | __| | | | __| | | |
2718 %% | |_| | |_| | | | |_| |_| |
2719 %% \___/ \__|_|_|_|\__|\__, |
2720 %% |___/
2722 gen_var(_).
2723 gen_vars(N,Xs) :-
2724 length(Xs,N).
2726 head_info(Head,A,Vars,Susp,VarsSusp,HeadPairs) :-
2727 vars_susp(A,Vars,Susp,VarsSusp),
2728 Head =.. [_|Args],
2729 pairup(Args,Vars,HeadPairs).
2731 inc_id([N|Ns],[O|Ns]) :-
2732 O is N + 1.
2733 dec_id([N|Ns],[M|Ns]) :-
2734 M is N - 1.
2736 extend_id(Id,[0|Id]).
2738 next_id([_,N|Ns],[O|Ns]) :-
2739 O is N + 1.
2741 build_head(F,A,Id,Args,Head) :-
2742 buildName(F,A,Id,Name),
2743 Head =.. [Name|Args].
2745 buildName(Fct,Aty,List,Result) :-
2746 atom_concat(Fct, (/) ,FctSlash),
2747 atom_concat(FctSlash,Aty,FctSlashAty),
2748 buildName_(List,FctSlashAty,Result).
2750 buildName_([],Name,Name).
2751 buildName_([N|Ns],Name,Result) :-
2752 buildName_(Ns,Name,Name1),
2753 atom_concat(Name1,'__',NameDash), % '_' is a char :-(
2754 atom_concat(NameDash,N,Result).
2756 vars_susp(A,Vars,Susp,VarsSusp) :-
2757 length(Vars,A),
2758 append(Vars,[Susp],VarsSusp).
2760 make_attr(N,Mask,SuspsList,Attr) :-
2761 length(SuspsList,N),
2762 Attr =.. [v,Mask|SuspsList].
2764 or_pattern(Pos,Pat) :-
2765 Pow is Pos - 1,
2766 Pat is 1 << Pow. % was 2 ** X
2768 and_pattern(Pos,Pat) :-
2769 X is Pos - 1,
2770 Y is 1 << X, % was 2 ** X
2771 Pat is -(Y + 1).
2773 conj2list(Conj,L) :- %% transform conjunctions to list
2774 conj2list(Conj,L,[]).
2776 conj2list(Conj,L,T) :-
2777 Conj = (G1,G2), !,
2778 conj2list(G1,L,T1),
2779 conj2list(G2,T1,T).
2780 conj2list(G,[G | T],T).
2782 list2conj([],true).
2783 list2conj([G],X) :- !, X = G.
2784 list2conj([G|Gs],C) :-
2785 ( G == true -> %% remove some redundant trues
2786 list2conj(Gs,C)
2787 ;
2788 C = (G,R),
2789 list2conj(Gs,R)
2790 ).
2792 atom_concat_list([X],X) :- ! .
2793 atom_concat_list([X|Xs],A) :-
2794 atom_concat_list(Xs,B),
2795 atom_concat(X,B,A).
2797 set_elems([],_).
2798 set_elems([X|Xs],X) :-
2799 set_elems(Xs,X).
2801 member2([X|_],[Y|_],X-Y).
2802 member2([_|Xs],[_|Ys],P) :-
2803 member2(Xs,Ys,P).
2805 select2(X, Y, [X|Xs], [Y|Ys], Xs, Ys).
2806 select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :-
2807 select2(X, Y, Xs, Ys, NXs, NYs).
2809 pair_all_with([],_,[]).
2810 pair_all_with([X|Xs],Y,[X-Y|Rest]) :-
2811 pair_all_with(Xs,Y,Rest).
2813 % chr_delete/3 is delete/3 from the GNU-Prolog library. It is
2814 % a local predicate to avoid the confusion around delete/3 in
2815 % various Prolog libraries.
2817 chr_delete([], _, []).
2818 chr_delete([H|T], X, L) :-
2819 ( H==X ->
2820 chr_delete(T, X, L)
2821 ; L=[H|RT],
2822 chr_delete(T, X, RT)
2823 ).
2825 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%