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