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