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