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-2023, VU University Amsterdam
    7                              SWI-Prolog Solutions b.v.
    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:- module(arithmetic,
   37          [ arithmetic_function/1,              % +Name/Arity
   38            arithmetic_expression_value/2       % :Expression, -Value
   39          ]).   40:- autoload(library(error),[type_error/2]).   41:- autoload(library(lists),[append/3]).   42
   43:- set_prolog_flag(generate_debug_info, false).   44
   45/** <module> Extensible arithmetic
   46
   47This module provides a  portable   partial  replacement  of SWI-Prolog's
   48user-defined  arithmetic  (evaluable)   functions.    It   defines   the
   49compatibility  directive  arithmetic_function/1  and  support  for  both
   50runtime and compile-time evaluation of expressions   that  are a mixture
   51between Prolog predicates  used  as   functions  and  built-in evaluable
   52terms.
   53*/
   54
   55:- meta_predicate
   56    arithmetic_function(:),
   57    arithmetic_expression_value(:, -).   58:- multifile
   59    evaluable/2.                            % Term, Module
   60
   61%!  arithmetic_function(:NameArity) is det.
   62%
   63%   Declare a predicate as  an  arithmetic   function.  The  function is
   64%   visible in the module in which it is defined as well as modules that
   65%   import the implementation predicate or inherit from this module. For
   66%   example:
   67%
   68%   ```
   69%   :- use_module(library(arithmetic)).
   70%   :- arithmetic_function(mid/2).
   71%   mid(A,B,C) :- C is (A+B)/2.
   72%   ```
   73%
   74%   After which we may call `?- A is mid(3,5).`, resulting in `A = 4`.
   75%
   76%   The implementation uses goal_expansion/2 to   rewrite  an arithmetic
   77%   expression using user functions  into   a  conjunction of arithmetic
   78%   evaluation and predicate calls.  This   implies  that the expression
   79%   must be known at compile time. Runtime evaluation is supported using
   80%   arithmetic_expression_value/2.
   81%
   82%   @deprecated This function provides a partial   work  around for pure
   83%   Prolog user-defined arithmetic functions that   has  been dropped in
   84%   SWI-Prolog 5.11.23. Notably, it only deals   with expression know at
   85%   compile time.
   86
   87arithmetic_function(Term) :-
   88    throw(error(context_error(nodirective, arithmetic_function(Term)), _)).
   89
   90arith_decl_clauses(NameArity,
   91                   [(:- public(PI)),
   92                    arithmetic:evaluable(Term, Q)
   93                   ]) :-
   94    prolog_load_context(module, M),
   95    strip_module(M:NameArity, Q, Spec),
   96    (   Q == M
   97    ->  PI = Name/ImplArity
   98    ;   PI = Q:Name/ImplArity
   99    ),
  100    (   Spec = Name/Arity
  101    ->  functor(Term, Name, Arity),
  102        ImplArity is Arity+1
  103    ;   type_error(predicate_indicator, Term)
  104    ).
  105
  106%!  eval_clause(+Term, -Clause) is det.
  107%
  108%   Clause is a clause  for   evaluating  the  arithmetic expression
  109%   Term.
  110
  111eval_clause(roundtoward(_,Round), (eval(Gen,M,Result) :- Body)) :-
  112    !,
  113    Gen = roundtoward(Arg,Round),
  114    eval_args([Arg], [PlainArg], M, Goals,
  115              [Result is roundtoward(PlainArg,Round)]),
  116    list_conj(Goals, Body).
  117eval_clause(Term, (eval(Gen, M, Result) :- Body)) :-
  118    functor(Term, Name, Arity),
  119    functor(Gen, Name, Arity),
  120    Gen =.. [_|Args],
  121    eval_args(Args, PlainArgs, M, Goals, [Result is NewTerm]),
  122    NewTerm =.. [Name|PlainArgs],
  123    list_conj(Goals, Body).
  124
  125eval_args([], [], _, Goals, Goals).
  126eval_args([E0|T0], [A0|T], M, [eval(E0, M, A0)|GT], RT) :-
  127    eval_args(T0, T, M, GT, RT).
  128
  129list_conj([One], One) :- !.
  130list_conj([H|T0], (H,T)) :-
  131    list_conj(T0, T).
  132
  133eval_clause(Clause) :-
  134    current_arithmetic_function(Term),
  135    eval_clause(Term, Clause).
  136
  137term_expansion(eval('$builtin', _, _), Clauses) :-
  138    findall(Clause, eval_clause(Clause), Clauses).
  139
  140
  141%!  arithmetic_expression_value(:Expression, -Result) is det.
  142%
  143%   True  when  Result  unifies  with    the  arithmetic  result  of
  144%   evaluating Expression.
  145
  146arithmetic_expression_value(M:Expression, Result) :-
  147    eval(Expression, M, Result).
  148
  149eval(Number, _, Result) :-
  150    number(Number),
  151    !,
  152    Result = Number.
  153eval(Term, M, Result) :-
  154    evaluable(Term, M2),
  155    visible(Term, M, M2),
  156    !,
  157    call(M2:Term, Result).
  158eval('$builtin', _, _).
  159
  160
  161visible(_, M, M) :- !.
  162visible(F, M, Super) :-
  163    import_module(M, Parent),
  164    visible(F, Parent, Super),
  165    !.
  166visible(F, M, Super) :-
  167    functor(F, Name, Arity),
  168    PredArity is Arity+1,
  169    functor(Head, Name, PredArity),
  170    predicate_property(M:Head, imported_from(Super)),
  171    !.
  172
  173                 /*******************************
  174                 *         COMPILE-TIME         *
  175                 *******************************/
  176
  177math_goal_expansion(A is Expr, Goal) :-
  178    expand_function(Expr, Native, Pre),
  179    tidy((Pre, A is Native), Goal).
  180math_goal_expansion(ExprA =:= ExprB, Goal) :-
  181    expand_function(ExprA, NativeA, PreA),
  182    expand_function(ExprB, NativeB, PreB),
  183    tidy((PreA, PreB, NativeA =:= NativeB), Goal).
  184math_goal_expansion(ExprA =\= ExprB, Goal) :-
  185    expand_function(ExprA, NativeA, PreA),
  186    expand_function(ExprB, NativeB, PreB),
  187    tidy((PreA, PreB, NativeA =\= NativeB), Goal).
  188math_goal_expansion(ExprA > ExprB, Goal) :-
  189    expand_function(ExprA, NativeA, PreA),
  190    expand_function(ExprB, NativeB, PreB),
  191    tidy((PreA, PreB, NativeA > NativeB), Goal).
  192math_goal_expansion(ExprA < ExprB, Goal) :-
  193    expand_function(ExprA, NativeA, PreA),
  194    expand_function(ExprB, NativeB, PreB),
  195    tidy((PreA, PreB, NativeA < NativeB), Goal).
  196math_goal_expansion(ExprA >= ExprB, Goal) :-
  197    expand_function(ExprA, NativeA, PreA),
  198    expand_function(ExprB, NativeB, PreB),
  199    tidy((PreA, PreB, NativeA >= NativeB), Goal).
  200math_goal_expansion(ExprA =< ExprB, Goal) :-
  201    expand_function(ExprA, NativeA, PreA),
  202    expand_function(ExprB, NativeB, PreB),
  203    tidy((PreA, PreB, NativeA =< NativeB), Goal).
  204
  205expand_function(Expression, NativeExpression, Goal) :-
  206    do_expand_function(Expression, NativeExpression, Goal0),
  207    tidy(Goal0, Goal).
  208
  209do_expand_function(X, X, true) :-
  210    evaluable(X),
  211    !.
  212do_expand_function(roundtoward(Expr0, Round),
  213                   roundtoward(Expr, Round),
  214                   ArgCode) :-
  215    !,
  216    do_expand_function(Expr0, Expr, ArgCode).
  217do_expand_function(Function, Result, ArgCode) :-
  218    current_arithmetic_function(Function),
  219    !,
  220    Function =.. [Name|Args],
  221    expand_function_arguments(Args, ArgResults, ArgCode),
  222    Result =.. [Name|ArgResults].
  223do_expand_function(Function, Result, (ArgCode, Pred)) :-
  224    prolog_load_context(module, M),
  225    evaluable(Function, M2),
  226    visible(Function, M, M2),
  227    !,
  228    Function =.. [Name|Args],
  229    expand_predicate_arguments(Args, ArgResults, ArgCode),
  230    append(ArgResults, [Result], PredArgs),
  231    Pred =.. [Name|PredArgs].
  232do_expand_function(Function, _, _) :-
  233    type_error(evaluable, Function).
  234
  235
  236expand_function_arguments([], [], true).
  237expand_function_arguments([H0|T0], [H|T], (A,B)) :-
  238    do_expand_function(H0, H, A),
  239    expand_function_arguments(T0, T, B).
  240
  241expand_predicate_arguments([], [], true).
  242expand_predicate_arguments([H0|T0], [H|T], (A,B)) :-
  243    do_expand_function(H0, H1, A0),
  244    (   callable(H1),
  245        current_arithmetic_function(H1)
  246    ->  A = (A0, H is H1)
  247    ;   A = A0,
  248        H = H1
  249    ),
  250    expand_predicate_arguments(T0, T, B).
  251
  252%!  evaluable(F) is semidet.
  253%
  254%   True if F and all its subterms are evaluable terms or variables.
  255
  256evaluable(F) :-
  257    var(F),
  258    !.
  259evaluable(F) :-
  260    number(F),
  261    !.
  262evaluable([_Code]) :- !.
  263evaluable(Func) :-                              % Funtional notation.
  264    functor(Func, ., 2),
  265    !.
  266evaluable(F) :-
  267    string(F),
  268    !,
  269    string_length(F, 1).
  270evaluable(roundtoward(F,_Round)) :-
  271    !,
  272    evaluable(F).
  273evaluable(F) :-
  274    current_arithmetic_function(F),
  275    (   compound(F)
  276    ->  forall(arg(_,F,A), evaluable(A))
  277    ;   true
  278    ).
  279
  280%!  tidy(+GoalIn, -GoalOut)
  281%
  282%   Cleanup the output from expand_function/3.
  283
  284tidy(A, A) :-
  285    var(A),
  286    !.
  287tidy(((A,B),C), R) :-
  288    !,
  289    tidy((A,B,C), R).
  290tidy((true,A), R) :-
  291    !,
  292    tidy(A, R).
  293tidy((A,true), R) :-
  294    !,
  295    tidy(A, R).
  296tidy((A, X is Y), R) :-
  297    var(X), var(Y),
  298    !,
  299    tidy(A, R),
  300    X = Y.
  301tidy((A,B), (TA,TB)) :-
  302    !,
  303    tidy(A, TA),
  304    tidy(B, TB).
  305tidy(A, A).
  306
  307
  308                 /*******************************
  309                 *        EXPANSION HOOK        *
  310                 *******************************/
  311
  312:- multifile
  313    system:term_expansion/2,
  314    system:goal_expansion/2.  315
  316system:term_expansion((:- arithmetic_function(Term)), Clauses) :-
  317    arith_decl_clauses(Term, Clauses).
  318
  319system:goal_expansion(Math, MathGoal) :-
  320    math_goal_expansion(Math, MathGoal)