This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/pl/setof.yap

340 lines
7.3 KiB
Plaintext
Raw Normal View History

/*************************************************************************
* *
* YAP Prolog %W% %G%
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: setof.pl *
* Last rev: *
* mods: *
* comments: set predicates *
* *
*************************************************************************/
/**
* @file setof.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Thu Nov 19 10:45:32 2015
2018-06-05 20:51:49 +01:00
*
* @brief Setof and friends.
2018-06-05 20:51:49 +01:00
*
*
*/
2016-01-20 22:36:16 +00:00
:- system_module( '$_setof', [(^)/2,
all/3,
bagof/3,
findall/3,
findall/4,
setof/3], []).
/**
2014-09-11 20:06:57 +01:00
@defgroup Sets Collecting Solutions to a Goal
2018-06-05 20:51:49 +01:00
@{
@ingroup builtins
2014-09-11 20:06:57 +01:00
When there are several solutions to a goal, if the user wants to collect all
the solutions he may be led to use the data base, because backtracking will
forget previous solutions.
YAP allows the programmer to choose from several system
predicates instead of writing his own routines. findall/3 gives you
the fastest, but crudest solution. The other built-in predicates
post-process the result of the query in several different ways:
*/
2014-04-09 12:39:29 +01:00
:- use_system_module( '$_boot', ['$catch'/3]).
:- use_system_module( '$_errors', ['$do_error'/2]).
% this is used by the all predicate
:- op(50,xfx,same).
2016-01-20 22:36:16 +00:00
%% @pred ^/2
%
% The "existential quantifier" symbol is only significant to bagof
% and setof, which it stops binding the quantified variable.
% op(200, xfy, ^) is defined during bootstrap.
_^Goal :-
'$execute'(Goal).
2015-04-13 13:28:17 +01:00
/** @pred findall( _T_,+ _G_,- _L_) is iso
2014-09-15 19:10:49 +01:00
2016-01-20 22:36:16 +00:00
findall/3 is a simplified version of bagof which has an implicit
existential quantifier on every variable.
2014-09-15 19:10:49 +01:00
Unifies _L_ with a list that contains all the instantiations of the
term _T_ satisfying the goal _G_.
With the following program:
~~~~~
a(2,1).
a(1,1).
a(2,2).
~~~~~
the answer to the query
~~~~~
findall(X,a(X,Y),L).
~~~~~
would be:
~~~~~
X = _32
Y = _33
L = [2,1,2];
no
~~~~~
2015-04-13 13:28:17 +01:00
2014-09-15 19:10:49 +01:00
*/
findall(Template, Generator, Answers) :-
2016-05-19 08:47:40 +01:00
must_be_of_type( list_or_partial_list, Answers ),
'$findall'(Template, Generator, [], Answers).
% If some answers have already been found
2016-05-19 08:47:40 +01:00
/** @pred findall( ?Key, +Goal, +InitialSolutions, -Solutions )
2014-09-15 19:10:49 +01:00
Similar to findall/3, but appends all answers to list _L0_.
2015-04-13 13:28:17 +01:00
2014-09-15 19:10:49 +01:00
*/
findall(Template, Generator, Answers, SoFar) :-
2016-05-19 08:47:40 +01:00
must_be_of_type( list_or_partial_list, Answers ),
'$findall'(Template, Generator, SoFar, Answers).
% starts by calling the generator,
% and recording the answers
'$findall'(Template, Generator, SoFar, Answers) :-
nb:nb_queue(Ref),
(
'$execute'(Generator),
nb:nb_queue_enqueue(Ref, Template),
2013-02-15 16:31:49 +00:00
fail
;
2013-02-15 16:31:49 +00:00
nb:nb_queue_close(Ref, Answers, SoFar)
).
% findall_with_key is very similar to findall, but uses the SICStus
% algorithm to guarantee that variables will have the same names.
%
'$findall_with_common_vars'(Template, Generator, Answers) :-
nb:nb_queue(Ref),
(
'$execute'(Generator),
nb:nb_queue_enqueue(Ref, Template),
fail
;
nb:nb_queue_close(Ref, Answers, []),
'$collect_with_common_vars'(Answers, _)
).
'$collect_with_common_vars'([], _).
'$collect_with_common_vars'([Key-_|Answers], VarList) :-
'$variables_in_term'(Key, _, VarList),
'$collect_with_common_vars'(Answers, VarList).
2015-04-13 13:28:17 +01:00
% This is the setof predicate
2015-04-13 13:28:17 +01:00
/** @pred setof( _X_,+ _P_,- _B_) is iso
2014-09-15 19:10:49 +01:00
Similar to `bagof( _T_, _G_, _L_)` but sorts list
_L_ and keeping only one copy of each element. Again, assuming the
same clauses as in the examples above, the reply to the query
2018-06-07 18:05:45 +01:00
~~~
2014-09-15 19:10:49 +01:00
setof(X,a(X,Y),L).
2018-06-07 18:05:45 +01:00
~~~
2014-09-15 19:10:49 +01:00
would be:
2018-06-07 18:05:45 +01:00
~~~
2014-09-15 19:10:49 +01:00
X = _32
Y = 1
L = [1,2];
X = _32
Y = 2
L = [2];
no
2018-06-07 18:05:45 +01:00
~~~
2014-09-15 19:10:49 +01:00
*/
setof(Template, Generator, Set) :-
2018-06-05 20:51:49 +01:00
2012-03-06 14:41:23 +00:00
( '$is_list_or_partial_list'(Set) ->
true
;
'$do_error'(type_error(list,Set), setof(Template, Generator, Set))
),
'$bagof'(Template, Generator, Bag),
'$sort'(Bag, Set).
% And this is bagof
% Either we have excess of variables
% and we need to find the solutions for each instantiation
% of these variables
2015-04-13 13:28:17 +01:00
/** @pred bagof( _T_,+ _G_,- _L_) is iso
2014-09-15 19:10:49 +01:00
For each set of possible instances of the free variables occurring in
_G_ but not in _T_, generates the list _L_ of the instances of
_T_ satisfying _G_. Again, assuming the same clauses as in the
examples above, the reply to the query
2018-06-07 18:05:45 +01:00
~~~
2014-09-15 19:10:49 +01:00
bagof(X,a(X,Y),L).
would be:
X = _32
Y = 1
L = [2,1];
X = _32
Y = 2
L = [2];
no
2018-06-07 18:05:45 +01:00
~~~
2014-09-15 19:10:49 +01:00
2015-04-13 13:28:17 +01:00
2014-09-15 19:10:49 +01:00
*/
bagof(Template, Generator, Bag) :-
2012-03-06 14:41:23 +00:00
( '$is_list_or_partial_list'(Bag) ->
true
;
'$do_error'(type_error(list,Bag), bagof(Template, Generator, Bag))
),
'$bagof'(Template, Generator, Bag).
'$bagof'(Template, Generator, Bag) :-
2013-01-15 11:17:56 +00:00
'$free_variables_in_term'(Template^Generator, StrippedGenerator, Key),
%format('TemplateV=~w v=~w ~w~n',[TemplateV,Key, StrippedGenerator]),
( Key \== '$' ->
'$findall_with_common_vars'(Key-Template, StrippedGenerator, Bags0),
'$keysort'(Bags0, Bags),
'$pick'(Bags, Key, Bag)
;
'$findall'(Template, StrippedGenerator, [], Bag0),
Bag0 \== [],
Bag = Bag0
).
% picks a solution attending to the free variables
'$pick'([K-X|Bags], Key, Bag) :-
'$parade'(Bags, K, Bag1, Bags1),
'$decide'(Bags1, [X|Bag1], K, Key, Bag).
'$parade'([K-X|L1], Key, [X|B], L) :- K == Key, !,
'$parade'(L1, Key, B, L).
'$parade'(L, _, [], L).
%
% The first argument to decide gives if solutions still left;
% The second gives the solution currently found;
% The third gives the free variables that are supposed to be bound;
% The fourth gives the free variables being currently used.
% The fifth outputs the current solution.
%
'$decide'([], Bag, Key0, Key, Bag) :- !,
Key0=Key.
'$decide'(_, Bag, Key, Key, Bag).
'$decide'(Bags, _, _, Key, Bag) :-
'$pick'(Bags, Key, Bag).
% as an alternative to setof you can use the predicate all(Term,Goal,Solutions)
% But this version of all does not allow for repeated answers
2015-04-13 13:28:17 +01:00
% if you want them use findall
/** @pred all( _T_,+ _G_,- _L_)
2014-09-15 19:10:49 +01:00
Similar to `findall( _T_, _G_, _L_)` but eliminate
repeated elements. Thus, assuming the same clauses as in the above
example, the reply to the query
2018-06-07 18:05:45 +01:00
~~~
2014-09-15 19:10:49 +01:00
all(X,a(X,Y),L).
2018-06-07 18:05:45 +01:00
~~~
2014-09-15 19:10:49 +01:00
would be:
2018-06-07 18:05:45 +01:00
~~~
2014-09-15 19:10:49 +01:00
X = _32
Y = _33
L = [2,1];
no
2018-06-07 18:05:45 +01:00
~~~
2014-09-15 19:10:49 +01:00
Note that all/3 will fail if no answers are found.
2015-04-13 13:28:17 +01:00
2014-09-15 19:10:49 +01:00
*/
2014-02-09 10:47:44 +00:00
all(T, G same X,S) :- !, all(T same X,G,Sx), '$$produce'(Sx,S,X).
2015-04-13 13:28:17 +01:00
all(T,G,S) :-
'$init_db_queue'(Ref),
2016-04-14 12:00:09 +01:00
( catch(G, Error,'$clean_findall'(Ref,Error) ),
'$execute'(G),
'$db_enqueue'(Ref, T),
fail
;
'$$set'(S,Ref)
).
% $$set does its best to preserve space
2015-04-13 13:28:17 +01:00
'$$set'(S,R) :-
'$$build'(S0,_,R),
S0 = [_|_],
S = S0.
'$$build'(Ns,S0,R) :- '$db_dequeue'(R,X), !,
'$$build2'(Ns,S0,R,X).
'$$build'([],_,_).
'$$build2'([X|Ns],Hash,R,X) :-
'$$new'(Hash,X), !,
'$$build'(Ns,Hash,R).
'$$build2'(Ns,Hash,R,_) :-
'$$build'(Ns,Hash,R).
'$$new'(V,El) :- var(V), !, V = n(_,El,_).
2015-04-13 13:28:17 +01:00
'$$new'(n(R,El0,L),El) :-
compare(C,El0,El),
'$$new'(C,R,L,El).
'$$new'(=,_,_,_) :- !, fail.
'$$new'(<,R,_,El) :- '$$new'(R,El).
'$$new'(>,_,L,El) :- '$$new'(L,El).
'$$produce'([T1 same X1|Tn],S,X) :- '$$split'(Tn,T1,X1,S1,S2),
( S=[T1|S1], X=X1;
!, produce(S2,S,X) ).
'$$split'([],_,_,[],[]).
'$$split'([T same X|Tn],T,X,S1,S2) :- '$$split'(Tn,T,X,S1,S2).
'$$split'([T1 same X|Tn],T,X,[T1|S1],S2) :- '$$split'(Tn,T,X,S1,S2).
'$$split'([T1|Tn],T,X,S1,[T1|S2]) :- '$$split'(Tn,T,X,S1,S2).
2014-09-11 20:06:57 +01:00
/**
@}
*/