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

   68:- multifile evaluable/2.                       % Term, Module
 arithmetic_function(NameArity) is det
Declare a predicate as an arithmetic function.
   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? 
 eval_clause(+Term, -Clause) is det
Clause is a clause for evaluating the built-in arithmetic expression Term.
  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	).
 arithmetic_expression_value(:Expression, -Result) is det
True when Result unifies with the arithmetic result of evaluating Expression.
  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).
 evaluable(F) is semidet
True if F and all its subterms are variables or evaluable terms by builtin functions.
  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).
 tidy(+GoalIn, -GoalOut)
Cleanup the output from expand_function/3.
  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)