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