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