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