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:- (current_prolog_flag(optimise, Opt), 139 nb_setval('arithmetic_types:optflag',Opt), % save current value to restore later 140 set_prolog_flag(optimise,true) 141 ). 142 143restore_optimise :- % restore "optimise" flag 144 (nb_current('arithmetic_types:optflag', Opt) 145 -> (nb_delete('arithmetic_types:optflag'), set_prolog_flag(optimise,Opt)) 146 ; true 147 ).

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

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

337tidy(A, A) :- 338 var(A), 339 !. 340tidy(((A,B),C), R) :- 341 !, 342 tidy((A,B,C), R). 343tidy((true,A), R) :- 344 !, 345 tidy(A, R). 346tidy((A,true), R) :- 347 !, 348 tidy(A, R). 349tidy((A, X is Y), R) :- 350 var(X), var(Y), 351 !, 352 tidy(A, R), 353 X = Y. 354tidy((A,B), (TA,TB)) :- 355 !, 356 tidy(A, TA), 357 tidy(B, TB). 358tidy(A, A). 359 360 361 /******************************* 362 * EXPANSION HOOK * 363 *******************************/ 364 365:- multifile % context = 'user' so run before 'arithmetic' 366 user:term_expansion/2, 367 user:goal_expansion/2. 368 369user:term_expansion((:- arithmetic_function(Term)), Clauses) :- 370 arith_decl_clauses(Term, Clauses). 371 372user:goal_expansion(Math, MathGoal) :- % failure will default to 'arithmetic' 373 math_goal_expansion(Math, MathGoal)