module general; % General functions for the support of REDUCE.
% Author: Anthony C. Hearn.
% Copyright (c) 1999 Anthony C. Hearn. All rights reserved.
global '(!!arbint);
!!arbint := 0; % Index for arbitrary constants.
symbolic procedure atomlis u;
null u or (atom car u and atomlis cdr u);
symbolic procedure carx(u,v);
if null cdr u then car u
else rerror(alg,5,list("Wrong number of arguments to",v));
% We assume concat2 is defined in the underlying Lisp system.
% symbolic macro procedure concat u;
% if null u then nil else expand(cdr u,'concat2);
% symbolic procedure delasc(u,v);
% if null v then nil
% else if atom car v or u neq caar v then car v . delasc(u,cdr v)
% else cdr v;
% This definition, due to A.C. Norman, avoids recursion.
symbolic procedure delasc(u,v);
begin scalar w;
while v do
<<if atom car v or u neq caar v then w := car v . w; v := cdr v>>;
return reversip w
end;
symbolic procedure eqexpr u;
% Returns true if U is an equation or similar structure
% (e.g., a rule).
not atom u
and flagp(car u,'equalopr) and cddr u and null cdddr u;
flag('(eq equal),'equalopr);
symbolic procedure evenp x; remainder(x,2)=0;
flag('(evenp),'opfn); % Make a symbolic operator.
symbolic procedure lengthc u;
%gives character length of U excluding string and escape chars;
begin integer n; scalar x;
n := 0;
x := explode u;
if car x eq '!" then return length x-2;
while x do
<<if car x eq '!! then x := cdr x;
n := n+1;
x := cdr x>>;
return n
end;
symbolic procedure makearbcomplex;
begin scalar ans;
!!arbint := !!arbint+1;
ans := car(simp!*(list('arbcomplex, !!arbint)));
% This CAR is NUMR, which is not yet defined.
return ans
end;
symbolic procedure mapcons(u,v);
for each j in u collect v . j;
symbolic procedure mappend(u,v);
for each j in u collect append(v,j);
symbolic procedure nlist(u,n);
if n=0 then nil else u . nlist(u,n-1);
symbolic procedure nth(u,n);
car pnth(u,n);
symbolic procedure pnth(u,n);
if null u then rerror(alg,6,"Index out of range")
else if n=1 then u
else pnth(cdr u,n-1);
symbolic procedure permp(u,v);
% This used to use EQ. However, SUBST use requires =.
if null u then t
else if car u=car v then permp(cdr u,cdr v)
else not permp(cdr u,subst(car v,car u,cdr v));
symbolic procedure permutations u;
% Returns list of all permutations of the list u.
if null u then list u
else for each j in u join mapcons(permutations delete(j,u),j);
symbolic procedure posintegerp u;
% True if U is a positive (non-zero) integer.
fixp u and u>0;
symbolic procedure remove(x,n);
% Returns X with Nth element removed;
if null x then nil
else if n=1 then cdr x
else car x . remove(cdr x,n-1);
symbolic procedure repasc(u,v,w);
% Replaces value of key U by V in association list W.
if null w then rerror(alg,7,list("key",u,"not found"))
else if u = caar w then (u . v) . cdr w
else car w . repasc(u,v,cdr w);
symbolic procedure repeats x;
if null x then nil
else if car x member cdr x then car x . repeats cdr x
else repeats cdr x;
symbolic procedure revpr u;
cdr u . car u;
symbolic procedure smember(u,v);
%determines if S-expression U is a member of V at any level;
if u=v then t
else if atom v then nil
else smember(u,car v) or smember(u,cdr v);
symbolic procedure smemql(u,v);
%Returns those members of id list U contained in V at any
%level (excluding quoted expressions);
if null u then nil
else if smemq(car u,v) then car u . smemql(cdr u,v)
else smemql(cdr u,v);
symbolic procedure smemqlp(u,v);
%True if any member of id list U is contained at any level
%in V (exclusive of quoted expressions);
if null v or numberp v then nil
else if atom v then v memq u
else if car v eq 'quote then nil
else smemqlp(u,car v) or smemqlp(u,cdr v);
symbolic procedure spaces n; for i := 1:n do prin2 " ";
symbolic procedure subla(u,v);
% Substitutes the atom u in v. Retains previous structure where
% possible.
if null u or null v then v
else if atom v then (if x then cdr x else v) where x=atsoc(v,u)
else (if y=v then v else y) where y=subla(u,car v) . subla(u,cdr v);
symbolic procedure xnp(u,v);
%returns true if the atom lists U and V have at least one common
%element;
u and (car u memq v or xnp(cdr u,v));
endmodule;
end;