yap-6.3/pl/setof.yap

/*************************************************************************
*									 *
*	 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
 *
 * @brief  Setof and friends.
 *
 *
*/


:- system_module( '$_setof', [(^)/2,
        all/3,
        bagof/3,
        findall/3,
        findall/4,
        setof/3], []).

/**

@defgroup Sets Collecting Solutions to a Goal
@{
@ingroup builtins

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:

*/

:- use_system_module( '$_boot', ['$catch'/3]).

:- use_system_module( '$_errors', ['$do_error'/2]).

% this is used by the all predicate

:- op(50,xfx,same).


%% @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).



/** @pred  findall( _T_,+ _G_,- _L_) is iso

findall/3 is a simplified version of bagof which has an implicit
   existential quantifier on every variable.

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
~~~~~


*/

findall(Template, Generator, Answers) :-
     must_be_of_type( list_or_partial_list, Answers ),
     '$findall'(Template, Generator, [], Answers).


% If some answers have already been found
/** @pred  findall( ?Key, +Goal, +InitialSolutions, -Solutions )

Similar to findall/3, but appends all answers to list  _L0_.


*/
findall(Template, Generator, Answers, SoFar) :-
     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),
	 fail
	;
	 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).

% This is the setof predicate
/** @pred  setof( _X_,+ _P_,- _B_) is iso


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

~~~
setof(X,a(X,Y),L).
~~~
would be:

~~~
X = _32
Y = 1
L = [1,2];
X = _32
Y = 2
L = [2];
no
~~~




 */
setof(Template, Generator, Set) :-

	( '$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

/** @pred  bagof( _T_,+ _G_,- _L_) is iso


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

~~~
bagof(X,a(X,Y),L).

would be:
X = _32
Y = 1
L = [2,1];
X = _32
Y = 2
L = [2];
no
~~~


*/

bagof(Template, Generator, Bag) :-
	( '$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) :-
	'$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
% if you want them use findall
/** @pred  all( _T_,+ _G_,- _L_)


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

~~~
all(X,a(X,Y),L).
~~~
would be:

~~~
X = _32
Y = _33
L = [2,1];
no
~~~

Note that all/3 will fail if no answers are found.


*/
all(T, G same X,S) :- !, all(T same X,G,Sx), '$$produce'(Sx,S,X).
all(T,G,S) :-
	'$init_db_queue'(Ref),
	( catch(G, Error,'$clean_findall'(Ref,Error) ),
	  '$execute'(G),
	  '$db_enqueue'(Ref, T),
	  fail
        ;
	  '$$set'(S,Ref)
        ).

% $$set does its best to preserve space
'$$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,_).
'$$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).

/**
@}
*/