35
36:- module(arithmetic_types,
37 [ arithmetic_function/1, 38 arithmetic_expression_value/2 39 ]). 40:- autoload(library(error),[type_error/2]). 41
43:- use_module(library(arithmetic),
44 [arithmetic_expression_value/2 as def_arithmetic_expression_value]
45 ). 46
68:- multifile evaluable/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), 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) 86 -> Clauses=[]
87 ; Clauses=[arithmetic_types:evaluable(Term, Q)]
88 )
89 ; type_error(predicate_indicator, NameArity).
90
91pred_indicator(_:NameArity, Name, Arity) :- 92 pred_indicator(NameArity, Name, Arity).
93pred_indicator(Name/Arity, Name, Arity).
94
95defining_context(Pred,M) :-
96 predicate_property(Pred,implementation_module(M)), !. 97defining_context(Pred,C) :-
98 predicate_property(Pred,imported_from(C)), !. 99defining_context(_,user).
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
138:- (current_prolog_flag(optimise, Opt),
139 nb_setval('arithmetic_types:optflag',Opt), 140 set_prolog_flag(optimise,true)
141 ). 142
143restore_optimise :- 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, _) :- 158 var(Var),
159 !,
160 eval_error(Var).
161eval(Number, Number) :- 162 number(Number),
163 !.
164eval(Term, Result) :- 165 eval_user(Term, Result),
166 !.
167eval('$builtin', _). 168eval(Literal, Result) :- atom(Literal), 169 compound_name_arity(Term,Literal,0),
170 eval_user(Term, Result),
171 !.
172eval(Literal, Literal) :- atomic(Literal), 173 !.
174eval(Term, Result) :- 175 catch(def_arithmetic_expression_value(Term, Result),_,fail),
176 !.
177eval(Term, _Result) :- 178 eval_error(Term).
179
180:- restore_optimise. 181
185eval_user(Function, Result) :-
186 evaluable(Function, Module), 187 call(Module:Function, Result),
188 !. 189
193eval_error(Term) :-
194 current_prolog_flag(debug, true), 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 204
205math_goal_expansion(A is Expr, Goal) :-
206 expand_function(A, NativeA, PreA), 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) :- 239 evaluable(X),
240 !.
241do_expand_function(roundtoward(Expr0, Round), 242 roundtoward(Expr, Round),
243 ArgCode) :-
244 !,
245 do_expand_function(Expr0, Expr, ArgCode).
246do_expand_function(X, Result, Result=X) :- 247 is_list(X),
248 !.
249do_expand_function(Function, 250 Result,
251 (ArgCode, arithmetic_types:eval_user(Pred,Result))) :- 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, 258 Result,
259 ArgCode) :-
260 callable(Function), 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, 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) :- 274 atomic(X),
275 !.
276do_expand_function(_Function, _, _) :- 277 fail. 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), 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 308 (current_prolog_flag(disable_codeTBD,true) -> fail ; eval_code(Code)),
309 !.
310evaluable(Func) :- 311 functor(Func, ., 2),
312 !.
313evaluable(F) :- 314 string(F),
315 !,
316 string_length(F, 1).
317evaluable(roundtoward(F,_Round)) :- 318 !,
319 evaluable(F).
320evaluable(F) :-
321 current_arithmetic_function(F),
322 \+ evaluable(F,_), 323 ( compound(F)
324 -> forall(arg(_,F,A), evaluable(A))
325 ; true
326 ).
327
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 364
365:- multifile 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) :- 373 math_goal_expansion(Math, MathGoal)
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. */