1% ---------------------------------------------------------------------- 2% BEGIN LICENSE BLOCK 3% Version: CMPL 1.1 4% 5% The contents of this file are subject to the Cisco-style Mozilla Public 6% License Version 1.1 (the "License"); you may not use this file except 7% in compliance with the License. You may obtain a copy of the License 8% at www.eclipse-clp.org/license. 9% 10% Software distributed under the License is distributed on an "AS IS" 11% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 12% the License for the specific language governing rights and limitations 13% under the License. 14% 15% The Original Code is The ECLiPSe Constraint Logic Programming System. 16% The Initial Developer of the Original Code is Cisco Systems, Inc. 17% Portions created by the Initial Developer are 18% Copyright (C) 1989-2006 Cisco Systems, Inc. All Rights Reserved. 19% 20% Contributor(s): R.A.O'Keefe and David Warren 21% Contributor(s): ECRC GmbH 22% Contributor(s): IC-Parc, Imperal College London 23% Contributor(s): Joachim Schimpf, Coninfer Ltd 24% 25% END LICENSE BLOCK 26% ---------------------------------------------------------------------- 27% 28% System: ECLiPSe Constraint Logic Programming System 29% Version: $Id: setof.pl,v 1.7 2013/02/18 00:42:59 jschimpf Exp $ 30% Identification: setof.pl, part of module(sepia_kernel) 31% Description: Implements the all-solution predicates. 32% This code was originally based on Richard O'Keefe's 33% 1983 public domain implementation, but now retains 34% virtually nothing from that base, except the 35% wording of some comments. 36% 37% ---------------------------------------------------------------------- 38 39:- system. 40 41:- export 42 findall/3, 43 setof/3, 44 coverof/3, 45 bagof/3, 46 (^)/2. 47 48:- meta_predicate(( 49 findall(*,0,*), 50 setof(*,0,*), 51 bagof(*,0,*), 52 coverof(*,0,*), 53 ^(*,0))). 54 55 56% findall(Template, Generator, List) 57% is a special case of bagof, where all free variables in the 58% generator are taken to be existentially quantified. It is 59% described in Clocksin & Mellish on p152. The code they give 60% has a bug (which the Dec-10 bagof and setof predicates share) 61% which this has not. 62 63findall_body(Template, Generator, List, Module) :- 64 bag_create(Ref), 65 recordz_instances(Template, Generator, Module, Ref), 66 bag_dissolve(Ref, List). 67 68 69% setof(Template, Generator, Set) 70% finds the Set of instances of the Template satisfying the Generator. 71% The set is in ascending order (see compare/3 for a definition of 72% this order) without duplicates, and is non-empty. If there are 73% no solutions, setof fails. setof may succeed more than one way, 74% binding free variables in the Generator to different values. This 75% predicate is defined on p51 of the Dec-10 Prolog manual. 76 77setof_body(Template, Filter, Set, Module) :- 78 bagof_body(Template, Filter, Bag, Module), 79 sort(0, <, Bag, Set). 80 81 82% coverof(Template, Generator, Set) - ECLiPSe extension 83% works like setof/3, however the list of solutions is not sorted 84% and only the most general instances are retained 85 86coverof_body(Template, Filter, Set, Module) :- 87 bagof_body(Template, Filter, Bag, Module), 88 prune_instances(Bag, Set). 89 90 91% bagof(Template, Generator, Bag) 92% finds all the instances of the Template produced by the Generator, 93% and returns them in the Bag in they order in which they were found. 94% If the Generator contains free variables which are not bound in the 95% Template, it assumes that this is like any other Prolog question 96% and that you want bindings for those variables. (You can tell it 97% not to bother by using existential quantifiers.) 98 99bagof_body(Template, QGenerator, Bag, Module) :- 100 free_variables_quant(QGenerator, Template, Generator, Vars, Module), 101 ( Vars == [] -> 102 bag_create(Ref), 103 recordz_instances(Template, Generator, Module, Ref), 104 bag_dissolve(Ref, Bag), 105 Bag \== [] 106 ; 107 Key =.. [.|Vars], 108 bag_create(Ref), 109 recordz_instances(Key-Template, Generator, Module, Ref), 110 bag_dissolve(Ref, KeyedSols), 111 add_stripped_keys(KeyedSols, DoubleKeyedSols, HaveAttributes), 112 ( HaveAttributes == true -> 113 instance_bag_attrs(DoubleKeyedSols, Key, Bag) 114 ; 115 instance_bag_plain(KeyedSols, Key, Bag) 116 ) 117 ). 118 119 120% The simpler form for "plain" solutions, which have no attributes in their 121% free variable bindings, and thus are cheaper to partition into variants. 122 123instance_bag_plain(KeyedSols, FreeVars, Bag) :- 124 % Unify variables in FreeBindings. As a result, variants become 125 % identical (the sharing side-effect among non-variants is unimportant). 126 % The trick was suggested by Ulrich Neumerkel. 127 equalise_key_variables(KeyedSols, _), 128 sort(1, =<, KeyedSols, SortedKeyedSols), 129 same_key_members(SortedKeyedSols, FreeVars, Bag). 130 131 132% The general form, where free variable bindings can be attributed vars. 133% We have a list of FreeBindingsPlain-(FreeBindingsAttr-TemplateBinding) 134% We first use FreeBindingsPlain to group solutions as in the attribute-free 135% case. Within these groups we then use the naive algorithm for further 136% partitioning using full attribute-aware variant testing on FreeBindingsAttr. 137 138instance_bag_attrs(DoubleKeyedSols, FreeVars, Bag) :- 139 equalise_key_variables(DoubleKeyedSols, _), 140 sort(1, =<, DoubleKeyedSols, SortedDoubleKeyedSols), 141 same_key_members(SortedDoubleKeyedSols, _, MultiBag), 142 instance_bag_naive(MultiBag, FreeVars, Bag). 143 144 145% Naive version with full variant testing, quadratic complexity 146instance_bag_naive([FreeBinding1-TmplBinding1|Sols], FreeVars, Bag) :- 147 ( 148 foreach(Sol,Sols), 149 fromto(RemSols,RemSols1,RemSols2,[]), 150 fromto(Bag1,Bag2,Bag3,[]), 151 param(FreeBinding1) 152 do 153 Sol = FreeBinding-TmplBinding, 154 ( variant(FreeBinding, FreeBinding1) -> 155 FreeBinding1 = FreeBinding, 156 Bag2 = [TmplBinding|Bag3], 157 RemSols1 = RemSols2 158 ; 159 Bag2 = Bag3, 160 RemSols1 = [Sol|RemSols2] 161 ) 162 ), 163 ( RemSols == [] -> 164 FreeVars = FreeBinding1, Bag = [TmplBinding1|Bag1] 165 ; 166 ( 167 FreeVars = FreeBinding1, Bag = [TmplBinding1|Bag1] 168 ; 169 instance_bag_naive(RemSols, FreeVars, Bag) 170 ) 171 ). 172 173 174% Auxiliary operations on Key-Value lists 175 176% Add keys that are copies of the original keys with their attributes stripped. 177 178add_stripped_keys(KVs, KKVs, HaveAttributes) :- 179 ( 180 foreach(KV,KVs), 181 foreach(PlainKey-KV,KKVs), 182 param(HaveAttributes) 183 do 184 KV = Key-_, 185 copy_term(Key, PlainKey, AttrVars), 186 ( AttrVars == [] -> true ; HaveAttributes = true ) 187 ). 188 189 190% Unify variables in the list keys. 191% This is similar to using numbervars, but leaves the variables free. 192 193equalise_key_variables([], _PositionVars). 194equalise_key_variables([Key-_|KVs], PositionVars) :- 195 term_variables(Key, FreeVars), 196 append(FreeVars, _, PositionVars), 197 equalise_key_variables(KVs, PositionVars). 198 199 200% Separate the leading list elements with identical keys 201 202same_key_prefix([Key-V|KVs], Key, [V|Vs], KVsRest) :- 203 same_key_prefix1(KVs, Key, Vs, KVsRest). 204 205 same_key_prefix1([], _Key, [], []). 206 same_key_prefix1(KVs, Key, Vs, KVsRest) :- KVs = [K-V|KVs1], 207 ( K == Key -> 208 Vs = [V|Vs1], 209 same_key_prefix1(KVs1, Key, Vs1, KVsRest) 210 ; 211 Vs = [], KVsRest = KVs 212 ). 213 214 215% Succeed once for each sequence of elements with identical keys 216 217same_key_members(KVs, Key, Vs) :- 218 % Pick the first sequence 219 same_key_prefix(KVs, Key0, Vs0, KVsRest), 220 % Succeed, and if necessary, allow backtracking for more 221 ( KVsRest == [] -> 222 Key = Key0, Vs = Vs0 223 ; 224 ( 225 Key = Key0, Vs = Vs0 226 ; 227 same_key_members(KVsRest, Key, Vs) 228 ) 229 ). 230 231 232% recordz_instances(Template, Generator, Module, Ref) 233% enumerates all provable instances of the Generator and records the 234% associated Template instances. Neither argument ends up changed. 235 236% :- sequential recordz_instances/4. 237recordz_instances(Template, Generator, Module, Ref) :- 238 call_local(Generator, Module), 239% true, % force waking before recording 240 bag_enter(Ref, Template), 241 fail. 242recordz_instances(_, _, _, _). 243 244 245% Collect the free variables in QGoal. These are those that occur 246% neither in Bound nor are explicitly quantified via X^Y^...^Goal. 247% If ^/2 is defined as a predicate, we use traditional quantifier-semantics, 248% else ISO-semantics (where only toplevel occurrences of ^/2 are considered). 249% The (toplevel-)unquantified goal is returned as well. 250 251free_variables_quant(QGoal, Bound, Goal, VarList, _Module) :- var(QGoal), !, 252 Goal = QGoal, 253 free_variables(QGoal, Bound, [], VarList, false). 254free_variables_quant(Vars^QGoal, Bound, Goal, VarList, Module) :- !, 255 free_variables_quant(QGoal, Vars^Bound, Goal, VarList, Module). 256free_variables_quant(Goal, Bound, Goal, VarList, Module) :- 257 ( current_built_in((^)/2)@Module -> UseQuant=true ; UseQuant=false ), 258 free_variables(Goal, Bound, [], VarList, UseQuant). 259 260free_variables(Term, Bound, Vars0, Vars, _) :- var(Term), 261 ( occurs(Term, Bound) -> Vars = Vars0 262 ; occurs(Term, Vars0) -> Vars = Vars0 263 ; Vars = [Term|Vars0] 264 ). 265free_variables(Term, _Bound, Vars0, Vars, _) :- atomic(Term), 266 Vars0 = Vars. 267free_variables(Term, Bound, Vars0, Vars, UseQuant) :- compound(Term), 268 ( UseQuant==true, explicit_binding(Term, Bound, NewTerm, NewBound) -> 269 free_variables(NewTerm, NewBound, Vars0, Vars, UseQuant) 270 ; 271 ( 272 foreacharg(Argument,Term), 273 fromto(Vars0,Vars1,Vars2,Vars), 274 param(Bound,UseQuant) 275 do 276 free_variables(Argument, Bound, Vars1, Vars2, UseQuant) 277 ) 278 ). 279 280% Traditional, non-ISO feature: 281% explicit_binding checks for goals known to existentially quantify 282% one or more variables. In particular \+ is quite common. 283 284:- mode explicit_binding(+,+,-,-). 285explicit_binding(\+ _, Bound, fail, Bound ) :- !. 286explicit_binding(not(_), Bound, fail, Bound ) :- !. 287explicit_binding(fail_if(_), Bound, fail, Bound ) :- !. 288explicit_binding(Var^Goal, Bound, Goal, Bound+Var) :- !. 289explicit_binding(setof(Var,Goal,Set), Bound, Goal-Set, Bound+Var) :- !. 290explicit_binding(bagof(Var,Goal,Bag), Bound, Goal-Bag, Bound+Var) :- !. 291explicit_binding(coverof(Var,Goal,Bag), Bound, Goal-Bag, Bound+Var) :- !. 292 293 294% The tool body of ^/2 295 296exquant_body(_, Goal, Module) :- 297 untraced_call(Goal, Module). 298 299 300% For proper tracing behaviour, this file must be in nodbgcomp 301% and the metapredicates must be set to unskipped. This will cause 302% only the metacalls of the user goals to show up in the trace. 303 304:- unskipped 305 exquant_body/3, 306 setof_body/4, 307 bagof_body/4, 308 coverof_body/4, 309 findall_body/4. 310 311:- set_flag(setof/3, trace_meta, on). 312:- set_flag(setof_body/4, trace_meta, on). 313:- set_flag(bagof/3, trace_meta, on). 314:- set_flag(bagof_body/4, trace_meta, on). 315:- set_flag(coverof/3, trace_meta, on). 316:- set_flag(coverof_body/4, trace_meta, on). 317:- set_flag(findall/3, trace_meta, on). 318:- set_flag(findall_body/4, trace_meta, on). 319:- set_flag((^)/2, trace_meta, on). 320:- set_flag(exquant_body/3, trace_meta, on). 321 322