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).