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