1/* Cloned from arithmetic.pl, Part of SWI-Prolog 2 Modified for user defined arithmetic types by Rick Workman, 2021 3 4 Author: Jan Wielemaker 5 E-mail: J.Wielemaker@vu.nl 6 WWW: http://www.swi-prolog.org 7 Copyright (c) 2011-2015, VU University Amsterdam 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_types, 37 [ arithmetic_function/1, % +Name/Arity 38 arithmetic_expression_value/2 % Expression, -Value 39 ]). 40:- autoload(library(error),[type_error/2]). % for compile/load errors 41 42% the following permits calls to library(arithmetic) of evaluation fails here 43:- use_module(library(arithmetic), 44 [arithmetic_expression_value/2 as def_arithmetic_expression_value] 45 ). 46 47%:- set_prolog_flag(generate_debug_info, false).

Extensible arithmetic types

This module extends the existing library(arithmetic) to support expressions with atomic values and user defined types. Such types include compound terms which are not functions. A user defined type is typically packaged as a module with its associated function definitions. These predicates need not, and typically do not export the predicates; the exports of such modules are the set of globally visible functions they define. Functions can be "polymorphic" in that the same function Name/Arity can be defined for more than one type; in such cases they are distinguished by the argument types.

This module extends the functionality of library(arithmetic) and exports the same predicate set. Conficts are largely avoided since arithmetic type expansion is done before library(arithmetic) expansion is invoked.

Functions are defined using the directive arithmetic_function/1. Runtime evaluation is provided by arithmetic_expression_value/2. */

74arithmetic_function(Term) :- 75 throw(error(context_error(nodirective, arithmetic_function(Term)), _)). 76 77arith_decl_clauses(NameArity, Clauses) :- 78 pred_indicator(NameArity,Name,Arity) 79 -> 80 compound_name_arity(Term, Name, Arity), % for possible 0 arity 81 ImplArity is Arity+1, 82 functor(Pred, Name, ImplArity), 83 prolog_load_context(module, M), 84 defining_context(M:Pred,Q), 85 (evaluable(Term, Q) % make idempotent 86 -> Clauses=[] 87 ; Clauses=[arithmetic_types:evaluable(Term, Q)] 88 ) 89 ; type_error(predicate_indicator, NameArity). 90 91pred_indicator(_:NameArity, Name, Arity) :- % for compatibility - throw away any specified module 92 pred_indicator(NameArity, Name, Arity). 93pred_indicator(Name/Arity, Name, Arity). 94 95defining_context(Pred,M) :- 96 predicate_property(Pred,implementation_module(M)), !. % local to M 97defining_context(Pred,C) :- 98 predicate_property(Pred,imported_from(C)), !. % imported from C 99defining_context(_,user). % not found, sorted out at evaluation?

106eval_clause(roundtoward(_,Round), (eval(Gen,Result) :- Body)) :- 107 !, 108 Gen = roundtoward(Arg,Round), 109 eval_args([Arg], [PlainArg], Goals, 110 [Result is roundtoward(PlainArg,Round)]), 111 list_conj(Goals, Body). 112eval_clause(Term, (eval(Gen, Result) :- Body)) :- 113 functor(Term, Name, Arity), 114 functor(Gen, Name, Arity), 115 Gen =.. [_|Args], 116 eval_args(Args, PlainArgs, Goals, [Result is NewTerm]), 117 NewTerm =.. [Name|PlainArgs], 118 list_conj(Goals, Body). 119 120eval_args([], [], Goals, Goals). 121eval_args([E0|T0], [A0|T], [eval(E0, A0)|GT], RT) :- 122 eval_args(T0, T, GT, RT). 123 124list_conj([], !). 125list_conj([H|T0], (H,T)) :- 126 list_conj(T0, T). 127 128eval_clause(Clause) :- 129 current_arithmetic_function(Term), 130 eval_clause(Term, Clause). 131 132term_expansion(eval('$builtin', _), Clauses) :- 133 findall(Clause, eval_clause(Clause), Clauses). 134 135% 136% Compile arithmetic in eval/2 (particularly '$builtin') 137% 138:- set_prolog_flag(optimise,true).

145arithmetic_expression_value(Expression, Result) :- 146 eval(Expression, Result). 147 148eval(Var, _) :- % var check to prevent infinite eval loop 149 var(Var), 150 !, 151 eval_error(Var). 152eval(Number, Number) :- % first numbers 153 number(Number), 154 !. 155eval(Term, Result) :- % then user defined functions 156 eval_user(Term, Result), 157 !. 158eval('$builtin', _). % then builtins (expanded at load time) 159eval(Literal, Result) :- atom(Literal), % then if atom, maybe 0 arity user function 160 compound_name_arity(Term,Literal,0), 161 eval_user(Term, Result), 162 !. 163eval(Literal, Literal) :- atomic(Literal), % then other literals - evaluate to themselves 164 !. 165eval(Term, Result) :- % then see if library(arithmetic) works 166 catch(def_arithmetic_expression_value(Term, Result),_,fail), 167 !. 168eval(Term, _Result) :- % then fail 169 eval_error(Term). 170 171% 172% evaluate user defined function (via inline code or arithmetic_expression_value) 173% 174eval_user(Function, Result) :- 175 evaluable(Function, Module), % non-deterministic due to possible polymorphism 176 call(Module:Function, Result), 177 !. % commit to successful choice 178 179% 180% evaluation error - if debug, print warning, always fail 181% 182eval_error(Term) :- 183 current_prolog_flag(debug, true), % if false, silent fail 184 print_message(debug(arithmetic_types), arithmetic_types(Term)), 185 fail. 186 187prolog:message(arithmetic_types(Term)) --> 188 ['arithmetic_types: failed to evaluate ~w .'-[Term] ]. 189 190 /******************************* 191 * COMPILE-TIME * 192 *******************************/ 193 194math_goal_expansion(A is Expr, Goal) :- 195 expand_function(A, NativeA, PreA), % new 196 expand_function(Expr, Native, Pre), 197 tidy((PreA, Pre, NativeA is Native), Goal). 198math_goal_expansion(ExprA =:= ExprB, Goal) :- 199 expand_function(ExprA, NativeA, PreA), 200 expand_function(ExprB, NativeB, PreB), 201 tidy((PreA, PreB, NativeA =:= NativeB), Goal). 202math_goal_expansion(ExprA =\= ExprB, Goal) :- 203 expand_function(ExprA, NativeA, PreA), 204 expand_function(ExprB, NativeB, PreB), 205 tidy((PreA, PreB, NativeA =\= NativeB), Goal). 206math_goal_expansion(ExprA > ExprB, Goal) :- 207 expand_function(ExprA, NativeA, PreA), 208 expand_function(ExprB, NativeB, PreB), 209 tidy((PreA, PreB, NativeA > NativeB), Goal). 210math_goal_expansion(ExprA < ExprB, Goal) :- 211 expand_function(ExprA, NativeA, PreA), 212 expand_function(ExprB, NativeB, PreB), 213 tidy((PreA, PreB, NativeA < NativeB), Goal). 214math_goal_expansion(ExprA >= ExprB, Goal) :- 215 expand_function(ExprA, NativeA, PreA), 216 expand_function(ExprB, NativeB, PreB), 217 tidy((PreA, PreB, NativeA >= NativeB), Goal). 218math_goal_expansion(ExprA =< ExprB, Goal) :- 219 expand_function(ExprA, NativeA, PreA), 220 expand_function(ExprB, NativeB, PreB), 221 tidy((PreA, PreB, NativeA =< NativeB), Goal). 222 223expand_function(Expression, NativeExpression, Goal) :- 224 do_expand_function(Expression, NativeExpression, Goal0), 225 tidy(Goal0, Goal). 226 227do_expand_function(X, X, true) :- % #1 anything evaluable 228 evaluable(X), 229 !. 230do_expand_function(roundtoward(Expr0, Round), % #2 roundtoward special case 231 roundtoward(Expr, Round), 232 ArgCode) :- 233 !, 234 do_expand_function(Expr0, Expr, ArgCode). 235do_expand_function(X, Result, Result=X) :- % #3 lists, move out of expression 236 is_list(X), 237 !. 238do_expand_function(Function, % #4 user defined (before built in for overloading) 239 Result, 240 (ArgCode, arithmetic_types:eval(Pred,Result))) :- % Use eval/2 for polymorphic functions 241 evaluable(Function, _Module), 242 !, 243 compound_name_arguments(Function, Name, Args), 244 expand_predicate_arguments(Args, PredArgs, ArgCode), 245 Pred =.. [Name|PredArgs]. 246do_expand_function(Function, % #5 builtin (before atomic for family of pi) 247 Result, 248 ArgCode) :- 249 callable(Function), % guard before 250 current_arithmetic_function(Function), 251 !, 252 Function =.. [Name|Args], 253 expand_function_arguments(Args, ArgResults, ArgCode), 254 Result =.. [Name|ArgResults]. 255do_expand_function(Name, % #6 atom, possible user defined arity 0 256 Result, 257 arithmetic_types:eval_user(Pred,Result)) :- 258 atom(Name), 259 compound_name_arguments(Pred, Name, []), 260 evaluable(Pred, _Module), 261 !. 262do_expand_function(X, Result, Result=X) :- % #7 atomic literals, move out of expression 263 atomic(X), 264 !. 265do_expand_function(_Function, _, _) :- % #8 fail expansion (defaults to 'arithmetic') 266 fail. % type_error(evaluable, Function). 267 268 269expand_function_arguments([], [], true). 270expand_function_arguments([H0|T0], [H|T], (A,B)) :- 271 do_expand_function(H0, H, A), 272 expand_function_arguments(T0, T, B). 273 274expand_predicate_arguments([], [], true). 275expand_predicate_arguments([H0|T0], [H|T], (A,B)) :- 276 do_expand_function(H0, H1, A0), 277 ( callable(H1), 278 current_arithmetic_function(H1) 279 -> A = (A0, H is H1) 280 ; (A0 = (X=R) -> X=R, A=true ; A = A0), % optimization for atomics 281 H = H1 282 ), 283 expand_predicate_arguments(T0, T, B).

289evaluable(F) :- 290 var(F), 291 !. 292evaluable(F) :- 293 number(F), 294 !. 295evaluable([Code]) :- 296 % assumes possibility of future environment flag to disable 297 (current_prolog_flag(disable_codeTBD,true) -> fail ; eval_code(Code)), 298 !. 299evaluable(Func) :- % Functional notation. 300 functor(Func, ., 2), 301 !. 302evaluable(F) :- % unfortunate case - should be a literal 303 string(F), 304 !, 305 string_length(F, 1). 306evaluable(roundtoward(F,_Round)) :- % special case to ignore atom(_Round) 307 !, 308 evaluable(F). 309evaluable(F) :- 310 current_arithmetic_function(F), 311 \+ evaluable(F,_), % ** not overridden ** 312 ( compound(F) 313 -> forall(arg(_,F,A), evaluable(A)) 314 ; true 315 ). 316 317% as defined by builtin 318eval_code(Code) :- var(Code). 319eval_code(Code) :- integer(Code), Code>=0. 320eval_code(Code) :- atom(Code), atom_length(Code,1).

326tidy(A, A) :- 327 var(A), 328 !. 329tidy(((A,B),C), R) :- 330 !, 331 tidy((A,B,C), R). 332tidy((true,A), R) :- 333 !, 334 tidy(A, R). 335tidy((A,true), R) :- 336 !, 337 tidy(A, R). 338tidy((A, X is Y), R) :- 339 var(X), var(Y), 340 !, 341 tidy(A, R), 342 X = Y. 343tidy((A,B), (TA,TB)) :- 344 !, 345 tidy(A, TA), 346 tidy(B, TB). 347tidy(A, A). 348 349 350 /******************************* 351 * EXPANSION HOOK * 352 *******************************/ 353 354:- multifile % context = 'user' so run before 'arithmetic' 355 user:term_expansion/2, 356 user:goal_expansion/2. 357 358user:term_expansion((:- arithmetic_function(Term)), Clauses) :- 359 arith_decl_clauses(Term, Clauses). 360 361user:goal_expansion(Math, MathGoal) :- % failure will default to 'arithmetic' 362 math_goal_expansion(Math, MathGoal)