34
35:- module(argument_chains,
36 [gen_argument_chains/2,
37 argument_chain/2,
38 unlinked_arg/4,
39 arg_id/6,
40 lead_to_root/1,
41 linked_arg/2]). 42
43:- use_module(library(codewalk)). 44
45:- dynamic
46 clause_db/1,
47 unlinked_arg/4,
48 linked_arg/2,
49 arg_id/6,
50 counter/1. 51
52counter(1).
53
54count(Curr) :-
55 retract(counter(Curr)),
56 succ(Curr, Next),
57 assertz(counter(Next)).
58
59gen_argument_chains(AIL, Options1) :-
60 retractall(clause_db(_)),
61 retractall(arg_id(_, _, _, _, _, _)),
62 retractall(linked_arg(_, _)),
63 retractall(unlinked_arg(_, _, _, _)),
64 forall(member(AI, AIL),
65 record_linked(AI, 0 )),
66 merge_options(Options1, [source(false)], Options),
67 check_argument_fixpoint(0, Options).
68
69record_linked(IM:F/A-Pos, Stage) :-
70 functor(H, F, A),
71 record_linked(H, IM, _, Pos, Stage, 0).
72
73check_argument_fixpoint(Stage, Options) :-
74 succ(Stage, NStage),
75 findall(P, ( arg_id(H, M, Idx, Pos, Stage, _),
76 functor(H, F, A),
77 ( nonvar(Idx)
78 ->P = M:F/A-Idx/Pos
79 ; P = M:F/A-Pos
80 )
81 ), L),
82 length(L, N),
83 print_message(information, format("Stage ~w: Checking ~w argument positions", [NStage, N])),
84 walk_code([source(false), on_trace(propagate_argument_1(Stage, NStage))|Options]),
85 print_message(information, format("Stage ~w: Collecting unlinked arguments", [NStage])),
86 findall(Clause, retract(clause_db(Clause)), ClauseU),
87 sort(ClauseU, ClauseL),
88 walk_code([source(false),
89 clauses(ClauseL),
90 on_trace(propagate_argument_2(Stage, NStage))|Options]),
91 ( \+ arg_id(_, _, _, _, NStage, _)
92 ->true
93 ; check_argument_fixpoint(NStage, Options)
94 ).
95
96:- public propagate_argument_1/5. 97
98propagate_argument_1(Stage, NStage, MGoal, MCaller, From) :-
99 propagate_argument(argument_cond_1(Id), record_callee_1(Id), Stage, NStage, MGoal, MCaller, From).
100
101argument_cond_1(Id, Goal, M, Pos, Stage, _, _) :-
102 arg_id(Goal, M, _, Pos, Stage, Id),
103 \+ ( arg_id(Goal, M, _, Pos, PStage, _),
104 PStage < Stage
105 ).
106
107record_callee_1(Id, _, _, _, Ref, Id) :- assertz(clause_db(Ref)).
108
109:- public propagate_argument_2/5. 110
111propagate_argument_2(Stage, NStage, MGoal, MCaller, From) :-
112 propagate_argument(argument_cond_2, record_callee_2, Stage, NStage, MGoal, MCaller, From).
113
114argument_cond_2(Goal, M, Pos, _, NStage, CM:H-Idx/CPos) :-
115 \+ arg_id(Goal, M, _, Pos, _, _),
116 arg_id(H, CM, Idx, CPos, NStage, _).
117
118record_callee_2(Goal, M, Pos, _, Id) :-
119 functor(Goal, F, A),
120 functor(H, F, A),
121 record_unlinked(H, M, Pos, Id).
122
123record_unlinked(H, M, Pos, Id) :-
124 ( unlinked_arg(H, M, Pos, Id)
125 ->true
126 ; count(Id),
127 assertz(unlinked_arg(H, M, Pos, Id))
128 ).
129
130record_linked(H, M, Idx, Pos, Stage, Id) :-
131 ( arg_id(H, M, Idx, Pos, _, Ref)
132 ->true
133 ; ( retract(unlinked_arg(H, M, Pos, Ref))
134 ->true
135 ; count(Ref)
136 ),
137 assertz(arg_id(H, M, Idx, Pos, Stage, Ref))
138 ),
139 ( linked_arg(Id, Ref)
140 ->true
141 ; assertz(linked_arg(Id, Ref))
142 ).
143
144:- meta_predicate propagate_argument(6,5,?,?,?,?,?). 145propagate_argument(GoalCondition, RecordCallee, Stage, NStage, MGoal, MCaller, From) :-
146 MGoal = _:Goal,
147 compound(Goal),
148 predicate_property(MGoal, implementation_module(IM)),
149 MCaller = CM:Caller,
150 compound(Caller),
151 functor(Caller, F, A),
152 functor(H, F, A),
153 From = clause(CRef),
154 nth_clause(_, Idx, CRef),
155 arg(Pos, Goal, Arg),
156 \+ ( nonvar(Arg),
157 predicate_property(MGoal, meta_predicate(Meta)),
158 arg(Pos, Meta, 0 )
159 ),
160 call(GoalCondition, Goal, IM, Pos, Stage, NStage, CM:H-Idx/CPos),
161 arg(CPos, Caller, CArg),
162 \+ ( arg_id(H, CM, Idx, CPos, PStage, _),
163 PStage < NStage
164 ),
165 ( term_variables(CArg, CVL),
166 term_variables(Arg, VL),
167 member(C, CVL),
168 member(V, VL),
169 C==V
170 ->call(RecordCallee, Goal, IM, Pos, CRef, Id),
171 record_linked(H, CM, Idx, CPos, NStage, Id)
172 ),
173 fail.
174
175argument_chain(M:F/A-Idx/Pos, Chain) :-
176 functor(H, F, A),
177 arg_id(H, M, Idx, Pos, _, Id),
178 argument_chain_rec(Id, Chain).
179
180argument_chain_rec(Id, [M:F/A-Idx/Pos|Chain]) :-
181 arg_id(H, M, Idx, Pos, _, Id), !,
182 functor(H, F, A),
183 linked_arg(Ref, Id),
184 argument_chain_rec(Ref, Chain).
185argument_chain_rec(_, []).
186
187lead_to_root(Chain) :-
188 lead_to_root([], Chain).
189
190lead_to_root(Chain1, Chain) :-
191 linked_arg(0, Id),
192 lead_to_root(Id, Chain1, Chain).
193
194lead_to_root(Id, Chain, [Id|Chain]).
195lead_to_root(Id, Chain1, Chain) :-
196 linked_arg(Id, Id2),
197 \+ memberchk(Id2, [Id|Chain1 ]),
198 lead_to_root(Id2, [Id|Chain1 ], Chain)