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. */

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

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

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

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

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)