1/************************************************************************* 2* * 3* YAP Prolog %W% %G% 4* * 5* Yap Prolog was developed at NCCUP - Universidade do Porto * 6* * 7* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 * 8* * 9************************************************************************** 10* * 11* File: setof.pl * 12* Last rev: * 13* mods: * 14* comments: set predicates * 15* * 16*************************************************************************/ 17 18% The "existential quantifier" symbol is only significant to bagof 19% and setof, which it stops binding the quantified variable. 20% op(200, xfy, ^) is defined during bootstrap. 21 22% this is used by the all predicate 23 24:- op(50,xfx,same). 25 26_^Goal :- 27 '$execute'(Goal). 28 29 30% findall/3 is a simplified version of bagof which has an implicit 31% existential quantifier on every variable. 32 33 34findall(Template, Generator, Answers) :- 35 ( '$partial_list_or_list'(Answers) -> 36 true 37 ; 38 '$do_error'(type_error(list,Answers), findall(Template, Generator, Answers)) 39 ), 40 '$findall'(Template, Generator, [], Answers). 41 42 43% If some answers have already been found 44findall(Template, Generator, Answers, SoFar) :- 45 '$findall'(Template, Generator, SoFar, Answers). 46 47% starts by calling the generator, 48% and recording the answers 49'$findall'(Template, Generator, SoFar, Answers) :- 50 nb:nb_queue(Ref), 51 ( 52 '$execute'(Generator), 53 nb:nb_queue_enqueue(Ref, Template), 54 fail 55 ; 56 nb:nb_queue_close(Ref, Answers, SoFar) 57 ). 58 59 60 61% findall_with_key is very similar to findall, but uses the SICStus 62% algorithm to guarantee that variables will have the same names. 63% 64'$findall_with_common_vars'(Template, Generator, Answers) :- 65 nb:nb_queue(Ref), 66 ( 67 '$execute'(Generator), 68 nb:nb_queue_enqueue(Ref, Template), 69 fail 70 ; 71 nb:nb_queue_close(Ref, Answers, []), 72 '$collect_with_common_vars'(Answers, _) 73 ). 74 75'$collect_with_common_vars'([], _). 76'$collect_with_common_vars'([Key-_|Answers], VarList) :- 77 '$variables_in_term'(Key, _, VarList), 78 '$collect_with_common_vars'(Answers, VarList). 79 80% This is the setof predicate 81 82setof(Template, Generator, Set) :- 83 ( '$partial_list_or_list'(Set) -> 84 true 85 ; 86 '$do_error'(type_error(list,Set), setof(Template, Generator, Set)) 87 ), 88 '$bagof'(Template, Generator, Bag), 89 '$sort'(Bag, Set). 90 91% And this is bagof 92 93% Either we have excess of variables 94% and we need to find the solutions for each instantiation 95% of these variables 96 97bagof(Template, Generator, Bag) :- 98 ( '$partial_list_or_list'(Bag) -> 99 true 100 ; 101 '$do_error'(type_error(list,Bag), bagof(Template, Generator, Bag)) 102 ), 103 '$bagof'(Template, Generator, Bag). 104 105'$bagof'(Template, Generator, Bag) :- 106 '$variables_in_term'(Template, [], TemplateV), 107 '$excess_vars'(Generator, StrippedGenerator, TemplateV, [], FreeVars), 108 ( FreeVars \== [] -> 109 '$variables_in_term'(FreeVars, [], LFreeVars), 110 Key =.. ['$'|LFreeVars], 111 '$findall_with_common_vars'(Key-Template, StrippedGenerator, Bags0), 112 '$keysort'(Bags0, Bags), 113 '$pick'(Bags, Key, Bag) 114 ; 115 '$findall'(Template, StrippedGenerator, [], Bag0), 116 Bag0 \== [], 117 Bag = Bag0 118 ). 119 120 121% picks a solution attending to the free variables 122'$pick'([K-X|Bags], Key, Bag) :- 123 '$parade'(Bags, K, Bag1, Bags1), 124 '$decide'(Bags1, [X|Bag1], K, Key, Bag). 125 126'$parade'([K-X|L1], Key, [X|B], L) :- K == Key, !, 127 '$parade'(L1, Key, B, L). 128'$parade'(L, _, [], L). 129 130% 131% The first argument to decide gives if solutions still left; 132% The second gives the solution currently found; 133% The third gives the free variables that are supposed to be bound; 134% The fourth gives the free variables being currently used. 135% The fifth outputs the current solution. 136% 137'$decide'([], Bag, Key0, Key, Bag) :- !, 138 Key0=Key. 139'$decide'(_, Bag, Key, Key, Bag). 140'$decide'(Bags, _, _, Key, Bag) :- 141 '$pick'(Bags, Key, Bag). 142 143% 144% Detect free variables in the source term 145% 146'$excess_vars'(V, V, X, L0, L) :- 147 var(V), 148 !, 149 ( '$doesnt_include'(X, V) -> L = [V|L0] 150 ; L = L0 151 ). 152'$excess_vars'(A, A, _, L, L) :- 153 atomic(A), !. 154'$excess_vars'(X^P, NP, Y, L0, L) :- !, 155 '$variables_in_term'(X+Y, [], NY), 156 '$excess_vars'(P, NP, NY, L0, L). 157'$excess_vars'(setof(X,P,S), setof(X,P,S), Y, L0, L) :- !, 158 '$variables_in_term'(X+Y, [], NY), 159 '$excess_vars'((P,S), _, NY, L0, L). 160'$excess_vars'(bagof(X,P,S), bagof(X,P,S), Y, L0, L) :- !, 161 '$variables_in_term'(X+Y, [], NY), 162 '$excess_vars'((P,S), _, NY, L0, L). 163'$excess_vars'(findall(X,P,S), findall(X,P,S), Y, L0, L) :- !, 164 '$excess_vars'(S, _, Y, L0, L). 165'$excess_vars'(findall(X,P,S0,S), findall(X,P,S0,S), Y, L0, L) :- !, 166 '$excess_vars'(S, _, Y, L0, L). 167'$excess_vars'(\+G, \+G, _, L0, LF) :- !, 168 L0 = LF. 169'$excess_vars'(_:G1, M:NG, Y, L0, LF) :- nonvar(G1), G1 = M:G, !, 170 '$excess_vars'(G, NG, Y, L0, LF). 171'$excess_vars'(M:G, M:NG, Y, L0, LF) :- !, 172 '$excess_vars'(G, NG, Y, L0, LF). 173'$excess_vars'(T, T, X, L0, L) :- 174 T =.. [_|LArgs], 175 '$recurse_for_excess_vars'(LArgs, X, L0, L). 176 177'$recurse_for_excess_vars'([], _, L, L). 178'$recurse_for_excess_vars'([T1|LArgs], X, L0, L) :- 179 '$excess_vars'(T1, _, X, L0, L1), 180 '$recurse_for_excess_vars'(LArgs, X, L1, L). 181 182'$doesnt_include'([], _). 183'$doesnt_include'([Y|L], X) :- 184 Y \== X, 185 '$doesnt_include'(L, X). 186 187% as an alternative to setof you can use the predicate all(Term,Goal,Solutions) 188% But this version of all does not allow for repeated answers 189% if you want them use findall 190 191all(T,G same X,S) :- !, all(T same X,G,Sx), '$$produce'(Sx,S,X). 192all(T,G,S) :- 193 '$init_db_queue'(Ref), 194 ( '$catch'(Error,'$clean_findall'(Ref,Error),_), 195 '$execute'(G), 196 '$db_enqueue'(Ref, T), 197 fail 198 ; 199 '$$set'(S,Ref) 200 ). 201 202% $$set does its best to preserve space 203'$$set'(S,R) :- 204 '$$build'(S0,_,R), 205 S0 = [_|_], 206 S = S0. 207 208'$$build'(Ns,S0,R) :- '$db_dequeue'(R,X), !, 209 '$$build2'(Ns,S0,R,X). 210'$$build'([],_,_). 211 212'$$build2'([X|Ns],Hash,R,X) :- 213 '$$new'(Hash,X), !, 214 '$$build'(Ns,Hash,R). 215'$$build2'(Ns,Hash,R,_) :- 216 '$$build'(Ns,Hash,R). 217 218'$$new'(V,El) :- var(V), !, V = n(_,El,_). 219'$$new'(n(R,El0,L),El) :- 220 compare(C,El0,El), 221 '$$new'(C,R,L,El). 222 223'$$new'(=,_,_,_) :- !, fail. 224'$$new'(<,R,_,El) :- '$$new'(R,El). 225'$$new'(>,_,L,El) :- '$$new'(L,El). 226 227 228'$$produce'([T1 same X1|Tn],S,X) :- '$$split'(Tn,T1,X1,S1,S2), 229 ( S=[T1|S1], X=X1; 230 !, produce(S2,S,X) ). 231 232'$$split'([],_,_,[],[]). 233'$$split'([T same X|Tn],T,X,S1,S2) :- '$$split'(Tn,T,X,S1,S2). 234'$$split'([T1 same X|Tn],T,X,[T1|S1],S2) :- '$$split'(Tn,T,X,S1,S2). 235'$$split'([T1|Tn],T,X,S1,[T1|S2]) :- '$$split'(Tn,T,X,S1,S2). 236 237 238'$partial_list_or_list'(V) :- var(V), !. 239'$partial_list_or_list'([]) :- !. 240'$partial_list_or_list'([_|B]) :- !, 241 '$partial_list_or_list'(B). 242 243