1/* Part of SWI-Prolog 2 3 Author: Jan Wielemaker 4 E-mail: J.Wielemaker@vu.nl 5 WWW: http://www.swi-prolog.org 6 Copyright (c) 1985-2014, University of Amsterdam, 7 VU University Amsterdam 8 All rights reserved. 9 10 Redistribution and use in source and binary forms, with or without 11 modification, are permitted provided that the following conditions 12 are met: 13 14 1. Redistributions of source code must retain the above copyright 15 notice, this list of conditions and the following disclaimer. 16 17 2. Redistributions in binary form must reproduce the above copyright 18 notice, this list of conditions and the following disclaimer in 19 the documentation and/or other materials provided with the 20 distribution. 21 22 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 23 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 24 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 25 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 26 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 27 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 28 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 29 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 30 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 31 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 32 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 33 POSSIBILITY OF SUCH DAMAGE. 34*/ 35 36/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 37Copyright notes: findall/3, bagof/3 and setof/3 are part of the standard 38folklore of Prolog. The core is findall/3 based on C code that was 39written for SWI-Prolog. Older versions also used C-based implementations 40of bagof/3 and setof/3. As these proved wrong, the current 41implementation is modelled after an older version of Yap. Ulrich 42Neumerkel fixed the variable preservation of bagof/3 and setof/3 using 43an algorithm also found in Yap 6.3, where it is claimed: "uses the 44SICStus algorithm to guarantee that variables will have the same names". 45- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ 46 47:- module('$bags', 48 [ findall/3, % +Templ, :Goal, -List 49 findall/4, % +Templ, :Goal, -List, +Tail 50 findnsols/4, % +Count, +Templ, :Goal, -List 51 findnsols/5, % +Count, +Templ, :Goal, -List, +Tail 52 bagof/3, % +Templ, :Goal, -List 53 setof/3 % +Templ, :Goal, -List 54 ]). 55 56:- meta_predicate 57 findall(, , ), 58 findall(, , , ), 59 findnsols(, , , ), 60 findnsols(, , , , ), 61 bagof(, , ), 62 setof(, , ). 63 64:- noprofile(( 65 findall/4, 66 findall/3, 67 findnsols/4, 68 findnsols/5, 69 bagof/3, 70 setof/3, 71 findall_loop/4)). 72 73:- '$iso'((findall/3, 74 bagof/3, 75 setof/3)). 76 77%! findall(-Var, +Goal, -Bag) is det. 78%! findall(-Var, +Goal, -Bag, +Tail) is det. 79% 80% Bag holds all alternatives for Var in Goal. Bag might hold 81% duplicates. Equivalent to bagof, using the existence operator 82% (^) on all free variables of Goal. Succeeds with Bag = [] if 83% Goal fails immediately. 84% 85% The findall/4 variation is a difference-list version of 86% findall/3. 87 88findall(Templ, Goal, List) :- 89 findall(Templ, , List, []). 90 91findall(Templ, Goal, List, Tail) :- 92 setup_call_cleanup( 93 '$new_findall_bag', 94 findall_loop(Templ, Goal, List, Tail), 95 '$destroy_findall_bag'). 96 97findall_loop(Templ, Goal, List, Tail) :- 98 ( , 99 '$add_findall_bag'(Templ) % fails 100 ; '$collect_findall_bag'(List, Tail) 101 ). 102 103%! findnsols(+Count, @Template, :Goal, -List) is nondet. 104%! findnsols(+Count, @Template, :Goal, -List, ?Tail) is nondet. 105% 106% True when List is the next chunk of maximal Count instantiations 107% of Template that reprensents a solution of Goal. For example: 108% 109% == 110% ?- findnsols(5, I, between(1, 12, I), L). 111% L = [1, 2, 3, 4, 5] ; 112% L = [6, 7, 8, 9, 10] ; 113% L = [11, 12]. 114% == 115% 116% @compat Ciao, but the SWI-Prolog version is non-deterministic. 117% @error domain_error(not_less_than_zero, Count) if Count is less 118% than 0. 119% @error type_error(integer, Count) if Count is not an integer. 120 121findnsols(Count, Template, Goal, List) :- 122 findnsols(Count, Template, , List, []). 123 124findnsols(Count, Template, Goal, List, Tail) :- 125 integer(Count), 126 !, 127 findnsols2(count(Count), Template, Goal, List, Tail). 128findnsols(Count, Template, Goal, List, Tail) :- 129 Count = count(Integer), 130 integer(Integer), 131 !, 132 findnsols2(Count, Template, Goal, List, Tail). 133findnsols(Count, _, _, _, _) :- 134 '$type_error'(integer, Count). 135 136findnsols2(Count, Template, Goal, List, Tail) :- 137 nsols_count(Count, N), N > 0, 138 !, 139 copy_term(Template+Goal, Templ+G), 140 setup_call_cleanup( 141 '$new_findall_bag', 142 findnsols_loop(Count, Templ, G, List, Tail), 143 '$destroy_findall_bag'). 144findnsols2(Count, _, _, List, Tail) :- 145 nsols_count(Count, 0), 146 !, 147 Tail = List. 148findnsols2(Count, _, _, _, _) :- 149 nsols_count(Count, N), 150 '$domain_error'(not_less_than_zero, N). 151 152findnsols_loop(Count, Templ, Goal, List, Tail) :- 153 nsols_count(Count, FirstStop), 154 State = state(FirstStop), 155 ( call_cleanup(, Det=true), 156 '$add_findall_bag'(Templ, Found), 157 Det \== true, 158 arg(1, State, Found), 159 '$collect_findall_bag'(List, Tail), 160 ( '$suspend_findall_bag' 161 ; nsols_count(Count, Incr), 162 NextStop is Found+Incr, 163 nb_setarg(1, State, NextStop), 164 fail 165 ) 166 ; '$collect_findall_bag'(List, Tail) 167 ). 168 169nsols_count(count(N), N). 170 171%! bagof(+Var, +Goal, -Bag) is semidet. 172% 173% Implements Clocksin and Melish's bagof/3 predicate. Bag is 174% unified with the alternatives of Var in Goal, Free variables of 175% Goal are bound, unless asked not to with the existential 176% quantifier operator (^). 177 178bagof(Templ, Goal0, List) :- 179 '$free_variable_set'(Templ^Goal0, Goal, Vars), 180 ( Vars == v 181 -> findall(Templ, , List), 182 List \== [] 183 ; findall(Vars-Templ, , Answers), 184 bind_bagof_keys(Answers,_), 185 keysort(Answers, Sorted), 186 pick(Sorted, Vars, List) 187 ). 188 189%! bind_bagof_keys(+VarsTemplPairs, -SharedVars) 190% 191% Establish a canonical binding of the _vars_ structures. This 192% code was added by Ulrich Neumerkel in commit 193% 1bf9e87900b3bbd61308e80a784224c856854745. 194 195bind_bagof_keys([], _). 196bind_bagof_keys([W-_|WTs], Vars) :- 197 term_variables(W, Vars, _), 198 bind_bagof_keys(WTs, Vars). 199 200pick(Bags, Vars1, Bag1) :- 201 pick_first(Bags, Vars0, Bag0, RestBags), 202 select_bag(RestBags, Vars0, Bag0, Vars1, Bag1). 203 204select_bag([], Vars0, Bag0, Vars1, Bag1) :- % last one: deterministic 205 !, 206 Vars0 = Vars1, 207 Bag0 = Bag1. 208select_bag(_, Vars, Bag, Vars, Bag). 209select_bag(RestBags, _, _, Vars1, Bag1) :- 210 pick(RestBags, Vars1, Bag1). 211 212%! pick_first(+Bags, +Vars, -Bag1, -RestBags) is semidet. 213% 214% Pick the first result-bag from the list of Templ-Answer. Note 215% that we pick all elements that are equal under =@=, but because 216% the variables in the witness are canonized this is the same as ==. 217% 218% @param Bags List of Templ-Answer 219% @param Vars Initial Templ (for rebinding variables) 220% @param Bag1 First bag of results 221% @param RestBags Remaining Templ-Answer 222 223pick_first([Vars-Templ|T0], Vars, [Templ|T], RestBag) :- 224 pick_same(T0, Vars, T, RestBag). 225 226 227pick_same([V-H|T0], Vars, [H|T], Bag) :- 228 V == Vars, 229 !, 230 pick_same(T0, Vars, T, Bag). 231pick_same(Bag, _, [], Bag). 232 233 234%! setof(+Var, +Goal, -Set) is semidet. 235% 236% Equivalent to bagof/3, but sorts the resulting bag and removes 237% duplicate answers. We sort immediately after the findall/3, 238% removing duplicate Templ-Answer pairs early. 239 240setof(Templ, Goal0, List) :- 241 '$free_variable_set'(Templ^Goal0, Goal, Vars), 242 ( Vars == v 243 -> findall(Templ, , Answers), 244 Answers \== [], 245 sort(Answers, List) 246 ; findall(Vars-Templ, , Answers), 247 ( ground(Answers) 248 -> sort(Answers,Sorted), 249 pick(Sorted,Vars,List) 250 ; bind_bagof_keys(Answers,_VDict), 251 sort(Answers, Sorted), 252 pick(Sorted, Vars, Listu), 253 sort(Listu,List) % Listu ordering may be nixed by Vars 254 ) 255 ).