module coddom;
% ------------------------------------------------------------------- ;
% Copyright : J.A. van Hulzen, Twente University, Dept. of Computer ;
% Science, P.O.Box 217, 7500 AE Enschede, the Netherlands.;
% Author : W.N. Borst. ;
% ------------------------------------------------------------------- ;
symbolic$
fluid '(!:prec!:);
fluid '(pline!* posn!* orig!* ycoord!* ymax!* ymin!*);
symbolic procedure zeropp u;
% Returns T if u equals 0, regardless of u being
% an integer or an floating-point number.
if atom u then zerop u
else if car u eq '!:rd!: then rd!:zerop u
else nil$
symbolic procedure constp c;
% Returns T iff c is a number, NIL otherwise
numberp(c) or (pairp(c) and memq(car c, domainlist!*))$
symbolic procedure integerp i;
% Returns T iff i is an integer, NIL otherwise
numberp(i) and not floatp(i)$
symbolic procedure floatprop f;
% Returns T iff f is a (domain mode) float, NIL otherwise
floatp(f) or eqcar(f,'!:rd!:)$
symbolic procedure domprop d;
% Returns T iff d is a domain element, NIL otherwise
pairp(d) and memq(car d, domainlist!*);
symbolic procedure doublep d;
% Returns T iff d is an arbitrary precision rounded number, else NIL
eqcar(d,'!:rd!:) and pairp(cdr d);
symbolic procedure nil2zero u;
% Conversion NIL -> 0 needed for domain mode operations
if null(u) then 0 else u;
symbolic procedure zero2nil u;
% Conversion 0 -> NIL needed for domain mode operations
if !:zerop(u) then nil else u;
symbolic procedure dm!-plus(u,v);
nil2zero(!:plus(zero2nil u, zero2nil v));
symbolic procedure dm!-difference(u,v);
nil2zero(!:difference(zero2nil u, v));
symbolic procedure dm!-minus(u);
nil2zero(!:minus(u));
symbolic procedure dm!-abs(u);
if !:minusp(u) then dm!-minus(u) else u;
symbolic procedure dm!-min(u,v);
% Domain mode minimum
if dm!-gt(u,v) then v else u;
symbolic procedure dm!-max(u,v);
% Domain mode maximum
if dm!-gt(u,v) then u else v;
symbolic procedure dm!-times(u,v);
nil2zero(!:times(zero2nil u,zero2nil v));
symbolic procedure dm!-mkfloat(u);
% Use consistent and version independent trafo:
if integerp u then
%'!:rd!: . (u + 0.0)
%i2rd!* u
apply1(get('!:rd!:,'i2d),u)
else u;
symbolic procedure dm!-quotient(u,v);
% ---
% Domain mode quotient
% Always performs a floating point division and returns integers
% when possible
% ---
begin scalar noequiv;
noequiv:=!*noequiv;
!*noequiv:=nil; % for integer results in productscheme
return nil2zero(!:quotient(dm!-mkfloat u,dm!-mkfloat v));
!*noequiv:=noequiv;
end;
symbolic procedure dm!-expt(u,n);
nil2zero(!:expt(zero2nil u,n));
symbolic procedure dm!-gt(u,v);
% Domain mode greater than
!:minusp(dm!-difference(v,u));
symbolic procedure dm!-eq(u,v);
% Domain mode equal to
!:zerop(dm!-difference(u,v));
symbolic procedure dm!-lt(u,v);
% Domain mode less than
!:minusp dm!-difference(u,v);
symbolic procedure dm!-print(p);
% ---
% Domain mode PRIN2. This is an adapted version of mathprint.
% It is used for printing floats in the data structures
% (part 1 of CODPRI)
% ---
begin
terpri!* nil;
maprint(p,0);
pline!* := reverse pline!*;
scprint(pline!*, ymax!*);
pline!* := nil;
posn!* := orig!*;
ycoord!* := ymax!* := ymin!* := 0;
end;
symbolic procedure rd!:zerop!: u;
if atom cdr u then
ft!:zerop cdr u
else
bfzerop!: round!* u;
%-----------------------------------
% R3.5 seems to have machine-dependent precision algorithms.
% So we comment this out :
%
%symbolic procedure bfzerop!: u;
%% A new bigfloat zerop test which respects the precision setting
%begin scalar x;
% return
% << x:=cadr(u) * 10^(cddr(u) + !:prec!:);
% ((x>-50) and (x<50))
% >>
%end;
symbolic procedure ft!:zerop u;
begin scalar x;
return
<< x:=u * 10^!:prec!:;
(x>-50 and x<50)
>>
end;
symbolic procedure ftintequiv u;
begin scalar x;
return
if ft!:zerop(u-(x := fix u)) then x else nil
end;
symbolic procedure dm!-fixp u;
% u = (m . e), meaning m*10^e.
% Returned : fix(u) if u is interpretable as an integer,
% nil otherwise.
% JB 14/4/94
begin scalar r,fp;
r:=reverse explode car u;
fp:='t;
if (cdr u) >= 0
then for i:=1:(cdr u) do r:='!0 . r
else if (fp:=(length(r) > -(cdr u)))
then for i:=1:-cdr(u) do <<fp:=fp and eq(car r,'!0);
r:=cdr r>>
else r:= list '!0;
return if fp then compress reverse r
else nil;
end;
symbolic procedure bfintequiv u;
% We need to be sure we work with radix 10.
% This is guaranteed by `internal2decimal'.
% We need `dm!-fixp' to avoid entering an endless loop.
% JB 14/4/94
begin scalar i;
i:=dm!-fixp internal2decimal(u,!:prec!:);
return
if i then i else u
end;
symbolic procedure rdintequiv u;
if atom cdr u then
ftintequiv cdr u
else
bfintequiv u;
put('!:rd!:,'intequivfn,'rdintequiv);
% complex mode . Is momentarliy superfluous ??
symbolic expr procedure complexp v;
('complex member getdec(car v))
or
(!*complex and not(freeof(cdr v,'i)));
symbolic procedure myprepsq u;
if null numr u then 0 else sqform(u,function myprepf);
symbolic procedure myprepf u;
(if null x then 0 else replus x) where x=myprepf1(u,nil);
symbolic procedure myprepf1(u,v);
if null u then nil
else if domainp u then list retimes(u . exchk v)
else nconc!*(myprepf1(lc u,if mvar u eq 'k!* then v
else lpow u . v),
myprepf1(red u,v));
symbolic procedure cireval u;
% (plus a (times b i)) -> (!:cr!: !:crn!: !:gi!:)
begin
scalar ocmplx, res;
ocmplx:=!*complex;!*complex:='t;
res :=if freeof(u,'i)
then u
else myprepsq cadr aeval ireval u;
!*complex:=ocmplx;
return res;
end$
symbolic procedure remcomplex u;
% (!:cr!: !:crn!: !:gi!:) -> (plus a (times b i))
if atom u
then u
else if member(car u,'(!:cr!: !:crn!: !:gi!:))
then if eqcar(u,'!:gi!:)
then list('plus,cadr u,list('times,cddr u,'i))
else prepsq cr!:simp u
else if not(constp u) % Could be other domain-notation.
% JB 18/3/94.
then (car u)
. foreach el in cdr u collect remcomplex el
else u;
endmodule;
end;