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
   65:- noprofile((
   66        findall/4,
   67        findall/3,
   68        findnsols/4,
   69        findnsols/5,
   70        bagof/3,
   71        setof/3,
   72        findall_loop/4)).   73
   74:- '$iso'((findall/3,
   75           bagof/3,
   76           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.

   89findall(Templ, Goal, List) :-
   90    findall(Templ, Goal, List, []).
   91
   92findall(Templ, Goal, List, Tail) :-
   93    setup_call_cleanup(
   94        '$new_findall_bag',
   95        findall_loop(Templ, Goal, List, Tail),
   96        '$destroy_findall_bag').
   97
   98findall_loop(Templ, Goal, List, Tail) :-
   99    (   Goal,
  100        '$add_findall_bag'(Templ)   % fails
  101    ;   '$collect_findall_bag'(List, Tail)
  102    ).

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.

  122findnsols(Count, Template, Goal, List) :-
  123    findnsols(Count, Template, Goal, List, []).
  124
  125findnsols(Count, Template, Goal, List, Tail) :-
  126    integer(Count),
  127    !,
  128    findnsols2(count(Count), Template, Goal, List, Tail).
  129findnsols(Count, Template, Goal, List, Tail) :-
  130    Count = count(Integer),
  131    integer(Integer),
  132    !,
  133    findnsols2(Count, Template, Goal, List, Tail).
  134findnsols(Count, _, _, _, _) :-
  135    '$type_error'(integer, Count).
  136
  137findnsols2(Count, Template, Goal, List, Tail) :-
  138    nsols_count(Count, N), N > 0,
  139    !,
  140    copy_term(Template+Goal, Templ+G),
  141    setup_call_cleanup(
  142        '$new_findall_bag',
  143        findnsols_loop(Count, Templ, G, List, Tail),
  144        '$destroy_findall_bag').
  145findnsols2(Count, _, _, List, Tail) :-
  146    nsols_count(Count, 0),
  147    !,
  148    Tail = List.
  149findnsols2(Count, _, _, _, _) :-
  150    nsols_count(Count, N),
  151    '$domain_error'(not_less_than_zero, N).
  152
  153findnsols_loop(Count, Templ, Goal, List, Tail) :-
  154    nsols_count(Count, FirstStop),
  155    State = state(FirstStop),
  156    (   call_cleanup(Goal, Det=true),
  157        '$add_findall_bag'(Templ, Found),
  158        Det \== true,
  159        arg(1, State, Found),
  160        '$collect_findall_bag'(List, Tail),
  161        (   '$suspend_findall_bag'
  162        ;   nsols_count(Count, Incr),
  163            NextStop is Found+Incr,
  164            nb_setarg(1, State, NextStop),
  165            fail
  166        )
  167    ;   '$collect_findall_bag'(List, Tail)
  168    ).
  169
  170nsols_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 (^).

  179bagof(Templ, Goal0, List) :-
  180    '$free_variable_set'(Templ^Goal0, Goal, Vars),
  181    (   Vars == v
  182    ->  findall(Templ, Goal, List),
  183        List \== []
  184    ;   alloc_bind_key_list(Vars, VDict),
  185        findall(Vars-Templ, Goal, Answers),
  186        bind_bagof_keys(Answers, VDict),
  187        keysort(Answers, Sorted),
  188        pick(Sorted, Vars, List)
  189    ).

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.

  201alloc_bind_key_list(Vars, VDict) :-
  202    functor(Vars, _, Count),
  203    length(List, Count),
  204    '$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.

  212bind_bagof_keys([], _).
  213bind_bagof_keys([W-_|WTs], Vars) :-
  214    term_variables(W, Vars, _),
  215    bind_bagof_keys(WTs, Vars).
  216
  217pick(Bags, Vars1, Bag1) :-
  218    pick_first(Bags, Vars0, Bag0, RestBags),
  219    select_bag(RestBags, Vars0, Bag0, Vars1, Bag1).
  220
  221select_bag([], Vars0, Bag0, Vars1, Bag1) :-   % last one: deterministic
  222    !,
  223    Vars0 = Vars1,
  224    Bag0 = Bag1.
  225select_bag(_, Vars, Bag, Vars, Bag).
  226select_bag(RestBags, _, _, Vars1, Bag1) :-
  227    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

  240pick_first([Vars-Templ|T0], Vars, [Templ|T], RestBag) :-
  241    pick_same(T0, Vars, T, RestBag).
  242
  243
  244pick_same([V-H|T0], Vars, [H|T], Bag) :-
  245    V == Vars,
  246    !,
  247    pick_same(T0, Vars, T, Bag).
  248pick_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.

  257setof(Templ, Goal0, List) :-
  258    '$free_variable_set'(Templ^Goal0, Goal, Vars),
  259    (   Vars == v
  260    ->  findall(Templ, Goal, Answers),
  261        Answers \== [],
  262        sort(Answers, List)
  263    ;   alloc_bind_key_list(Vars, VDict),
  264        findall(Vars-Templ, Goal, Answers),
  265        (   ground(Answers)
  266        ->  sort(Answers, Sorted),
  267            pick(Sorted, Vars, List)
  268        ;   bind_bagof_keys(Answers, VDict),
  269            sort(Answers, Sorted),
  270            pick(Sorted, Vars, Listu),
  271            sort(Listu, List) % Listu ordering may be nixed by Vars
  272        )
  273    )