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)  2011-2015, VU University Amsterdam
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(arithmetic,
   36          [ arithmetic_function/1,              % +Name/Arity
   37            arithmetic_expression_value/2       % :Expression, -Value
   38          ]).   39:- autoload(library(error),[type_error/2]).   40:- autoload(library(lists),[append/3]).   41
   42:- set_prolog_flag(generate_debug_info, false).

Extensible arithmetic

This module provides a portable partial replacement of SWI-Prolog's user-defined arithmetic (evaluable) functions. It defines the compatibility directive arithmetic_function/1 and support for both runtime and compile-time evaluation of expressions that are a mixture between Prolog predicates used as functions and built-in evaluable terms. */

   54:- meta_predicate
   55    arithmetic_function(:),
   56    arithmetic_expression_value(:, -).   57:- multifile
   58    evaluable/2.                            % Term, Module
 arithmetic_function(:NameArity) is det
Declare a predicate as an arithmetic function.
deprecated
- This function provides a partial work around for pure Prolog user-defined arithmetic functions that has been dropped in SWI-Prolog 5.11.23. Notably, it only deals with expression know at compile time.
   69arithmetic_function(Term) :-
   70    throw(error(context_error(nodirective, arithmetic_function(Term)), _)).
   71
   72arith_decl_clauses(NameArity,
   73                   [(:- public(PI)),
   74                    arithmetic:evaluable(Term, Q)
   75                   ]) :-
   76    prolog_load_context(module, M),
   77    strip_module(M:NameArity, Q, Spec),
   78    (   Q == M
   79    ->  PI = Name/ImplArity
   80    ;   PI = Q:Name/ImplArity
   81    ),
   82    (   Spec = Name/Arity
   83    ->  functor(Term, Name, Arity),
   84        ImplArity is Arity+1
   85    ;   type_error(predicate_indicator, Term)
   86    ).
 eval_clause(+Term, -Clause) is det
Clause is a clause for evaluating the arithmetic expression Term.
   93eval_clause(Term, (eval(Gen, M, Result) :- Body)) :-
   94    functor(Term, Name, Arity),
   95    functor(Gen, Name, Arity),
   96    Gen =.. [_|Args],
   97    eval_args(Args, PlainArgs, M, Goals, [Result is NewTerm]),
   98    NewTerm =.. [Name|PlainArgs],
   99    list_conj(Goals, Body).
  100
  101eval_args([], [], _, Goals, Goals).
  102eval_args([E0|T0], [A0|T], M, [eval(E0, M, A0)|GT], RT) :-
  103    eval_args(T0, T, M, GT, RT).
  104
  105list_conj([One], One) :- !.
  106list_conj([H|T0], (H,T)) :-
  107    list_conj(T0, T).
  108
  109eval_clause(Clause) :-
  110    current_arithmetic_function(Term),
  111    eval_clause(Term, Clause).
  112
  113term_expansion(eval('$builtin', _, _), Clauses) :-
  114    findall(Clause, eval_clause(Clause), Clauses).
 arithmetic_expression_value(:Expression, -Result) is det
True when Result unifies with the arithmetic result of evaluating Expression.
  122arithmetic_expression_value(M:Expression, Result) :-
  123    eval(Expression, M, Result).
  124
  125eval(Number, _, Result) :-
  126    number(Number),
  127    !,
  128    Result = Number.
  129eval(Term, M, Result) :-
  130    evaluable(Term, M2),
  131    visible(M, M2),
  132    !,
  133    call(M2:Term, Result).
  134eval('$builtin', _, _).
  135
  136
  137visible(M, M) :- !.
  138visible(M, Super) :-
  139    import_module(M, Parent),
  140    visible(Parent, Super).
  141
  142
  143                 /*******************************
  144                 *         COMPILE-TIME         *
  145                 *******************************/
  146
  147math_goal_expansion(A is Expr, Goal) :-
  148    expand_function(Expr, Native, Pre),
  149    tidy((Pre, A is Native), Goal).
  150math_goal_expansion(ExprA =:= ExprB, Goal) :-
  151    expand_function(ExprA, NativeA, PreA),
  152    expand_function(ExprB, NativeB, PreB),
  153    tidy((PreA, PreB, NativeA =:= NativeB), Goal).
  154math_goal_expansion(ExprA =\= ExprB, Goal) :-
  155    expand_function(ExprA, NativeA, PreA),
  156    expand_function(ExprB, NativeB, PreB),
  157    tidy((PreA, PreB, NativeA =\= NativeB), Goal).
  158math_goal_expansion(ExprA > ExprB, Goal) :-
  159    expand_function(ExprA, NativeA, PreA),
  160    expand_function(ExprB, NativeB, PreB),
  161    tidy((PreA, PreB, NativeA > NativeB), Goal).
  162math_goal_expansion(ExprA < ExprB, Goal) :-
  163    expand_function(ExprA, NativeA, PreA),
  164    expand_function(ExprB, NativeB, PreB),
  165    tidy((PreA, PreB, NativeA < NativeB), Goal).
  166math_goal_expansion(ExprA >= ExprB, Goal) :-
  167    expand_function(ExprA, NativeA, PreA),
  168    expand_function(ExprB, NativeB, PreB),
  169    tidy((PreA, PreB, NativeA >= NativeB), Goal).
  170math_goal_expansion(ExprA =< ExprB, Goal) :-
  171    expand_function(ExprA, NativeA, PreA),
  172    expand_function(ExprB, NativeB, PreB),
  173    tidy((PreA, PreB, NativeA =< NativeB), Goal).
  174
  175expand_function(Expression, NativeExpression, Goal) :-
  176    do_expand_function(Expression, NativeExpression, Goal0),
  177    tidy(Goal0, Goal).
  178
  179do_expand_function(X, X, true) :-
  180    evaluable(X),
  181    !.
  182do_expand_function(Function, Result, ArgCode) :-
  183    current_arithmetic_function(Function),
  184    !,
  185    Function =.. [Name|Args],
  186    expand_function_arguments(Args, ArgResults, ArgCode),
  187    Result =.. [Name|ArgResults].
  188do_expand_function(Function, Result, (ArgCode, Pred)) :-
  189    prolog_load_context(module, M),
  190    evaluable(Function, M2),
  191    visible(M, M2),
  192    !,
  193    Function =.. [Name|Args],
  194    expand_predicate_arguments(Args, ArgResults, ArgCode),
  195    append(ArgResults, [Result], PredArgs),
  196    Pred =.. [Name|PredArgs].
  197do_expand_function(Function, _, _) :-
  198    type_error(evaluable, Function).
  199
  200
  201expand_function_arguments([], [], true).
  202expand_function_arguments([H0|T0], [H|T], (A,B)) :-
  203    do_expand_function(H0, H, A),
  204    expand_function_arguments(T0, T, B).
  205
  206expand_predicate_arguments([], [], true).
  207expand_predicate_arguments([H0|T0], [H|T], (A,B)) :-
  208    do_expand_function(H0, H1, A0),
  209    (   callable(H1),
  210        current_arithmetic_function(H1)
  211    ->  A = (A0, H is H1)
  212    ;   A = A0,
  213        H = H1
  214    ),
  215    expand_predicate_arguments(T0, T, B).
 evaluable(F) is semidet
True if F and all its subterms are evaluable terms or variables.
  221evaluable(F) :-
  222    var(F),
  223    !.
  224evaluable(F) :-
  225    number(F),
  226    !.
  227evaluable([_Code]) :- !.
  228evaluable(Func) :-                              % Funtional notation.
  229    functor(Func, ., 2),
  230    !.
  231evaluable(F) :-
  232    string(F),
  233    !,
  234    string_length(F, 1).
  235evaluable(F) :-
  236    current_arithmetic_function(F),
  237    (   compound(F)
  238    ->  forall(arg(_,F,A), evaluable(A))
  239    ;   true
  240    ).
 tidy(+GoalIn, -GoalOut)
Cleanup the output from expand_function/3.
  246tidy(A, A) :-
  247    var(A),
  248    !.
  249tidy(((A,B),C), R) :-
  250    !,
  251    tidy((A,B,C), R).
  252tidy((true,A), R) :-
  253    !,
  254    tidy(A, R).
  255tidy((A,true), R) :-
  256    !,
  257    tidy(A, R).
  258tidy((A, X is Y), R) :-
  259    var(X), var(Y),
  260    !,
  261    tidy(A, R),
  262    X = Y.
  263tidy((A,B), (TA,TB)) :-
  264    !,
  265    tidy(A, TA),
  266    tidy(B, TB).
  267tidy(A, A).
  268
  269
  270                 /*******************************
  271                 *        EXPANSION HOOK        *
  272                 *******************************/
  273
  274:- multifile
  275    system:term_expansion/2,
  276    system:goal_expansion/2.  277
  278system:term_expansion((:- arithmetic_function(Term)), Clauses) :-
  279    arith_decl_clauses(Term, Clauses).
  280
  281system:goal_expansion(Math, MathGoal) :-
  282    math_goal_expansion(Math, MathGoal)