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-2014, University of Amsterdam,
    7                              VU University Amsterdam
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
   37Copyright notes: findall/3, bagof/3 and setof/3 are part of the standard
   38folklore of Prolog. The core  is  findall/3   based  on  C code that was
   39written for SWI-Prolog. Older versions also used C-based implementations
   40of  bagof/3  and  setof/3.  As   these    proved   wrong,   the  current
   41implementation is modelled  after  an  older   version  of  Yap.  Ulrich
   42Neumerkel fixed the variable preservation of   bagof/3 and setof/3 using
   43an algorithm also found in  Yap  6.3,   where  it  is claimed: "uses the
   44SICStus algorithm to guarantee that variables will have the same names".
   45- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
   46
   47:- module('$bags',
   48          [ findall/3,                  % +Templ, :Goal, -List
   49            findall/4,                  % +Templ, :Goal, -List, +Tail
   50            findnsols/4,                % +Count, +Templ, :Goal, -List
   51            findnsols/5,                % +Count, +Templ, :Goal, -List, +Tail
   52            bagof/3,                    % +Templ, :Goal, -List
   53            setof/3                     % +Templ, :Goal, -List
   54          ]).   55
   56:- meta_predicate
   57    findall(?, 0, -),
   58    findall(?, 0, -, ?),
   59    findnsols(+, ?, 0, -),
   60    findnsols(+, ?, 0, -, ?),
   61    bagof(?, ^, -),
   62    setof(?, ^, -).   63
   64:- noprofile((
   65        findall/4,
   66        findall/3,
   67        findnsols/4,
   68        findnsols/5,
   69        bagof/3,
   70        setof/3,
   71        findall_loop/4)).   72
   73:- '$iso'((findall/3,
   74           bagof/3,
   75           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.

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

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.

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

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

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

  195bind_bagof_keys([], _).
  196bind_bagof_keys([W-_|WTs], Vars) :-
  197    term_variables(W, Vars, _),
  198    bind_bagof_keys(WTs, Vars).
  199
  200pick(Bags, Vars1, Bag1) :-
  201    pick_first(Bags, Vars0, Bag0, RestBags),
  202    select_bag(RestBags, Vars0, Bag0, Vars1, Bag1).
  203
  204select_bag([], Vars0, Bag0, Vars1, Bag1) :-   % last one: deterministic
  205    !,
  206    Vars0 = Vars1,
  207    Bag0 = Bag1.
  208select_bag(_, Vars, Bag, Vars, Bag).
  209select_bag(RestBags, _, _, Vars1, Bag1) :-
  210    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

  223pick_first([Vars-Templ|T0], Vars, [Templ|T], RestBag) :-
  224    pick_same(T0, Vars, T, RestBag).
  225
  226
  227pick_same([V-H|T0], Vars, [H|T], Bag) :-
  228    V == Vars,
  229    !,
  230    pick_same(T0, Vars, T, Bag).
  231pick_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.

  240setof(Templ, Goal0, List) :-
  241    '$free_variable_set'(Templ^Goal0, Goal, Vars),
  242    (   Vars == v
  243    ->  findall(Templ, Goal, Answers),
  244        Answers \== [],
  245        sort(Answers, List)
  246    ;   findall(Vars-Templ, Goal, Answers),
  247        (   ground(Answers)
  248        ->  sort(Answers,Sorted),
  249            pick(Sorted,Vars,List)
  250        ;   bind_bagof_keys(Answers,_VDict),
  251            sort(Answers, Sorted),
  252            pick(Sorted, Vars, Listu),
  253            sort(Listu,List) % Listu ordering may be nixed by Vars
  254        )
  255    )