Skip to content

Commit

Permalink
Bags, re issue #614
Browse files Browse the repository at this point in the history
  • Loading branch information
@infradig
infradig committed Oct 30, 2024
1 parent f948746 commit b8121aa
Show file tree
Hide file tree
Showing 2 changed files with 88 additions and 191 deletions.
276 changes: 85 additions & 191 deletions library/builtins.pl
View file
Original file line number Diff line number Diff line change
Expand Up @@ -202,205 +202,99 @@

:- help(copy_term(+term,?term,+list), [iso(false)]).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Derived from code by R.A. O'Keefe
term_variables(P1, P2, P3) :-
term_variables(P1, P4),
append(P4, P3, P2).

:- meta_predicate(setof(-,0,?)).
:- help(term_variables(+term,-list,?tail), [iso(false)]).

setof(Template, Generator, Set) :-
( var(Set) ->
true
; must_be(Set, list_or_partial_list, setof/3, _)
),
bagof_(Template, Generator, Bag),
is_list_or_partial_list(Set),
sort(Bag, Set).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%

:- meta_predicate(setof(-,0,?)).
:- help(setof(+term,+callable,?list), [iso(true)]).

:- meta_predicate(bagof(-,0,?)).

bagof(Template, Generator, Bag) :-
(var(Bag) -> true; must_be(Bag, list_or_partial_list, bagof/3, _)),
bagof_(Template, Generator, Bag).

:- help(bagof(+term,:callable,?list), [iso(true)]).

bagof_(Template, Generator, Bag) :-
acyclic_term(Generator),
free_variables_(Generator, Template, [], Vars, 1),
Vars \== [],
!,
Key =.. [(.)|Vars],
functor(Key, (.), N),
findall(Key-Template, Generator, Recorded),
replace_instance_(Recorded, Key, N, _, OmniumGatherum),
keysort(OmniumGatherum, Gamut), !,
concordant_subset_(Gamut, Key, Answer),
Bag = Answer.
bagof_(Template, Generator, Bag) :-
findall(Template, Generator, Bag0),
Bag0 \== [],
Bag = Bag0.

_^Goal :- Goal.

replace_instance_([], _, _, _, []) :- !.
replace_instance_([NewKey-Term|Xs], Key, NVars, Vars, [NewKey-Term|NewBag]) :-
replace_key_variables_(NVars, Key, Vars, NewKey), !,
replace_instance_(Xs, Key, NVars, Vars, NewBag).


% Original R.A. O'Keefe comment:
% There is a bug in the compiled version of arg in Dec-10 Prolog,
% hence the rather strange code. Only two calls on arg are needed
% in Dec-10 interpreted Prolog or C-Prolog.

replace_key_variables_(0, _, _, _) :- !.
replace_key_variables_(N, OldKey, Vars0, NewKey) :-
arg(N, NewKey, Arg),
nonvar(Arg), !,
replace_variables_(Arg, Vars0, Vars1),
M is N-1,
replace_key_variables_(M, OldKey, Vars1, NewKey).
replace_key_variables_(N, OldKey, Vars, NewKey) :-
%arg(N, OldKey, OldVar),
arg(N, NewKey, _OldVar),
M is N-1,
replace_key_variables_(M, OldKey, Vars, NewKey).

replace_variables_(Term, [Var|Vars], Vars) :-
var(Term), !,
Term = Var.
replace_variables_(Term, Vars, Vars) :-
atomic(Term), !.
replace_variables_(Term, Vars0, Vars) :-
functor(Term, _, Arity),
replace_variables_term_(Arity, Term, Vars0, Vars).

replace_variables_term_(0, _, Vars, Vars) :- !.
replace_variables_term_(N, Term, Vars0, Vars) :-
arg(N, Term, Arg),
( cyclic_term(Arg) ->
N1 is N-1,
replace_variables_term_(N1, Term, Vars0, Vars)
; replace_variables_(Arg, Vars0, Vars1),
N1 is N-1,
replace_variables_term_(N1, Term, Vars1, Vars)
).

/*
% concordant_subset_([Key-Val list], Key, [Val list]).
% takes a list of Key-Val pairs which has been keysorted to bring
% all the identical keys together, and enumerates each different
% Key and the corresponding lists of values.
*/

concordant_subset_([Key-Val|Rest], Clavis, Answer) :-
concordant_subset_(Rest, Key, List, More),
concordant_subset_(More, Key, [Val|List], Clavis, Answer).

/*
% concordant_subset_(Rest, Key, List, More)
% strips off all the Key-Val pairs from the from of Rest,
% putting the Val elements into List, and returning the
% left-over pairs, if any, as More.
*/

concordant_subset_([Key-Val|Rest], Clavis, List, More) :-
subsumes_term(Key, Clavis),
subsumes_term(Clavis, Key),
!,
Key = Clavis,
List = [Val|Rest2],
concordant_subset_(Rest, Clavis, Rest2, More).
concordant_subset_(More, _, [], More).

/*
% concordant_subset_/5 tries the current subset, and if that
% doesn't work if backs up and tries the next subset. The
% first clause is there to save a choicepoint when this is
% the last possible subset.
*/

concordant_subset_([], Key, Subset, Key, Subset) :- !.
concordant_subset_(_, Key, Subset, Key, Subset).
concordant_subset_(More, _, _, Clavis, Answer) :-
concordant_subset_(More, Clavis, Answer).

% 0 disables use of explicit_binding_, 1 enables them
% setof stuff still uses 1, that's closer to it's usual implementation
free_variables_(A,B,C,D) :- free_variables_(A,B,C,D,0).

% ---extracted from: not.pl --------------------%

% Author : R.A.O'Keefe
% Updated: 17 November 1983
% Purpose: "suspicious" negation

% In order to handle variables properly, we have to find all the
% universally quantified variables in the Generator. All variables
% as yet unbound are universally quantified, unless
% a) they occur in the template
% b) they are bound by X^P, setof, or bagof
% free_variables_(Generator, Template, OldList, NewList,CheckBindings=0,1)
% finds this set, using OldList as an accumulator.

free_variables_(Term, Bound, VarList, [Term|VarList],_) :-
var(Term),
term_is_free_of_(Bound, Term),
list_is_free_of_(VarList, Term),
!.
free_variables_(Term, _, VarList, VarList,_) :-
var(Term),
!.
free_variables_(Term, Bound, OldList, NewList, 1) :-
explicit_binding_(Term, Bound, NewTerm, NewBound),
!,
free_variables_(NewTerm, NewBound, OldList, NewList, 1).
free_variables_(Term, Bound, OldList, NewList, _) :-
functor(Term, _, N),
free_variables_(N, Term, Bound, OldList, NewList, 0).

free_variables_(0, _, _, VarList, VarList, _) :- !.
free_variables_(N, Term, Bound, OldList, NewList, B) :-
arg(N, Term, Argument),
( cyclic_term(Argument) ->
M is N-1, !,
free_variables_(M, Term, Bound, OldList, NewList, B)
; free_variables_(Argument, Bound, OldList, MidList, B),
M is N-1, !,
free_variables_(M, Term, Bound, MidList, NewList, B)
).

% explicit_binding_ checks for goals known to existentially quantify
% one or more variables. In particular "not" is quite common.

explicit_binding_(\+(_), Bound, fail, Bound ).
explicit_binding_(not(_), Bound, fail, Bound ).
explicit_binding_(Term^Goal, Bound, Goal, Bound+Vars) :-
term_variables(Term, Vars).
explicit_binding_(setof(Var,Goal,Set), Bound, Goal-Set, Bound+Var).
explicit_binding_(bagof(Var,Goal,Bag), Bound, Goal-Bag, Bound+Var).

term_is_free_of_(Term, Var) :-
var(Term), !,
Term \== Var.
term_is_free_of_(Term, Var) :-
functor(Term, _, N),
term_is_free_of_(N, Term, Var).

term_is_free_of_(0, _, _) :- !.
term_is_free_of_(N, Term, Var) :-
arg(N, Term, Argument),
term_is_free_of_(Argument, Var),
M is N-1, !,
term_is_free_of_(M, Term, Var).

list_is_free_of_([], _).
list_is_free_of_([Head|Tail], Var) :-
Head \== Var,
list_is_free_of_(Tail, Var).
/************************************************************/
/* bagof/3 and setof/3 */
/************************************************************/

/**
* bagof(T, X1^…^Xn^G, L): [ISO 8.10.2]
* The predicate determines all the solutions to the goal G,
* whereby collecting copies of the template T and the
* witness. The predicate then repeatedly succeeds for
* the witness and the list of associated templates.
*/
% bagof(+Term, +Goal, -List)
bagof(T, G, L) :-
(var(L) -> true; must_be(L, list_or_partial_list, bagof/3, _)),
acyclic_term(G),
sys_globals_kernel(T^G, W, H),
findall(W-T, H, J),
sys_same_vars(J, _),
keysort(J, K),
sys_enum_runs(K, W, L).

/**
* setof(T, X1^…^Xn^G, L): [ISO 8.10.3]
* The predicate determines all the solutions to the goal G,
* whereby collecting copies of the template T and the
* witness. The predicate then repeatedly succeeds for
* the witness and the set of associated templates.
*/
% setof(+Term, +Goal, -List)
setof(T, G, L) :-
(var(L) -> true; must_be(L, list_or_partial_list, setof/3, _)),
acyclic_term(G),
sys_globals_kernel(T^G, W, H),
findall(W-T, H, J),
sys_same_vars(J, _),
sort(J, K),
sys_enum_runs(K, W, L).

% sys_same_vars(+Pairs, +List)
sys_same_vars([K-_|L], V) :-
term_variables(K, V, _),
sys_same_vars(L, V).
sys_same_vars([], _).

% sys_enum_runs(+Pairs, +Term, -List)
sys_enum_runs([K-V|L], W, Q) :-
sys_key_run(L, K, R, H),
(K = W, Q = [V|R], (H = [], !; true); sys_enum_runs(H, W, Q)).

% sys_key_run(+Pairs, +Term, -List, -Pairs)
sys_key_run([K-V|L], J, [V|R], H) :- K == J, !,
sys_key_run(L, J, R, H).
sys_key_run(L, _, [], L).

/********************************************************************/
/* Helpers */
/********************************************************************/

% sys_goal_split(+Goal, -List, -Goal)
sys_globals_kernel(G, W, H) :-
sys_goal_split(G, I, H),
term_variables(H, A),
term_variables(I, B),
sys_var_subtract(A, B, W).

% sys_goal_split(+Goal, -List, -Goal)
sys_goal_split(G, [], G) :- var(G), !.
sys_goal_split(V^G, [V|L], H) :- !,
sys_goal_split(G, L, H).
sys_goal_split(G, [], G).

% sys_var_subtract(+List, +List, -List)
sys_var_subtract([X|L], R, T) :-
member(Y, R), Y == X, !,
sys_var_subtract(L, R, T).
sys_var_subtract([X|L], R, [X|S]) :-
sys_var_subtract(L, R, S).
sys_var_subtract([], _, []).

%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Expand Down
3 changes: 3 additions & 0 deletions src/bif_predicates.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -110,6 +110,9 @@ static bool bif_iso_findall_3(query *q)
return throw_error(q, p3, p3_ctx, "resource_error", "stack");
}

if (check_body_callable(p2))
return throw_error(q, p2, p2_ctx, "type_error", "callable");

grab_queuen(q);

if (q->st.qnbr == MAX_QUEUES)
Expand Down

0 comments on commit b8121aa

Please sign in to comment.