diff --git a/library/aggregate.pl b/library/aggregate.pl new file mode 100755 index 000000000..e2aae1feb --- /dev/null +++ b/library/aggregate.pl @@ -0,0 +1,544 @@ +/* $Id: aggregate.pl,v 1.4 2008-07-22 23:34:49 vsc Exp $ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: wielemak@science.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 2008, University of Amsterdam + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(aggretate, + [ foreach/2, % :Generator, :Goal + aggregate/3, % +Templ, :Goal, -Result + aggregate/4, % +Templ, +Discrim, :Goal, -Result + aggregate_all/3, % +Templ, :Goal, -Result + aggregate_all/4, % +Templ, +Discrim, :Goal, -Result + free_variables/4 % :Generator, :Template, +Vars0, -Vars + ]). +:- use_module(library(ordsets)). +:- use_module(library(pairs)). +:- use_module(library(error)). +:- use_module(library(lists)). + +:- module_transparent + foreach/2, + aggregate/3, + aggregate/4, + aggregate_all/3, + aggregate_all/4. + +/** Aggregation operators on backtrackable predicates + +This library provides aggregating operators over the solutions of a +predicate. The operations are a generalisation of the bagof/3, setof/3 +and findall/3 built-in predicates. The defined aggregation operations +are counting, computing the sum, minimum, maximum, a bag of solutions +and a set of solutions. We first give a simple example, computing the +country with the smallest area: + +== +average_country_area(Name, Area) :- + aggregate(min(A, N), country(N, A), min(Area, Name)). +== + +There are four aggregation predicates, distinguished on two properties. + + $ aggregate vs. aggregate_all : + The aggregate predicates use setof/3 (aggregate/4) or bagof/3 + (aggregate/3), dealing with existential qualified variables + (Var^Goal) and providing multiple solutions for the remaining free + variables in Goal. The aggregate_all/3 predicate uses findall/3, + implicitely qualifying all free variables and providing exactly one + solution, while aggregate_all/4 uses sort/2 over solutions and + Distinguish (see below) generated using findall/3. + + $ The Distinguish argument : + The versions with 4 arguments provide a Distinguish argument that + allow for keeping duplicate bindings of a variable in the result. + For example, if we wish to compute the total population of all + countries we do not want to loose results because two countries + have the same population. Therefore we use: + + == + aggregate(sum(P), Name, country(Name, P), Total) + == + +All aggregation predicates support the following operator below in +Template. In addition, they allow for an arbitrary named compound term +where each of the arguments is a term from the list below. I.e. the term +r(min(X), max(X)) computes both the minimum and maximum binding for X. + + * count + Count number of solutions. Same as sum(1). + * sum(Expr) + Sum of Expr for all solutions. + * min(Expr) + Minimum of Expr for all solutions. + * min(Expr, Witness) + A term min(Min, Witness), where Min is the minimal version + of Expr over all Solution and Witness is any other template + the applied to the solution that produced Min. If multiple + solutions provide the same minimum, Witness corresponds to + the first solution. + * max(Expr) + Maximum of Expr for all solutions. + * max(Expr, Witness) + As min(Expr, Witness), but producing the maximum result. + * set(X) + An ordered set with all solutions for X. + * bag(X) + A list of all solutions for X. + +---+++ Acknowledgements + +_|The development of this library was sponsored by SecuritEase, + http://www.securitease.com +|_ + +@compat Quintus, SICStus 4. The forall/2 is a SWI-Prolog built-in and + term_variables/3 is a SWI-Prolog with a *|different definition|*. +@tbd Analysing the aggregation template and compiling a predicate + for the list aggregation can be done at compile time. +@tbd aggregate_all/3 can be rewritten to run in constant space using + non-backtrackable assignment on a term. +*/ + + /******************************* + * AGGREGATE * + *******************************/ + +%% aggregate(+Template, :Goal, -Result) is nondet. +% +% Aggregate bindings in Goal according to Template. The aggregate/3 +% version performs bagof/3 on Goal. + +aggregate(Template, Goal0, Result) :- + template_to_pattern(bag, Template, Pattern, Goal0, Goal, Aggregate), + bagof(Pattern, Goal, List), + aggregate_list(Aggregate, List, Result). + +%% aggregate(+Template, +Discriminator, :Goal, -Result) is nondet. +% +% Aggregate bindings in Goal according to Template. The aggregate/3 +% version performs setof/3 on Goal. + +aggregate(Template, Discriminator, Goal0, Result) :- + template_to_pattern(bag, Template, Pattern, Goal0, Goal, Aggregate), + setof(Discriminator-Pattern, Goal, Pairs), + pairs_values(Pairs, List), + aggregate_list(Aggregate, List, Result). + +%% aggregate_all(+Template, :Goal, -Result) is semidet. +% +% Aggregate bindings in Goal according to Template. The aggregate_all/3 +% version performs findall/3 on Goal. + +aggregate_all(Template, Goal0, Result) :- + template_to_pattern(all, Template, Pattern, Goal0, Goal, Aggregate), + findall(Pattern, Goal, List), + aggregate_list(Aggregate, List, Result). + +%% aggregate_all(+Template, +Discriminator, :Goal, -Result) is semidet. +% +% Aggregate bindings in Goal according to Template. The aggregate_all/3 +% version performs findall/3 followed by sort/2 on Goal. + +aggregate_all(Template, Discriminator, Goal0, Result) :- + template_to_pattern(all, Template, Pattern, Goal0, Goal, Aggregate), + findall(Discriminator-Pattern, Goal, Pairs0), + sort(Pairs0, Pairs), + pairs_values(Pairs, List), + aggregate_list(Aggregate, List, Result). + + +template_to_pattern(_All, Template, Pattern, Goal0, Goal, Aggregate) :- + template_to_pattern(Template, Pattern, Post, Vars, Aggregate), + existential_vars(Goal0, Goal1, AllVars, Vars), + clean_body((Goal1, Post), Goal2), + add_existential_vars(AllVars, Goal2, Goal). + +existential_vars(Var, Var) --> + { var(Var) }, !. +existential_vars(Var^G0, G) --> !, + [Var], + existential_vars(G0, G). +existential_vars(G, G) --> + []. + +add_existential_vars([], G, G). +add_existential_vars([H|T], G0, H^G1) :- + add_existential_vars(T, G0, G1). + + +%% clean_body(+Goal0, -Goal) is det. +% +% Remove redundant =true= from Goal0. + +clean_body((Goal0,Goal1), Goal) :- !, + clean_body(Goal0, GoalA), + clean_body(Goal1, GoalB), + ( GoalA == true + -> Goal = GoalB + ; GoalB == true + -> Goal = GoalA + ; Goal = (GoalA,GoalB) + ). +clean_body(Goal, Goal). + + +%% template_to_pattern(+Template, -Pattern, -Post, -Vars, -Agregate) +% +% Determine which parts of the goal we must remember in the +% findall/3 pattern. +% +% @param Post is a body-term that evaluates expressions to reduce +% storage requirements. +% @param Vars is a list of intermediate variables that must be +% added to the existential variables for bagof/3. +% @param Agregate defines the aggregation operation to execute. + +template_to_pattern(sum(X), X, true, [], sum) :- var(X), !. +template_to_pattern(sum(X0), X, X is X0, [X0], sum) :- !. +template_to_pattern(count, 1, true, [], count) :- !. +template_to_pattern(min(X), X, true, [], min) :- var(X), !. +template_to_pattern(min(X0), X, X is X0, [X0], min) :- !. +template_to_pattern(min(X0, Witness), X-Witness, X is X0, [X0], min_witness) :- !. +template_to_pattern(max(X0), X, X is X0, [X0], max) :- !. +template_to_pattern(max(X0, Witness), X-Witness, X is X0, [X0], max_witness) :- !. +template_to_pattern(set(X), X, true, [], set) :- !. +template_to_pattern(bag(X), X, true, [], bag) :- !. +template_to_pattern(Term, Pattern, Goal, Vars, term(MinNeeded, Functor, AggregateArgs)) :- + compound(Term), !, + Term =.. [Functor|Args0], + templates_to_patterns(Args0, Args, Goal, Vars, AggregateArgs), + needs_one(AggregateArgs, MinNeeded), + Pattern =.. [Functor|Args]. +template_to_pattern(Term, _, _, _, _) :- + type_error(aggregate_template, Term). + +templates_to_patterns([], [], true, [], []). +templates_to_patterns([H0], [H], G, Vars, [A]) :- !, + template_to_pattern(H0, H, G, Vars, A). +templates_to_patterns([H0|T0], [H|T], (G0,G), Vars, [A0|A]) :- + template_to_pattern(H0, H, G0, V0, A0), + append(V0, RV, Vars), + templates_to_patterns(T0, T, G, RV, A). + +%% needs_one(+Ops, -OneOrZero) +% +% If one of the operations in Ops needs at least one answer, +% unify OneOrZero to 1. Else 0. + +needs_one(Ops, 1) :- + member(Op, Ops), + needs_one(Op), !. +needs_one(_, 0). + +needs_one(min). +needs_one(min_witness). +needs_one(max). +needs_one(max_witness). + +%% aggregate_list(+Op, +List, -Answer) is semidet. +% +% Aggregate the answer from the list produced by findall/3, +% bagof/3 or setof/3. The latter two cases deal with compound +% answers. +% +% @tbd Compile code for incremental state update, which we will use +% for aggregate_all/3 as well. We should be using goal_expansion +% to generate these clauses. + +aggregate_list(bag, List0, List) :- !, + List = List0. +aggregate_list(set, List, Set) :- !, + sort(List, Set). +aggregate_list(sum, List, Sum) :- + sumlist(List, Sum). +aggregate_list(count, List, Count) :- + length(List, Count). +aggregate_list(max, List, Sum) :- + max_list(List, Sum). +aggregate_list(max_witness, List, max(Max, Witness)) :- + max_pair(List, Max, Witness). +aggregate_list(min, List, Sum) :- + min_list(List, Sum). +aggregate_list(min_witness, List, min(Min, Witness)) :- + min_pair(List, Min, Witness). +aggregate_list(term(0, Functor, Ops), List, Result) :- !, + maplist(state0, Ops, StateArgs, FinishArgs), + State0 =.. [Functor|StateArgs], + aggregate_term_list(List, Ops, State0, Result0), + finish_result(Ops, FinishArgs, Result0, Result). +aggregate_list(term(1, Functor, Ops), [H|List], Result) :- + H =.. [Functor|Args], + maplist(state1, Ops, Args, StateArgs, FinishArgs), + State0 =.. [Functor|StateArgs], + aggregate_term_list(List, Ops, State0, Result0), + finish_result(Ops, FinishArgs, Result0, Result). + +aggregate_term_list([], _, State, State). +aggregate_term_list([H|T], Ops, State0, State) :- + step_term(Ops, H, State0, State1), + aggregate_term_list(T, Ops, State1, State). + + +%% min_pair(+Pairs, -Key, -Value) is det. +%% max_pair(+Pairs, -Key, -Value) is det. +% +% True if Key-Value has the smallest/largest key in Pairs. If +% multiple pairs share the smallest/largest key, the first pair is +% returned. + +min_pair([M0-W0|T], M, W) :- + min_pair(T, M0, W0, M, W). + +min_pair([], M, W, M, W). +min_pair([M0-W0|T], M1, W1, M, W) :- + ( M0 > M1 + -> min_pair(T, M0, W0, M, W) + ; min_pair(T, M1, W1, M, W) + ). + +max_pair([M0-W0|T], M, W) :- + max_pair(T, M0, W0, M, W). + +max_pair([], M, W, M, W). +max_pair([M0-W0|T], M1, W1, M, W) :- + ( M0 > M1 + -> max_pair(T, M0, W0, M, W) + ; max_pair(T, M1, W1, M, W) + ). + +%% step(+AggregateAction, +New, +State0, -State1). + +step(bag, X, [X|L], L). +step(set, X, [X|L], L). +step(count, _, X0, X1) :- + succ(X0, X1). +step(sum, X, X0, X1) :- + X1 is X0+X. +step(max, X, X0, X1) :- + X1 is max(X0, X). +step(min, X, X0, X1) :- + X1 is min(X0, X). +step(max_witness, X-W, X0-W0, X1-W1) :- + ( X > X0 + -> X1 = X, W1 = W + ; X1 = X0, W1 = W0 + ). +step(min_witness, X-W, X0-W0, X1-W1) :- + ( X < X0 + -> X1 = X, W1 = W + ; X1 = X0, W1 = W0 + ). +step(term(Ops), Row, Row0, Row1) :- + step_term(Ops, Row, Row0, Row1). + +step_term(Ops, Row, Row0, Row1) :- + functor(Row, Name, Arity), + functor(Row1, Name, Arity), + step_list(Ops, 1, Row, Row0, Row1). + +step_list([], _, _, _, _). +step_list([Op|OpT], Arg, Row, Row0, Row1) :- + arg(Arg, Row, X), + arg(Arg, Row0, X0), + arg(Arg, Row1, X1), + step(Op, X, X0, X1), + succ(Arg, Arg1), + step_list(OpT, Arg1, Row, Row0, Row1). + +finish_result(Ops, Finish, R0, R) :- + functor(R0, Functor, Arity), + functor(R, Functor, Arity), + finish_result(Ops, Finish, 1, R0, R). + +finish_result([], _, _, _, _). +finish_result([Op|OpT], [F|FT], I, R0, R) :- + arg(I, R0, A0), + arg(I, R, A), + finish_result1(Op, F, A0, A), + succ(I, I2), + finish_result(OpT, FT, I2, R0, R). + +finish_result1(bag, Bag0, [], Bag) :- !, + Bag = Bag0. +finish_result1(set, Bag, [], Set) :- !, + sort(Bag, Set). +finish_result1(max_witness, _, M-W, R) :- !, + R = max(M,W). +finish_result1(min_witness, _, M-W, R) :- !, + R = min(M,W). +finish_result1(_, _, A, A). + +%% state0(+Op, -State, -Finish) + +state0(bag, L, L). +state0(set, L, L). +state0(count, 0, _). +state0(sum, 0, _). + +%% state1(+Op, +First, -State, -Finish) + +state1(bag, X, [X|L], L). +state1(set, X, [X|L], L). +state1(_, X, X, _). + + + /******************************* + * FOREACH * + *******************************/ + +%% foreach(:Generator, :Goal) +% +% True if the conjunction of instances of Goal using the bindings +% from Generator is true. Unlike forall/2, which runs a +% failure-driven loop that proves Goal for each solution of +% Generator, foreach creates a conjunction. Each member of the +% conjunction is a copy of Goal, where the variables it shares +% with Generator are filled with the values from the corresponding +% solution. +% +% The implementation executes forall/2 if Goal does not contain +% any variables that are not shared with Generator. +% +% Here is an example: +% +% == +% ?- foreach(between(1,4,X), dif(X,Y)), Y = 5. +% Y = 5 +% ?- foreach(between(1,4,X), dif(X,Y)), Y = 3. +% No +% == +% +% @bug Goal is copied repeatetly, which may cause problems if +% attributed variables are involved. + +foreach(Generator, Goal0) :- + strip_module(Goal0, M, G), + Goal = M:G, + term_variables(Generator, GenVars0), sort(GenVars0, GenVars), + term_variables(Goal, GoalVars0), sort(GoalVars0, GoalVars), + ord_subtract(GoalVars, GenVars, SharedGoalVars), + ( SharedGoalVars == [] + -> \+ (Generator, \+Goal) % = forall(Generator, Goal) + ; ord_intersection(GenVars, GoalVars, SharedVars), + Templ =.. [v|SharedVars], + SharedTempl =.. [v|SharedGoalVars], + findall(Templ, Generator, List), + prove_list(List, Templ, SharedTempl, Goal) + ). + +prove_list([], _, _, _). +prove_list([H|T], Templ, SharedTempl, Goal) :- + copy_term(Templ+SharedTempl+Goal, + H+SharedTempl+Copy), + Copy, + prove_list(T, Templ, SharedTempl, Goal). + + +%% free_variables(:Generator, +Template, +VarList0, -VarList) is det. +% +% 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 +% +% 1. they occur in the template +% 2. they are bound by X^P, setof, or bagof +% +% free_variables(Generator, Template, OldList, NewList) finds this +% set, using OldList as an accumulator. +% +% @author Richard O'Keefe +% @author Jan Wielemaker (made some SWI-Prolog enhancements) +% @license Public domain (from DEC10 library). +% @tbd Distinguish between control-structures and data terms. +% @tbd Exploit our built-in term_variables/2 at some places? + +free_variables(Term, Bound, VarList, [Term|VarList]) :- + var(Term), + term_is_free_of(Bound, Term), + list_is_free_of(VarList, Term), !. +free_variables(Term, _Bound, VarList, VarList) :- + var(Term), !. +free_variables(Term, Bound, OldList, NewList) :- + explicit_binding(Term, Bound, NewTerm, NewBound), !, + free_variables(NewTerm, NewBound, OldList, NewList). +free_variables(Term, Bound, OldList, NewList) :- + functor(Term, _, N), + free_variables(N, Term, Bound, OldList, NewList). + +free_variables(0, _, _, VarList, VarList) :- !. +free_variables(N, Term, Bound, OldList, NewList) :- + arg(N, Term, Argument), + free_variables(Argument, Bound, OldList, MidList), + M is N-1, !, + free_variables(M, Term, Bound, MidList, NewList). + +% explicit_binding checks for goals known to existentially quantify +% one or more variables. In particular \+ is quite common. + +explicit_binding(\+ _Goal, Bound, fail, Bound ) :- !. +explicit_binding(not(_Goal), Bound, fail, Bound ) :- !. +explicit_binding(Var^Goal, Bound, Goal, Bound+Var) :- !. +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) is semidet. +% +% True if Var does not appear in Term. This has been rewritten +% from the DEC10 library source to exploit our non-deterministic +% arg/3. + +term_is_free_of(Term, Var) :- + \+ var_in_term(Term, Var). + +var_in_term(Term, Var) :- + Var == Term, !. +var_in_term(Term, Var) :- + compound(Term), + genarg(_, Term, Arg), + var_in_term(Arg, Var), !. + + +%% list_is_free_of(+List, +Var) is semidet. +% +% True if Var is not in List. + +list_is_free_of([Head|Tail], Var) :- + Head \== Var, !, + list_is_free_of(Tail, Var). +list_is_free_of([], _). + + +% term_variables(+Term, +Vars0, -Vars) is det. +% +% True if Vars is the union of variables in Term and Vars0. +% We cannot have this as term_variables/3 is already defined +% as a difference-list version of term_variables/2. + +%term_variables(Term, Vars0, Vars) :- +% term_variables(Term+Vars0, Vars). diff --git a/library/error.pl b/library/error.pl new file mode 100755 index 000000000..db55e43ac --- /dev/null +++ b/library/error.pl @@ -0,0 +1,262 @@ +/* $Id: error.pl,v 1.3 2008-07-22 23:34:49 vsc Exp $ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: wielemak@science.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2007, University of Amsterdam + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(error, + [ type_error/2, % +Type, +Term + domain_error/2, % +Domain, +Term + existence_error/2, % +Type, +Term + permission_error/3, % +Action, +Type, +Term + instantiation_error/1, % +Term + representation_error/1, % +Reason + + must_be/2, % +Type, +Term + is_of_type/2 % +Type, +Term + ]). + +:- if(current_prolog_flag(dialect, yap)). + +:- use_module(library(lists),[memberchk/2]). + +:- endif. + +/** Error generating support + +This module provides predicates to simplify error generation and +checking. It's implementation is based on a discussion on the SWI-Prolog +mailinglist on best practices in error handling. The utility predicate +must_be/2 provides simple run-time type validation. The *_error +predicates are simple wrappers around throw/1 to simplify throwing the +most common ISO error terms. + +@author Jan Wielemaker +@author Richard O'Keefe +@see library(debug) and library(prolog_stack). +*/ + +:- multifile + has_type/2. + +%% type_error(+Type, +Term). +%% domain_error(+Type, +Term). +%% existence_error(+Type, +Term). +%% permission_error(+Action, +Type, +Term). +%% instantiation_error(+Term). +%% representation_error(+Reason). +% +% Throw ISO compliant error messages. + +type_error(Type, Term) :- + throw(error(type_error(Type, Term), _)). +domain_error(Type, Term) :- + throw(error(domain_error(Type, Term), _)). +existence_error(Type, Term) :- + throw(error(existence_error(Type, Term), _)). +permission_error(Action, Type, Term) :- + throw(error(permission_error(Action, Type, Term), _)). +instantiation_error(_Term) :- + throw(error(instantiation_error, _)). +representation_error(Reason) :- + throw(error(representation_error(Reason), _)). + +%% must_be(+Type, @Term) is det. +% +% True if Term satisfies the type constraints for Type. Defined +% types are =atom=, =atomic=, =between=, =boolean=, =callable=, +% =chars=, =codes=, =text=, =compound=, =constant=, =float=, +% =integer=, =nonneg=, =positive_integer=, =negative_integer=, +% =nonvar=, =number=, =oneof=, =list=, =list_or_partial_list=, +% =symbol=, =var=, =rational= and =string=. +% +% Most of these types are defined by an arity-1 built-in predicate +% of the same name. Below is a brief definition of the other +% types. +% +% | boolean | one of =true= or =false= | +% | chars | Proper list of 1-character atoms | +% | codes | Proper list of Unicode character codes | +% | text | One of =atom=, =string=, =chars= or =codes= | +% | between(L,U) | Number between L and U (including L and U) | +% | nonneg | Integer >= 0 | +% | positive_integer | Integer > 0 | +% | negative_integer | Integer < 0 | +% | oneof(L) | Ground term that is member of L | +% | list(Type) | Proper list with elements of Type | +% | list_or_partial_list | A list or an open list (ending in a variable | +% +% @throws instantiation_error if Term is insufficiently +% instantiated and type_error(Type, Term) if Term is not of Type. + +must_be(Type, X) :- + ( has_type(Type, X) + -> true + ; is_not(Type, X) + ). + +%% is_not(+Type, @Term) +% +% Throws appropriate error. It is _known_ that Term is not of type +% Type. +% +% @throws type_error(Type, Term) +% @throws instantiation_error + +is_not(list, X) :- !, + not_a_list(list, X). +is_not(list(_), X) :- !, + not_a_list(list, X). +is_not(list_or_partial_list, X) :- !, + type_error(list, X). +is_not(chars, X) :- !, + not_a_list(chars, X). +is_not(codes, X) :- !, + not_a_list(codes, X). +is_not(var,_X) :- !, + representation_error(variable). +is_not(rational, X) :- !, + not_a_rational(X). +is_not(Type, X) :- + ( var(X) + -> instantiation_error(X) + ; ground_type(Type), \+ ground(X) + -> instantiation_error(X) + ; type_error(Type, X) + ). + +ground_type(ground). +ground_type(oneof(_)). +ground_type(stream). +ground_type(text). +ground_type(string). + +not_a_list(Type, X) :- + '$skip_list'(_, X, Rest), + ( var(Rest) + -> instantiation_error(X) + ; type_error(Type, X) + ). + +not_a_rational(X) :- + ( var(X) + -> instantiation_error(X) + ; X = rdiv(N,D) + -> must_be(integer, N), must_be(integer, D), + type_error(rational,X) + ; type_error(rational,X) + ). + +%% is_of_type(+Type, @Term) is semidet. +% +% True if Term satisfies Type. + +is_of_type(Type, Term) :- + has_type(Type, Term). + + +%% has_type(+Type, @Term) is semidet. +% +% True if Term satisfies Type. + +has_type(impossible, _) :- instantiation_error(_). +has_type(any, _). +has_type(atom, X) :- atom(X). +has_type(atomic, X) :- atomic(X). +has_type(between(L,U), X) :- ( integer(L) + -> integer(X), between(L,U,X) + ; number(X), X >= L, X =< U + ). +has_type(boolean, X) :- (X==true;X==false), !. +has_type(callable, X) :- callable(X). +has_type(chars, X) :- chars(X). +has_type(codes, X) :- codes(X). +has_type(text, X) :- text(X). +has_type(compound, X) :- compound(X). +has_type(constant, X) :- atomic(X). +has_type(float, X) :- float(X). +has_type(ground, X) :- ground(X). +has_type(integer, X) :- integer(X). +has_type(nonneg, X) :- integer(X), X >= 0. +has_type(positive_integer, X) :- integer(X), X > 0. +has_type(negative_integer, X) :- integer(X), X < 0. +has_type(nonvar, X) :- nonvar(X). +has_type(number, X) :- number(X). +has_type(oneof(L), X) :- ground(X), memberchk(X, L). +has_type(proper_list, X) :- is_list(X). +has_type(list, X) :- is_list(X). +has_type(list_or_partial_list, X) :- is_list_or_partial_list(X). +has_type(symbol, X) :- atom(X). +has_type(var, X) :- var(X). +has_type(rational, X) :- rational(X). +has_type(string, X) :- string(X). +has_type(stream, X) :- is_stream(X). +has_type(list(Type), X) :- is_list(X), element_types(X, Type). + +chars(0) :- !, fail. +chars([]). +chars([H|T]) :- + atom(H), atom_length(H, 1), + chars(T). + +codes(x) :- !, fail. +codes([]). +codes([H|T]) :- + integer(H), between(1, 0x10ffff, H), + codes(T). + +text(X) :- + ( atom(X) + ; string(X) + ; chars(X) + ; codes(X) + ), !. + +element_types([], _). +element_types([H|T], Type) :- + must_be(Type, H), + element_types(T, Type). + +is_list_or_partial_list(L0) :- + '$skip_list'(_, L0,L), + ( var(L) -> true ; L == [] ). + +:- if(current_prolog_flag(dialect, yap)). + +% vsc: I hope it works like this +'$skip_list'(_, Rest, Rest) :- var(Rest), !. +'$skip_list'(_, [], _) :- !, fail. +'$skip_list'(Anything, [_|More], Rest) :- + '$skip_list'(Anything, [_|More], Rest). +'$skip_list'(Anything, [_|More], Rest) :- + '$skip_list'(Anything, More, Rest). +'$skip_list'(_Anything, Rest, Rest). + +:- endif. + + diff --git a/library/maplist.pl b/library/maplist.pl new file mode 100755 index 000000000..e770ab28d --- /dev/null +++ b/library/maplist.pl @@ -0,0 +1,103 @@ +/* $Id: maplist.pl,v 1.2 2008-06-05 19:33:51 rzf Exp $ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: jan@swi.psy.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2002, University of Amsterdam + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(maplist, + [ maplist/2, % :Goal, +List + maplist/3, % :Goal, ?List1, ?List2 + maplist/4, % :Goal, ?List1, ?List2, ?List3 + maplist/5, % :Goal, ?List1, ?List2, ?List3, List4 + forall/2 % :Goal, :Goal + ]). + +:- module_transparent + maplist/2, + maplist2/2, + maplist/3, + maplist2/3, + maplist/4, + maplist2/4, + maplist/5, + maplist2/5, + forall/2. + +% maplist(:Goal, +List) +% +% True if Goal can succesfully be applied on all elements of List. +% Arguments are reordered to gain performance as well as to make +% the predicate deterministic under normal circumstances. + +maplist(Goal, List) :- + maplist2(List, Goal). + +maplist2([], _). +maplist2([Elem|Tail], Goal) :- + call(Goal, Elem), + maplist2(Tail, Goal). + +% maplist(:Goal, ?List1, ?List2) +% +% True if Goal can succesfully be applied to all succesive pairs +% of elements of List1 and List2. + +maplist(Goal, List1, List2) :- + maplist2(List1, List2, Goal). + +maplist2([], [], _). +maplist2([Elem1|Tail1], [Elem2|Tail2], Goal) :- + call(Goal, Elem1, Elem2), + maplist2(Tail1, Tail2, Goal). + +% maplist(:Goal, ?List1, ?List2, ?List3) +% +% True if Goal can succesfully be applied to all succesive triples +% of elements of List1..List3. + +maplist(Goal, List1, List2, List3) :- + maplist2(List1, List2, List3, Goal). + +maplist2([], [], [], _). +maplist2([Elem1|Tail1], [Elem2|Tail2], [Elem3|Tail3], Goal) :- + call(Goal, Elem1, Elem2, Elem3), + maplist2(Tail1, Tail2, Tail3, Goal). + +% maplist(:Goal, ?List1, ?List2, ?List3, List4) +% +% True if Goal can succesfully be applied to all succesive +% quadruples of elements of List1..List4 + +maplist(Goal, List1, List2, List3, List4) :- + maplist2(List1, List2, List3, List4, Goal). + +maplist2([], [], [], [], _). +maplist2([Elem1|Tail1], [Elem2|Tail2], [Elem3|Tail3], [Elem4|Tail4], Goal) :- + call(Goal, Elem1, Elem2, Elem3, Elem4), + maplist2(Tail1, Tail2, Tail3, Tail4, Goal). + diff --git a/library/occurs.yap b/library/occurs.yap new file mode 100755 index 000000000..d44ea70d1 --- /dev/null +++ b/library/occurs.yap @@ -0,0 +1,141 @@ +/* $Id: occurs.yap,v 1.1 2008-02-12 17:03:52 vsc Exp $ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: jan@swi.psy.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2002, University of Amsterdam + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(occurs, + [ contains_term/2, % +SubTerm, +Term + contains_var/2, % +SubTerm, +Term + free_of_term/2, % +SubTerm, +Term + free_of_var/2, % +SubTerm, +Term + occurrences_of_term/3, % +SubTerm, +Term, ?Tally + occurrences_of_var/3, % +SubTerm, +Term, ?Tally + sub_term/2, % -SubTerm, +Term + sub_var/2 % -SubTerm, +Term (SWI extra) + ]). + +:- use_module(library(arg), + [genarg/3]). + + +/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +This is a SWI-Prolog implementation of the corresponding Quintus +library, based on the generalised arg/3 predicate of SWI-Prolog. +- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */ + +%% contains_term(+Sub, +Term) is semidet. +% +% Succeeds if Sub is contained in Term (=, deterministically) + +contains_term(X, X) :- !. +contains_term(X, Term) :- + compound(Term), + genarg(_, Term, Arg), + contains_term(X, Arg), !. + + +%% contains_var(+Sub, +Term) is det. +% +% Succeeds if Sub is contained in Term (==, deterministically) + +contains_var(X0, X1) :- + X0 == X1, !. +contains_var(X, Term) :- + compound(Term), + genarg(_, Term, Arg), + contains_var(X, Arg), !. + +%% free_of_term(+Sub, +Term) +% +% Succeeds of Sub does not unify to any subterm of Term + +free_of_term(Sub, Term) :- + \+ contains_term(Sub, Term). + +%% free_of_var(+Sub, +Term) +% +% Succeeds of Sub is not equal (==) to any subterm of Term + +free_of_var(Sub, Term) :- + \+ contains_var(Sub, Term). + +%% occurrences_of_term(+SubTerm, +Term, ?Count) +% +% Count the number of SubTerms in Term + +occurrences_of_term(Sub, Term, Count) :- + count(sub_term(Sub, Term), Count). + +%% occurrences_of_var(+SubTerm, +Term, ?Count) +% +% Count the number of SubTerms in Term + +occurrences_of_var(Sub, Term, Count) :- + count(sub_var(Sub, Term), Count). + +%% sub_term(-Sub, +Term) +% +% Generates (on backtracking) all subterms of Term. + +sub_term(X, X). +sub_term(X, Term) :- + compound(Term), + genarg(_, Term, Arg), + sub_term(X, Arg). + +%% sub_var(-Sub, +Term) +% +% Generates (on backtracking) all subterms (==) of Term. + +sub_var(X0, X1) :- + X0 == X1. +sub_var(X, Term) :- + compound(Term), + genarg(_, Term, Arg), + sub_var(X, Arg). + + + /******************************* + * UTIL * + *******************************/ + +%% count(+Goal, -Count) +% +% Count number of times Goal succeeds. + +count(Goal, Count) :- + State = count(0), + ( Goal, + arg(1, State, N0), + N is N0 + 1, + nb_setarg(1, State, N), + fail + ; arg(1, State, Count) + ). + diff --git a/library/pairs.pl b/library/pairs.pl new file mode 100755 index 000000000..2ebb595dd --- /dev/null +++ b/library/pairs.pl @@ -0,0 +1,162 @@ +/* $Id: pairs.pl,v 1.1 2008-02-12 17:03:52 vsc Exp $ + + Part of SWI-Prolog + + Author: Jan Wielemaker + E-mail: wielemak@science.uva.nl + WWW: http://www.swi-prolog.org + Copyright (C): 1985-2006, University of Amsterdam + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License + as published by the Free Software Foundation; either version 2 + of the License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + As a special exception, if you link this library with other files, + compiled with a Free Software compiler, to produce an executable, this + library does not by itself cause the resulting executable to be covered + by the GNU General Public License. This exception does not however + invalidate any other reasons why the executable file might be covered by + the GNU General Public License. +*/ + +:- module(pairs, + [ pairs_keys_values/3, + pairs_values/2, + pairs_keys/2, + group_pairs_by_key/2, + transpose_pairs/2, + map_list_to_pairs/3 + ]). + +/** Operations on key-value lists + +This module implements common operations on Key-Value lists, also known +as _Pairs_. Pairs have great practical value, especially due to +keysort/2 and the library assoc.pl. + +This library is based on disussion in the SWI-Prolog mailinglist, +including specifications from Quintus and a library proposal by Richard +O'Keefe. + +@see keysort/2, library(assoc) +@author Jan Wielemaker +*/ + +%% pairs_keys_values(?Pairs, ?Keys, ?Values) is det. +% +% True if Keys holds the keys of Pairs and Values the values. +% +% Deterministic if any argument is instantiated to a finite list +% and the others are either free or finite lists. + +pairs_keys_values(Pairs, Keys, Values) :- + ( nonvar(Pairs) -> + pairs_keys_values_(Pairs, Keys, Values) + ; nonvar(Keys) -> + keys_values_pairs(Keys, Values, Pairs) + ; values_keys_pairs(Values, Keys, Pairs) + ). + +pairs_keys_values_([], [], []). +pairs_keys_values_([K-V|Pairs], [K|Keys], [V|Values]) :- + pairs_keys_values_(Pairs, Keys, Values). + +keys_values_pairs([], [], []). +keys_values_pairs([K|Ks], [V|Vs], [K-V|Pairs]) :- + keys_values_pairs(Ks, Vs, Pairs). + +values_keys_pairs([], [], []). +values_keys_pairs([V|Vs], [K|Ks], [K-V|Pairs]) :- + values_keys_pairs(Vs, Ks, Pairs). + +%% pairs_values(+Pairs, -Values) is det. +% +% Remove the keys from a list of Key-Value pairs. Same as +% pairs_keys_values(Pairs, _, Values) + +pairs_values([], []). +pairs_values([_-V|T0], [V|T]) :- + pairs_values(T0, T). + + +%% pairs_keys(+Pairs, -Keys) is det. +% +% Remove the values from a list of Key-Value pairs. Same as +% pairs_keys_values(Pairs, Keys, _) + +pairs_keys([], []). +pairs_keys([K-_|T0], [K|T]) :- + pairs_keys(T0, T). + + +%% group_pairs_by_key(+Pairs, -Joined:list(Key-Values)) is det. +% +% Group values with the same key. For example: +% +% == +% ?- group_pairs_by_key([a-2, a-1, b-4], X). +% +% X = [a-[2,1], b-[4]] +% == +% +% @param Pairs Key-Value list, sorted to the standard order +% of terms (as keysort/2 does) +% @param Joined List of Key-Group, where Group is the +% list of Values associated with Key. + +group_pairs_by_key([], []). +group_pairs_by_key([M-N|T0], [M-[N|TN]|T]) :- + same_key(M, T0, TN, T1), + group_pairs_by_key(T1, T). + +same_key(M, [M-N|T0], [N|TN], T) :- !, + same_key(M, T0, TN, T). +same_key(_, L, [], L). + + +%% transpose_pairs(+Pairs, -Transposed) is det. +% +% Swap Key-Value to Value-Key and sort the result on Value +% (the new key) using keysort/2. + +transpose_pairs(Pairs, Transposed) :- + flip_pairs(Pairs, Flipped), + keysort(Flipped, Transposed). + +flip_pairs([], []). +flip_pairs([Key-Val|Pairs], [Val-Key|Flipped]) :- + flip_pairs(Pairs, Flipped). + + +%% map_list_to_pairs(:Function, +List, -Keyed) +% +% Create a key-value list by mapping each element of List. +% For example, if we have a list of lists we can create a +% list of Length-List using +% +% == +% map_list_to_pairs(length, ListOfLists, Pairs), +% == + +:- module_transparent + map_list_to_pairs/3, + map_list_to_pairs2/3. + +map_list_to_pairs(Function, List, Pairs) :- + map_list_to_pairs2(List, Function, Pairs). + +map_list_to_pairs2([], _, []). +map_list_to_pairs2([H|T0], Pred, [K-H|T]) :- + call(Pred, H, K), + map_list_to_pairs2(T0, Pred, T). + diff --git a/misc/buildops b/misc/buildops new file mode 100644 index 000000000..47e4d08f6 --- /dev/null +++ b/misc/buildops @@ -0,0 +1,68 @@ + +:- use_module(library(lineutils), + [process/2, + split/3]). + +:- initialization(main). + +main :- + open('H/YapOpcodes.h',write,W), + header(W), + file('C/absmi.c',W), + format(W, '#ifdef YAPOR~n',[]), + file('OPTYap/or.insts.i',W), + format(W, '#endif~n',[]), + format(W, '#ifdef TABLING~n',[]), + file('OPTYap/tab.insts.i',W), + file('OPTYap/tab.tries.insts.i',W), + format(W, '#endif~n',[]), + footer(W), + close(W). + +header(W) :- + format(W,'~n /* This file was generated automatically by \"yap -L misc/buildops\"~n please do not update */~n~n',[]). + + +file(I,W) :- + open(I,read,R), + process(R,grep_opcode(W)), + close(R). + +grep_opcode(W, Line) :- + split(Line," ,();",[OP,Name,Type]), + Name \= "or_last", + check_op(OP), + special(Name,W), + format(W,' OPCODE(~s~36+,~s),~n',[Name,Type]), + end_special(Name,W). + +check_op("Op"). +check_op("BOp"). +check_op("PBOp"). +check_op("OpRW"). +check_op("OpW"). + +special(Name, W) :- + special_op(Name, Decl), !, + format(W,"#ifdef ~s~n",[Decl]). +special(_, _). + +end_special(Name, W) :- + special_op(Name, _), !, + format(W,"#endif~n",[]). +end_special(_, _). + +special_op("cut_c","CUT_C"). +special_op("cut_userc","CUT_C"). +special_op("run_eam","BEAM"). +special_op("retry_eam","BEAM"). +special_op("thread_local","THREADS"). + +/* or_last requires special handling */ +footer(W) :- + format(W,' /* this instruction is hardwired */~n',[]), + format(W,'#ifdef YAPOR~n',[]), + format(W,' OPCODE(~s~36+,~s)~n',["or_last","sblp"]), + format(W,'#else~n',[]), + format(W,' OPCODE(~s~36+,~s)~n',["or_last","p"]), + format(W,'#endif~n',[]).