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 65:- noprofile(( 66 findall/4, 67 findall/3, 68 findnsols/4, 69 findnsols/5, 70 bagof/3, 71 setof/3, 72 findall_loop/4)). 73 74:- '$iso'((findall/3, 75 bagof/3, 76 setof/3)). 77 78%! findall(-Var, +Goal, -Bag) is det. 79%! findall(-Var, +Goal, -Bag, +Tail) is det. 80% 81% Bag holds all alternatives for Var in Goal. Bag might hold 82% duplicates. Equivalent to bagof, using the existence operator 83% (^) on all free variables of Goal. Succeeds with Bag = [] if 84% Goal fails immediately. 85% 86% The findall/4 variation is a difference-list version of 87% findall/3. 88 89findall(Templ, Goal, List) :- 90 findall(Templ, Goal, List, []). 91 92findall(Templ, Goal, List, Tail) :- 93 setup_call_cleanup( 94 '$new_findall_bag', 95 findall_loop(Templ, Goal, List, Tail), 96 '$destroy_findall_bag'). 97 98findall_loop(Templ, Goal, List, Tail) :- 99 ( , 100 '$add_findall_bag'(Templ) % fails 101 ; '$collect_findall_bag'(List, Tail) 102 ). 103 104%! findnsols(+Count, @Template, :Goal, -List) is nondet. 105%! findnsols(+Count, @Template, :Goal, -List, ?Tail) is nondet. 106% 107% True when List is the next chunk of maximal Count instantiations 108% of Template that reprensents a solution of Goal. For example: 109% 110% == 111% ?- findnsols(5, I, between(1, 12, I), L). 112% L = [1, 2, 3, 4, 5] ; 113% L = [6, 7, 8, 9, 10] ; 114% L = [11, 12]. 115% == 116% 117% @compat Ciao, but the SWI-Prolog version is non-deterministic. 118% @error domain_error(not_less_than_zero, Count) if Count is less 119% than 0. 120% @error type_error(integer, Count) if Count is not an integer. 121 122findnsols(Count, Template, Goal, List) :- 123 findnsols(Count, Template, Goal, List, []). 124 125findnsols(Count, Template, Goal, List, Tail) :- 126 integer(Count), 127 !, 128 findnsols2(count(Count), Template, Goal, List, Tail). 129findnsols(Count, Template, Goal, List, Tail) :- 130 Count = count(Integer), 131 integer(Integer), 132 !, 133 findnsols2(Count, Template, Goal, List, Tail). 134findnsols(Count, _, _, _, _) :- 135 '$type_error'(integer, Count). 136 137findnsols2(Count, Template, Goal, List, Tail) :- 138 nsols_count(Count, N), N > 0, 139 !, 140 copy_term(Template+Goal, Templ+G), 141 setup_call_cleanup( 142 '$new_findall_bag', 143 findnsols_loop(Count, Templ, G, List, Tail), 144 '$destroy_findall_bag'). 145findnsols2(Count, _, _, List, Tail) :- 146 nsols_count(Count, 0), 147 !, 148 Tail = List. 149findnsols2(Count, _, _, _, _) :- 150 nsols_count(Count, N), 151 '$domain_error'(not_less_than_zero, N). 152 153findnsols_loop(Count, Templ, Goal, List, Tail) :- 154 nsols_count(Count, FirstStop), 155 State = state(FirstStop), 156 ( call_cleanup(Goal, Det=true), 157 '$add_findall_bag'(Templ, Found), 158 Det \== true, 159 arg(1, State, Found), 160 '$collect_findall_bag'(List, Tail), 161 ( '$suspend_findall_bag' 162 ; nsols_count(Count, Incr), 163 NextStop is Found+Incr, 164 nb_setarg(1, State, NextStop), 165 fail 166 ) 167 ; '$collect_findall_bag'(List, Tail) 168 ). 169 170nsols_count(count(N), N). 171 172%! bagof(+Var, +Goal, -Bag) is semidet. 173% 174% Implements Clocksin and Melish's bagof/3 predicate. Bag is 175% unified with the alternatives of Var in Goal, Free variables of 176% Goal are bound, unless asked not to with the existential 177% quantifier operator (^). 178 179bagof(Templ, Goal0, List) :- 180 '$free_variable_set'(Templ^Goal0, Goal, Vars), 181 ( Vars == v 182 -> findall(Templ, Goal, List), 183 List \== [] 184 ; alloc_bind_key_list(Vars, VDict), 185 findall(Vars-Templ, Goal, Answers), 186 bind_bagof_keys(Answers, VDict), 187 keysort(Answers, Sorted), 188 pick(Sorted, Vars, List) 189 ). 190 191%! alloc_bind_key_list(+Vars, -VDict) is det. 192% 193% Pre-allocate the variable dictionary used by bind_bagof_keys/2. By 194% pre-allocating this list all variables bound become references from 195% the `Vars` of each answer to this dictionary. If we do not 196% preallocate we create a huge reference chain from VDict through each 197% of the answers, causing serious slowdown in the subsequent keysort. 198% 199% The slowdown was discovered by Jan Burse. 200 201alloc_bind_key_list(Vars, VDict) :- 202 functor(Vars, _, Count), 203 length(List, Count), 204 '$append'(List, _, VDict). 205 206%! bind_bagof_keys(+VarsTemplPairs, -SharedVars) 207% 208% Establish a canonical binding of the _vars_ structures. This 209% code was added by Ulrich Neumerkel in commit 210% 1bf9e87900b3bbd61308e80a784224c856854745. 211 212bind_bagof_keys([], _). 213bind_bagof_keys([W-_|WTs], Vars) :- 214 term_variables(W, Vars, _), 215 bind_bagof_keys(WTs, Vars). 216 217pick(Bags, Vars1, Bag1) :- 218 pick_first(Bags, Vars0, Bag0, RestBags), 219 select_bag(RestBags, Vars0, Bag0, Vars1, Bag1). 220 221select_bag([], Vars0, Bag0, Vars1, Bag1) :- % last one: deterministic 222 !, 223 Vars0 = Vars1, 224 Bag0 = Bag1. 225select_bag(_, Vars, Bag, Vars, Bag). 226select_bag(RestBags, _, _, Vars1, Bag1) :- 227 pick(RestBags, Vars1, Bag1). 228 229%! pick_first(+Bags, +Vars, -Bag1, -RestBags) is semidet. 230% 231% Pick the first result-bag from the list of Templ-Answer. Note 232% that we pick all elements that are equal under =@=, but because 233% the variables in the witness are canonized this is the same as ==. 234% 235% @param Bags List of Templ-Answer 236% @param Vars Initial Templ (for rebinding variables) 237% @param Bag1 First bag of results 238% @param RestBags Remaining Templ-Answer 239 240pick_first([Vars-Templ|T0], Vars, [Templ|T], RestBag) :- 241 pick_same(T0, Vars, T, RestBag). 242 243 244pick_same([V-H|T0], Vars, [H|T], Bag) :- 245 V == Vars, 246 !, 247 pick_same(T0, Vars, T, Bag). 248pick_same(Bag, _, [], Bag). 249 250 251%! setof(+Var, +Goal, -Set) is semidet. 252% 253% Equivalent to bagof/3, but sorts the resulting bag and removes 254% duplicate answers. We sort immediately after the findall/3, 255% removing duplicate Templ-Answer pairs early. 256 257setof(Templ, Goal0, List) :- 258 '$free_variable_set'(Templ^Goal0, Goal, Vars), 259 ( Vars == v 260 -> findall(Templ, Goal, Answers), 261 Answers \== [], 262 sort(Answers, List) 263 ; alloc_bind_key_list(Vars, VDict), 264 findall(Vars-Templ, Goal, Answers), 265 ( ground(Answers) 266 -> sort(Answers, Sorted), 267 pick(Sorted, Vars, List) 268 ; bind_bagof_keys(Answers, VDict), 269 sort(Answers, Sorted), 270 pick(Sorted, Vars, Listu), 271 sort(Listu, List) % Listu ordering may be nixed by Vars 272 ) 273 )