bags.pl

View source with raw 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)).

findall(-Var, +Goal, -Bag) is det
findall(-Var, +Goal, -Bag, +Tail) is det: Bag holds all alternatives for Var in Goal. Bag might hold duplicates. Equivalent to bagof, using the existence operator (^) on all free variables of Goal. Succeeds with Bag = [] if Goal fails immediately.
The findall/4 variation is a difference-list version of findall/3.

   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').

cleanup_bag(:Goal, :Cleanup): Variant of setup_call_cleanup/3 that using '$new_findall_bag'/0 directly instead of through sig_atomic/1.

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

findnsols(+Count, @Template, :Goal, -List) is nondet

findnsols(+Count, @Template, :Goal, -List, ?Tail) is nondet

True when List is the next chunk of maximal Count instantiations of Template that reprensents a solution of Goal. For example:

?- findnsols(5, I, between(1, 12, I), L).
L = [1, 2, 3, 4, 5] ;
L = [6, 7, 8, 9, 10] ;
L = [11, 12].

Errors: - domain_error(not_less_than_zero, Count) if Count is less than 0.; - type_error(integer, Count) if Count is not an integer.
Compatibility: - Ciao, but the SWI-Prolog version is non-deterministic.

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

bagof(+Var, +Goal, -Bag) is semidet: Implements Clocksin and Melish's bagof/3 predicate. Bag is unified with the alternatives of Var in Goal, Free variables of Goal are bound, unless asked not to with the existential quantifier operator (^).

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

alloc_bind_key_list(+Vars, -VDict) is det: Pre-allocate the variable dictionary used by bind_bagof_keys/2. By pre-allocating this list all variables bound become references from the Vars of each answer to this dictionary. If we do not preallocate we create a huge reference chain from VDict through each of the answers, causing serious slowdown in the subsequent keysort.
The slowdown was discovered by Jan Burse.

  211alloc_bind_key_list(Vars, VDict) :-
  212    functor(Vars, _, Count),
  213    length(List, Count),
  214    '$append'(List, _, VDict).

bind_bagof_keys(+VarsTemplPairs, -SharedVars): Establish a canonical binding of the vars structures. This code was added by Ulrich Neumerkel in commit 1bf9e87900b3bbd61308e80a784224c856854745.

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

pick_first(+Bags, +Vars, -Bag1, -RestBags) is semidet

Pick the first result-bag from the list of Templ-Answer. Note that we pick all elements that are equal under =@=, but because the variables in the witness are canonized this is the same as ==.

Arguments:

`Bags`	- List of Templ-Answer
`Vars`	- Initial Templ (for rebinding variables)
`Bag1`	- First bag of results
`RestBags`	- Remaining Templ-Answer

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

setof(+Var, +Goal, -Set) is semidet: Equivalent to bagof/3, but sorts the resulting bag and removes duplicate answers. We sort immediately after the findall/3, removing duplicate Templ-Answer pairs early.

  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    )