module assist; % Header Module for REDUCE 3.4 Extensions.
% create!-package('(assist switchext baglist genpurfunc control
% polyextensions transfunctions vectoroper matrext),
% '(contrib assist));
% % ********************************************************************
%
% Author: H. Caprasse <u214001@bliulg11.bitnet>.
% or <u214001@vm1.ulg.ac.be>
%
% Version and Date: Version 1.1, 15 September 1991.
% Revision history for version 1.0 :
%
% 5 Aug. 1991 : Corrections to RCONS
% Property NUMBER!_OF!_ARGS commented.
% Flag "NOVAL" on REDEXPR and LEADTERM eliminated.
% 1 Sept. 1991 : MAXLIST and MINLIST eliminated since they exist
% now in the basic package.
% 6 Sept. 1991 : Module "transfunctions" rewritten to conform to
% the new syntax for rules.
% FACT function eliminated since in the ARITH
% package under the name FACTORIAL.
% Function SIMPLIFY added to enforce full
% simplification in outputs of EXCALC.
% 12 Sept.1991 : Capabilities of the functions SHOW and SUPPRESS
% enlarged.
% Control of switches extended.
% ********************************************************************
%
endmodule;
module switchext$
fluid '(!*distribute);
switch distribute;
flag('(!*factor !*mcd !*div !*exp !*gcd !*rat !*rational !*rationalize
!*intstr !*reduced !*ratpri !*revpri !*distribute
!*ezgcd !*complex !*reduced !*lcm !*precise),'share)$
endmodule$
module baglist$
symbolic procedure rmklis u$
% This function works only for LIST-like objects.
begin scalar s,ss;integer n;
argnochk('mklist . u);
if length u = 2 then
<<s:=reval car u; n:=reval cadr u;
if car s eq 'list then ss:=
append(s,cdr rmklis(list(n+1-length s))) else nil>> else
if length u=1 then
<<n:=reval car u; for j:=1:n do s:=0 . s; ss:='list . s>>
else nil;
return ss end;
put('mklist,'psopfn,'rmklis);
global '(!:flaglis !:proplis); % To make properties and flags
% available in algebraic mode.
put('bag,'simpfn,'simpiden);
flag('(bag),'bag)$ % the default bag
flag('(bag),'reserved)$
symbolic (!:flaglis:=union(list list2('bag,'bag),!:flaglis))$
symbolic procedure !:delete(u,prop,val)$
if prop then
for each x in !:proplis do if x=list3(u,prop,val)
then !:proplis:=delete(x,!:proplis) else nil else
for each x in !:flaglis do if x=list2(u,val)
then !:flaglis:=delete(x,!:flaglis);
symbolic procedure !:bagno u; u eq 'list or flagp(u,'boolean);
symbolic procedure !:bagyes u; getd u or
gettype u member list('tvector,'vector) or
flagp( u,'opfn) or
get(u,'simpfn) or get(u,'psopfn) or
get(u,'fdegree) or get(u,'ifdegree);
symbolic procedure simpbagprop u$
% gives the bag property to identifier or baglike-list of identifiers U
% V is T if one creates the property or 0 if one destroys it.
% Use is bagprop(<list of atoms>,T or 0)
% Makes tests to avoid giving this property to an unsuitable object.
begin scalar id,bool;
id:= car u; bool:= if cadr u eq t then t;
if listp id then
<< for each x in id do simpbagprop list(x,bool) $
return bool>> else
if idp id and bool=t then
if !:bagno id then typerr (id,"BAG") else
if !:bagyes id then <<flag(list id,'bag),go to l1>> else
<<put(id,'simpfn,'simpiden)$ flag(list id,'bag)$ go to l1>>
else
if idp id and not bool then
<<remflag(list id,'bag); go to l1>>
else rederr("BAD ARGUMENT for bagprop");
l1: if bool then !:flaglis:=union(list list2(id,'bag),!:flaglis)
else !:delete(id,nil,'bag) end;
symbolic procedure putbag u; simpbagprop list(u,t);
% gives the bag property to identifier or baglike-list of identifiers u
% V is T to create the bag property.
symbolic procedure clearbag u; simpbagprop list(u,0);
% destroys the bag property of the identifier or the baglike-list u
symbolic rlistat '(putbag clearbag);
symbolic procedure bagp(u)$
% test of the baglike property of U$
not atom u and flagp(car u ,'bag)$
flag('(bagp),'boolean);
symbolic procedure nbglp(u,n)$
%Function which determines if U is not a bag at the level N.
% Used in DEPTH.
if n=0 then not baglistp u else
if atom u or not bglp!:!: car u then nil else
begin scalar uu$ uu:= u$
l1: uu:=cdr uu$
if null uu then return t$
if nbglp(car uu,n-1) then go to l1 else
return nil end$
symbolic procedure bglp!:!: u;
if not atom u then bglp!:!: car u else
if (flagp(u,'bag) or u eq 'list) then t else nil;
symbolic procedure baglistp u;
% This function is supposed to act on a prefix simplified expression.
not atom u and ( car u eq 'list or flagp(car u,'bag));
symbolic procedure nul!: u; baglistp u and null cdr u;
symbolic flag('(baglistp nul!:),'boolean);
symbolic procedure alistp u$
% Not for use in algebraic mode.
if null u then t else
(not atom car u) and alistp cdr u;
symbolic procedure abaglistp u;
% For use in algebraic mode. Recognizes when a bag-like object
% contains bags which themselves contain two and only two objects.
if null baglistp u or null baglistp cadr u then nil else
begin;
l1: u:=cdr u;
if null u then return t ;
if length car u <3 then return nil else go to l1 end;
flag('(abaglistp),'boolean);
% Definitions of operations on lists
symbolic procedure rexplis u;
% THIS PROCEDURE GENERALIZES BAGLIST TO ANY OBJECT AND GIVES A LIST OF
% THE ARGUMENTS OF U.
<<argnochk('kernlist . u);
if atom ( u:=reval car u) then nil else
if kernp mksq(u,1) then 'list . cdr u>> ;
put('kernlist,'psopfn,'rexplis);
symbolic procedure rlisbag u$
begin scalar x,prf;
argnochk('listbag . u);
x:=reval car u; prf :=reval cadr u;
if atom x then return nil else
<<simpbagprop list(prf,t) ; x:=prf . cdr x>>;
return x end;
% symbolic put('rlisbag,'number!_of!_args,2);
symbolic put('listbag,'psopfn,'rlisbag);
symbolic procedure rfirst li;
<<argnochk('first . li);
if bagp( li:=reval car li) then
if null cdr li then car li . nil else car li . cadr li . nil else
if car li neq 'list then typerr(li,"list or bag")
else if null cdr li then parterr(li,1)
else cadr li>>$
put('first,'psopfn,'rfirst);
symbolic procedure rsecond li;
<<argnochk ('second . li);
if bagp( li:=reval car li) then
if null cdr li or null cddr li then car li . nil
else car li . caddr li . nil
else if car li neq 'list then typerr(li,"list or bag")
else if null cdr li or null cddr li then parterr(li,2)
else caddr li>>;
put('second,'psopfn,'rsecond);
symbolic procedure rthird li;
<<argnochk ('third . li);
if bagp( li:=reval car li) then
if null cdr li or null cddr li or null cdddr li
then car li . nil else car li . cadddr li . nil
else if car li neq 'list then typerr(li,"list or bag")
else if null cdr li or null cddr li or null cdddr li
then parterr(li,3)
else cadddr li>>;
symbolic procedure rrest li;
<<argnochk('rest . li);
if bagp( li:=reval car li) then
if null cdr li then li . nil else car li . cddr li else
if car li neq 'list then typerr(li,"list or bag")
else 'list . if null (li:=cdr li) then li else cdr li>>$
symbolic put('rest,'psopfn,'rrest);
symbolic procedure rreverse u;
<<argnochk('reverse . u); u:=reval car u;
if bagp u then car u . reverse cdr u else
if car u neq 'list then typerr(u,"list or bag")
else 'list . reverse cdr u>>$
symbolic put('reverse,'psopfn,'rreverse);
symbolic procedure rlast u;
<<argnochk('last . u); u:=reval car u;
if bagp u then if null cdr u then u else
car u . car reverse cdr u . nil
else if car u neq 'list then typerr(u,"list or bag")
else if null cdr u then nil
else car reverse cdr u>>$
symbolic put('last,'psopfn,'rlast);
symbolic procedure rdc u;
if null cdr u then nil else car u . rdc cdr u;
symbolic procedure rbelast u;
<<argnochk('belast . u); u:=reval car u;
if bagp u then if null cdr u then u else car u . rdc cdr u else
if car u neq 'list then typerr(u,"list or bag")
else if null cdr u then u else 'list . rdc cdr u>>$
put('belast,'psopfn,'rbelast);
symbolic procedure rappend u;
begin scalar x,y;
argnochk ('append . u);
if length u neq 2 then rederr("append has TWO arguments");
x:=reval car u;
y:=reval cadr u;
if baglistp x and baglistp y then
return car x . append(cdr x,cdr y) else
typerr(list(x,y),"list or bag")
end ;
% put('rappend,'number!_of!_args,2);
put('append,'psopfn,'rappend);
symbolic procedure rcons u;
% This procedure does not work perfectly well when the package
% HEPHYS is entered because ISIMPA is applied by reval1 on the
% result of RCONS. When it is given by (BAG (LIST A B) C D) it gives
% the output BAG({A,B}) erasing C and D ! It is due to the fact that
% ISIMP1 and ISIMP2 do not accept SQ forms for identifiers.
% So avoid inputs like list(a,b).bag(c,d) when HEPHYS is loaded.
begin scalar x,y,z;
if (y := getrtypeor(x := revlis u)) eq 'hvector
then return if get('cons,'opmtch) and (z:=opmtch('cons . x))
then reval z
else prepsq simpdot x
else if getrtype(y:=cadr x) eq 'list
then return 'list . car x . cdadr x
else if bagp y
then return z:=car y . car x . cdr y
else if fixp y
then return z:=revalpart u
else typerr(x,"list or bag")
end;
% symbolic put('rcons,'number!_of!_args,2);
symbolic put('cons,'setqfn,'setpart!*);
symbolic put('cons,'psopfn,'rcons);
symbolic procedure lengthreval u;
begin scalar v,w;
if length u neq 1
then rederr "LENGTH called with wrong number of arguments"
else if idp car u and arrayp car u
then return 'list . get(car u,'dimension)
else if bagp (u:=reval car u)
then return length cdr u;
v := aeval u;
if (w := getrtype v) and (w := get(w,'lengthfn))
then return apply1(w,v)
else if atom v then return 1
else if not idp car v or not(w := get(car v,'lengthfn))
then typerr(u,"length argument")
else return apply1(w,cdr v)
end;
symbolic put('length,'psopfn,'lengthreval);
symbolic put('size,'psopfn,'lengthreval);
symbolic procedure rremove u;
% Allows one to remove the element n of bag u.
% First argument is a bag or list, second is an integer.
if length u neq 2 then
rederr("remove called with wrong number of arguments") else
begin scalar x;integer n;
argnochk('remove . u);
x:=reval car u; n:=reval cadr u;
if baglistp x then return car x . remove(cdr x,n) else
rederr(" first argument is a list or a bag, second is an integer")
end;
% symbolic put('rremove,'number!_of!_args,2);
symbolic put('remove,'psopfn,'rremove);
symbolic procedure rdelete u;
begin scalar x,y;
x:=reval car u; y:=reval cadr u;
if baglistp y then return delete(x,y) end;
symbolic put('delete,'psopfn,'rdelete);
% Use is delete(<any>,<bag or list>)
symbolic procedure rmember u;
% First argument is anything, second argument is a bag or list.
begin scalar x,y$
argnochk('member . u);
x:=reval car u;
y:=reval cadr u;
if baglistp y then
if (x:=member(x,cdr y))
then return car y . x else return nil
else typerr(y,"list or bag") end;
% symbolic put('rmember,'number!_of!_args,2);
symbolic put('member,'psopfn,'rmember);
% INPUT MUST BE " member (any , < bag OR list> ) ".
symbolic procedure relmult u;
if length u neq 2 then
rederr("elmult called with wrong number of arguments") else
begin scalar x,y; integer n;
argnochk('elmult . u);
x:=reval car u; % It is the object the multiplicity of which one
% wants to compute.
y:=reval cadr u; % IT IS THE list OR bag
if x=y then return 1 else
if baglistp y then
<<y:=cdr y;
while not null (y:=member(x,y)) do <<y:=cdr y;n:=n+1>>>>
else typerr(y,"list or bag");
return n end;
% symbolic put('relmult,'number!_of!_args,2);
symbolic put('elmult,'psopfn,'relmult);
% Use is " elmult (any , < bag OR list> ) " .
symbolic procedure rpair u$
begin scalar x,y,prf$
argnochk('pair . u);
if length u neq 2 then
rederr("pair called with wrong number of arguments");
x:=reval car u; y:=reval cadr u$
if not (baglistp x and baglistp y) then
rederr("arguments must be lists or bags") else
prf:=car x;x:=cdr x; y:=cdr y;
y:=pair(x,for each j in y collect list j);
return y:=prf . for each j in y collect prf . j end;
% symbolic put('rpair,'number!_of!_args,2);
symbolic put('pair,'psopfn,'rpair);
symbolic procedure depth!: u;
if not atom u and (car u eq 'list or flagp(car u,'bag))
then 1 + depth!: cadr u
else 0;
symbolic procedure rdepth(u)$
% Use is depth(<BAG or LIST>).
begin scalar x; integer n;
argnochk('depth . u);
x := reval car u;
if nbglp(x,n:=depth!: x) then
return n else return "bag or list of unequal depths" end;
put('depth,'psopfn,'rdepth);
symbolic procedure rinsert u;
% Use is insert(<any>, <list or bag>, <integer>).
begin scalar x,bg,bbg,prf; integer n;
argnochk('insert . u);
bg:=reval cadr u; n:=reval caddr u;
if not baglistp bg then typerr(bg,"list or bag") else
if n<=0 then rederr("third argument must be positive an integer") else
if (n:=n+1) > length bg then return append(bg,x:=list reval car u);
prf:=car bg; x:=reval car u;
for i:=3:n do <<bg:=cdr bg; bbg:=car bg . bbg>>;
bbg:=reverse bbg;
return bbg:=prf . append(bbg,cons(x,cdr bg))
end;
% symbolic put('insert,'number!_of!_args ,3);
symbolic put('insert,'psopfn,'rinsert);
symbolic procedure rposition u$
% Use is position(<any>,<LIST or BAG>).
begin scalar el,bg; integer n;
el:=reval car u;
if not baglistp (bg:=reval cadr u) then typerr(bg," list or bag");
n:=length( bg:=cdr bg);
if (bg:=member(el,bg))
then return (n:=n+1-length bg) else
msgpri(nil,el,"is not present in list or bag",nil,nil) end;
% put('rposition,'number!_of!_args,2);
put('position,'psopfn,'rposition);
% **********
% The functions below, when applied to objects containing SEVERAL bag
% prefixes have a rule to select them in the output object when this
% one is itself a bag: the first level prefix has priority over all
% other prefixes and will be selected, when needed, as the envelope
% of the output.
symbolic procedure !:assoc u;
if length u neq 2 then
rederr("asfirst called with wrong number of arguments") else
begin scalar x,y,prf;
argnochk('asfirst . u);
x:=reval car u; y:=reval cadr u;
if null baglistp y then typerr(y,"list or bag");
prf:=car y; y:=cdr y;
if null alistp y then typerr(y, "association list") else
y:=for each j in y collect cdr j;
return if null (y:=assoc(x,y)) then nil else prf . y end;
% symbolic put ('!:assoc,'number!_of!_args,2);
symbolic put('asfirst,'psopfn,'!:assoc);
% Use is : asfirst(<key>,<a-list>Y<a-bag>)
symbolic procedure !:rassoc u;
if length u neq 2 then
rederr("assecond called with wrong number of arguments") else
begin scalar x,y,prf;
argnochk('assecond . u);
x:=reval car u; y:=reval cadr u;
if null baglistp y then typerr(y,"list or bag");
prf:=car y; y:=cdr y;
if null alistp y then typerr(y, "association list") else
y:=for each j in y collect cdr j;
return if null (y:=rassoc(list x,y)) then nil else prf . y end;
% symbolic put ('!:rassoc,'number!_of!_args,2);
symbolic put('assecond,'psopfn,'!:rassoc);
% Use is : assecond(<key>,<a-list>Y<a-bag>)
symbolic procedure !:assoc2 u;
if length u neq 2 then
rederr("asrest called with wrong number of arguments") else
begin scalar x,y,prf;
argnochk('asrest . u);
x:=reval car u; y:=reval cadr u;
if null baglistp x or null baglistp y then
typerr(list(x,y),"list or bag");
prf:=car y; y:=cdr y; x:=cdr x;
if null alistp y then typerr(y, "association list") else
y:=for each j in y collect cdr j;
return if null (y:=assoc2(x,y)) then nil else prf . y end;
% symbolic put ('!:assoc2,'number!_of!_args,2);
symbolic put('asrest,'psopfn,'!:assoc2);
% Use is : asrest(<key>,<a-list>Y<a-bag>)
symbolic procedure lastassoc!*(u,v);
% Use is :
% aslast(<key as a last element>,<a-list>Y<a-bag>)
% Finds the sublist in which u is the last element in the
% compound list or bag v, or nil if it is not found.
if null v then nil
else begin scalar vv; vv:=car v;
while length vv > 1 do vv:=cdr vv;
if u = car vv then return car v
else return lastassoc!*(u,cdr v) end;
symbolic procedure !:lassoc u;
if length u neq 2 then
rederr("aslast called with wrong number of arguments") else
begin scalar x,y,prf;
argnochk('aslast . u);
x:=reval car u; y:=reval cadr u;
if null baglistp y then typerr(y,"list or bag");
prf:=car y; y:=cdr y;
if null alistp y then typerr(y, "association list") else
y:=for each j in y collect cdr j;
return if null (y:=lastassoc!*(x,y)) then nil else prf . y end;
% symbolic put ('!:lassoc,'number!_of!_args,2);
symbolic put('aslast,'psopfn,'!:lassoc);
symbolic procedure rasflist u;
% Use is :
% asflist(<key as a first element>,<a-list>Y<a-bag>)
% This procedure gives the LIST (or BAG) associated with the KEY con-
% tained in the first argument. The KEY is here the FIRST element
% of each sublist contained in the association list .
if length u neq 2 then
rederr("ASFLIST called with wrong number of arguments") else
begin scalar x,y,prf,res,aa;
x:=reval car u; y:=reval cadr u; prf:=car y;
if null cdr y then return y;
for each j in cdr y do if car j neq prf then
rederr list("prefix INSIDE the list or bag neq to",prf);
l1: aa:=!:assoc(list(x,y));
if not aa then return prf . reverse res;
res:=aa . res;
y:=delete(aa,y);
go to l1;
end$
symbolic put('asflist,'psopfn,'rasflist);
symbolic procedure rasslist u;
% Use is :
% asslist(<key as the second element>,<a-list>Y<a-bag>)
if length u neq 2 then
rederr("ASSLIST called with wrong number of arguments") else
begin scalar x,y,prf,res,aa;
x:=reval car u; y:=reval cadr u; prf:=car y;
if null cdr y then return y;
for each j in cdr y do if car j neq prf then
rederr list("prefix INSIDE the list or bag neq to",prf);
l1: aa:=!:rassoc(list(x,y));
if not aa then return prf . reverse res;
res:=aa . res;
y:=delete(aa,y);
go to l1;
end$
symbolic put('asslist,'psopfn,'rasslist);
symbolic procedure !:sublis u;
% Use is :
% restaslist(<bag-like object containing keys>,<a-list>Y<a-bag>)
% Output is a list containing the values associated to the selected
% keys.
if length u neq 2 then
rederr("restaslist called with wrong number of arguments") else
begin scalar x,y,yy,prf;
argnochk('sublis . u);
x:=reval car u;
y:=reval cadr u; prf:=car y;
if null baglistp y then typerr(y,"list or bag") else
if null alistp (y:=cdr y) then typerr(y," association list or bag")
else y:=for each j in y collect cdr j;
if baglistp x then <<x:=cdr x; x:=for each j in x collect
if assoc(j,y) then j>>;
y:=sublis(y,x); if atom y then yy:=list y else
for each j in y do if not null j then yy:=j . yy;
yy:=reverse yy;
return prf . for each j in yy collect
if atom j then prf . j . nil else prf . j$
end$
% symbolic put('!:sublis,'number!_of!_args,2);
symbolic put('restaslist,'psopfn,'!:sublis);
% Use is :
% restaslist(<bag-like object containing keys>,<a-list>Y<a-bag>)
% Output is a list containing the values associated to the selected
% keys.
% ******* End of functions which may change bag- or list- prefixes.
% FOR SUBSTITUTION OF IDENTIFIERS IT IS CONVENIENT TO USE :
symbolic procedure !:subst u;
<<argnochk('substitute . u);
reval subst(reval car u,reval cadr u,reval caddr u)>>;
% symbolic put('!:subst,'number!_of!_args,3);
symbolic put('substitute,'psopfn,'!:subst);
% Use is : substitute(<newid>,<oldid>,<in any>).
% May serve to transform ALL bags into lists or vice-versa.
symbolic procedure !:repla u;
if length u neq 2 then
rederr("repfirst called with wrong number of arguments") else
begin scalar x,y,prf;
argnochk('repfirst . u);
y:=reval car u; x:= reval cadr u;
if null baglistp x then typerr(x,"list or bag");
prf:= car x; x:=cdr x;
return prf . rplaca(x,y) end;
% symbolic put('!:repla,'number!_of!_args,2);
symbolic put('repfirst,'psopfn,'!:repla);
% Use is : repfirst(<any>, <bag or list>);
symbolic procedure !:repld u;
% Use is : replast(<any>, <bag or list>);
begin scalar x,y,prf;
argnochk('represt . u);
if length u neq 2 then
rederr("replast called with wrong number of arguments");
y:=reval car u; x:= reval cadr u;
if null baglistp x then typerr(u,"list or bag");
prf:= car x; x:=cdr x;
return prf . rplacd(x,list y) end;
% symbolic put('!:repld,'number!_of!_args,2);
symbolic put('represt,'psopfn,'!:repld);
symbolic procedure rinsert u;
begin scalar x,bg,bbg,prf; integer n;
argnochk('insert . u);
bg:=reval cadr u; n:=reval caddr u;
if not baglistp bg then typerr(bg,"list or bag") else
if n<=0 then rederr("third argument must be positive integer") else
if (n:=n+1) > length bg then return append(bg,x:=list reval car u);
prf:=car bg; x:=reval car u;
for i:=3:n do <<bg:=cdr bg; bbg:=car bg . bbg>>;
bbg:=reverse bbg;
return bbg:=prf . append(bbg,cons(x,cdr bg))
end;
% symbolic put('insert,'number!_of!_args ,3);
symbolic put('insert,'psopfn,'rinsert);
% Use is : insert(<any>, <list or bag>, <integer>).
% HERE ARE FUNCTIONS FOR SETS.
symbolic procedure !:union u$
begin scalar x,y,prf;
argnochk('union . u);
if length u neq 2 then
rederr("union called with wrong number of arguments");
x:=reval car u; y:=reval cadr u;
if baglistp x and baglistp y then
<<prf:=car y; y:=prf . union(cdr x,cdr y)>> else return nil;
return y end;
% symbolic put('!:union,'number!_of!_args,2);
symbolic put('union,'psopfn,'!:union);
symbolic procedure setp u;
null repeats u;
symbolic flag('(setp),'boolean);
symbolic procedure !:mkset u$
if null u then nil else if member(car u,cdr u) then !:mkset cdr u
else car u . !:mkset cdr u$
symbolic procedure rmkset u;
begin scalar x,prf$
argnochk('mkset . u); x:=reval car u; prf:=car x;
if baglistp x then return prf . !:mkset cdr x end;
symbolic put('mkset,'psopfn,'rmkset);
symbolic procedure !:setdiff u$
begin scalar x,y,prf;
argnochk('diffset . u);
if length u neq 2 then
rederr("diffset called with wrong number of arguments");
x:=reval car u; y:=reval cadr u;
if baglistp x and baglistp y then
<<prf:=car y; y:=prf . setdiff(cdr x,cdr y)>> else return nil;
return y end;
% symbolic put('!:setdiff,'number!_of!_args,2);
symbolic put('diffset,'psopfn,'!:setdiff);
symbolic procedure !:symdiff u$
begin scalar x,y,prf;
argnochk('symdiff . u);
if length u neq 2 then
rederr("symdiff called with wrong number of arguments");
x:=reval car u; y:=reval cadr u; prf:=car x;
if setp x and setp y then return
prf . append(setdiff(x:=cdr x,y:=cdr y),setdiff(y,x))
end;
% symbolic put('!:symdiff,'number!_of!_args,2);
symbolic put('symdiff,'psopfn,'!:symdiff);
symbolic procedure !:xn u$
begin scalar x,y,prf;
argnochk('intersect . u);
if length u neq 2 then
rederr("intersect called with wrong number of arguments");
x:=reval car u; y:=reval cadr u;
if setp x and setp y then return car x . intersection(cdr x,cdr y)
end;
% symbolic put('!:xn,'number!_of!_args,2);
symbolic put('intersect,'psopfn,'!:xn);
endmodule ;
module genpurfunc;
%=====================================================================$
% $
% VARIOUS GENERAL PURPOSE FUNCTIONS $
% $
%=====================================================================$
% 1. GENERALIZATION OF EXISTING FUNCTIONS
symbolic procedure mkidn(u)$
% generalizes "mkid" for any number of atoms
% Input is mkidn(list(a1,...ak)Ybag(a1,...,ak)).
expand(cdr u, 'mkid);
flag('(mkidn),'opfn);
symbolic procedure simpsetf u;
% generalizes the function "set" to kernels.
begin scalar x;
x := simp!* car u;
if not kernp x or fixp (!*q2a x) then
typerr(!*q2a x,"setvalue kernel") else
x:=!*q2a x;
let0 list(list('equal,x,mk!*sq(u := simp!* cadr u)));
return u
end;
put ('setvalue, 'simpfn, 'simpsetf);
newtok '((!= !=) setvalue ! !=!=! );
infix ==;
symbolic procedure inf2(n,m);
if evalgreaterp(n,m) then m else n;
symbolic procedure sup2(n,m);
if evalgreaterp(n,m) then n else m;
flag('(inf2,sup2),'opfn);
flag('(prin2 ) ,'opfn); % To make it available in the alg. mode.
% 2. NEW ELEMENTARY FUNCTIONS CLOSELY RELATED TO EXISTING ONES.
symbolic procedure oddp u$
% Tests if integer U is odd. Is also defined in EXCALC;
fixp u and remainder(u,2)=1$
symbolic procedure evenp u;
not oddp u;
symbolic flag('(oddp evenp),'boolean);
symbolic procedure followline(n)$
% It allows to go to a new line at the position given by the integer N.
<< terpri()$ spaces(n)>>$
symbolic flag('(followline ) ,'opfn);
% 3. NEW GENERAL PURPOSE FUNCTIONS.
symbolic procedure charnump!: x;
if x member list('!0,'!1,'!2,'!3,'!4,'!5,'!6,'!7,'!8,'!9) then t ;
symbolic procedure charnump u;
if null u then t else charnump!: car u and charnump cdr u;
symbolic procedure detidnum u;
% Allows one to extract the index number from the identifier u.
if idp u then
begin scalar uu;
if length(uu:= cdr explode u) =1 then go to l1
else
while not charnump uu do uu:=cdr uu;
l1: uu:= compress uu;
if fixp uu then return uu end;
flag('(detidnum),'opfn);
symbolic procedure randomlist(n,trial);
% This procedure gives a list of trials in number "trial" of
% random numbers between 0 and n. For the algorithm see KNUTH vol. 2.
'list . lisp for j:=1:trial collect random n;
flag('(randomlist),'opfn);
algebraic procedure combnum(n,nu)$
% Number of combinations of n objects nu to nu.
if nu>n then
rederr "second argument cannot be bigger than first argument"
else factorial(n)/factorial(nu)/factorial(n-nu)$
symbolic procedure rpermutation u;
<<argnochk('permutations . u); if not baglistp(u:=reval car u) then
nil else if null cdr u then 'list . nil else
begin scalar x,prf$ prf:=car u$
u:=cdr u$
x:=for each j in u
conc mapcons(permutations delete(j,u),j)$
x:=for each j in x collect prf . j$
return prf . x end>>;
put('permutations,'psopfn,'rpermutation);
symbolic procedure !:comb(u)$
begin scalar x,prf; integer n;
argnochk('combinations . u);
if length u neq 2 then
rederr "combinations called with wrong number of arguments";
x:=reval car u ; if not baglistp x then return nil ;
prf :=car x; x:=cdr x; n:=reval cadr u;
return prf . (for each j in comb(x,n) collect prf . j)
end;
symbolic put('combinations,'psopfn,'!:comb);
symbolic procedure rfuncvar(u)$
% U is an arbitrary expression
% Gives a list which contains all the variables whom U depends
% in an ARBITRARY order$
<<if atom (u:=reval car u) then
if not flagp(u,'reserved) then
if depatom u neq u then depatom u else nil
else nil else
begin scalar wi,aa$
aa:=listofvars(u)$
% if null cdr aa then return car aa else
if null cdr aa then return
if flagp(car aa,'reserved) or flagp(car aa,'constant)
then nil else car aa else
aa:=!:mkset aa $ wi:=aa$
while wi do if flagp(car wi ,'reserved) then
<<aa:=delete(car wi ,aa)$ wi:=cdr wi >> else wi:=cdr wi $
return aa:='list . aa end >>;
flag('(e i),'reserved);
symbolic procedure listofvars u $
if null u or numberp u then nil else
if atom u then list u else
varsinargs cdr u $
symbolic procedure varsinargs(u)$
if null u then nil else
append(listofvars car u,varsinargs cdr u)$
symbolic put('funcvar,'psopfn ,'rfuncvar);
symbolic procedure implicit u;
if atom u then u else
begin scalar prf;
prf:=car u;
if get(prf,'simpfn) neq 'simpiden then
rederr list(u,"must be an OPERATOR");
remprop(car u,'simpfn);
depl!*:=union(list (car u . reverse
for each y in cdr u collect implicit y),depl!*);
return prf end;
symbolic procedure depatom a$
%Gives a list of variables declared in DEPEND commands whom A depends
%A must be an atom$
if not atom a then rederr("ARGUMENT MUST BE AN ATOM") else
if null assoc(a,depl!*) then a else
'list . reverse cdr assoc(a,depl!*);
flag('(depatom),'opfn);
symbolic procedure explicit u$
% U is an atom. It gives a function named A which depends on the
% variables detected by DEPATOM and this to all levels$
begin scalar aa$
aa:=depatom u $
if aa = u then return u$
put(u,'simpfn,'simpiden)$
return u . (for each x in cdr aa collect explicit x) end$
symbolic flag('(implicit explicit),'opfn);
symbolic procedure simplify u;
% Enforces simplifications if necessary.
% u is any expression.
mk!*sq resimp simp!* reval u;
symbolic flag('(simplify),'opfn);
% 4. FUNCTIONS TO DEAL WITH PROPERTIES IN THE ALGEBRAIC MODE.
global('(!:flaglis !:proplis));
symbolic(!:flaglis:=union(list list2('bag,'bag),!:flaglis));
symbolic procedure putflag(u,flg,b)$
% Allows one to put or erase any FLAG on the identifier U.
% U is an idf or a list of idfs, FLAG is an idf, B is T or 0.
if not idp u and not null baglistp u then
<<for each x in cdr u do putflag(x,flg,b)$ t>>
else if idp u and b eq t then
<<flag(list u, flg)$
!:flaglis:=union(list list2(u, flg),!:flaglis)$ u>>
else if idp u and b equal 0 then
<<remflag( list u, flg)$ !:delete(u,nil,flg)$>>
else rederr "*** VARIABLES ARE (idp OR list of flags, T or 0).";
symbolic procedure putprop(u,prop,val,b)$
% Allows to put or erase any PROPERTY on the object U
% U is an idf or a list of idfs, B is T or 0$
if not idp u and baglistp u then
<<for each x in cdr u do putprop(x,prop,val,b)$ t>>
else if idp u and b eq t then
<<put(u, prop,val)$
!:proplis:=union(list list3(u,prop,val),!:proplis)$ u>>
else if idp u and b equal 0 then
<<remprop( u, prop)$ !:delete(u,prop,val)$ >>
else rederr "*** VARIABLES ARE (idp OR list of idps, T or 0).";
symbolic flag('(putflag putprop),'opfn)$
symbolic procedure rdisplayprop(u)$
% U is the idf whose properties one wants to display.Result is a
% list which contains them$
begin scalar x,val,aa$ x:=reval car u; val:=reval cadr u;
for each j in !:proplis do if car j eq x and cadr j eq val
then aa:=('list . cdr j) . aa;
return 'list . aa end;
symbolic put('displayprop,'psopfn,'rdisplayprop)$
symbolic put('displayflag,'psopfn,'rdisplayflag)$
symbolic procedure rdisplayflag(u)$
% U is the idf whose properties one wants to display.Result is a
% list which contains them$
begin scalar x,aa$ x:=reval car u;
for each j in !:flaglis do if car j=x then aa:=cons(cadr j,aa)$
return 'list . aa end;
symbolic procedure clrflg!: u;
for each x in !:flaglis do
if u eq car x then putflag(car x,cadr x,0) ;
symbolic procedure clearflag u;
% If u equals "all" all flags are eliminated.
% If u is a1,a2,a3.....an flags of these identifiers are eliminated.
if null cdr u and car u eq 'all then for each x in !:flaglis
do putflag (car x,cadr x,0) else
if null cdr u then clrflg!: car u else
for each y in u do clrflg!: y;
symbolic procedure clrprp!: u;
for each x in !:proplis do
if u eq car x then putprop(car x,cadr x,caddr x,0);
symbolic procedure clearprop u;
% If u equals "all" all properties are eliminated.
% If u is a1,a2,a3...an properties of these identifiers are eliminated.
if null cdr u and car u eq 'all then for each x in !:proplis
do putprop(car x,cadr x,caddr x,0) else
if null cdr u then clrprp!: car u else
for each y in u do clrprp!: y;
symbolic put('clearflag,'stat,'rlis);
symbolic put('clearprop,'stat,'rlis);
endmodule;
module control;
% functions which offer a BETTER CONTROL on $
% various objects and of the ALREADY USED quantities $
% 1. BOOLEAN functions.
flag('(null idp flagp),'boolean);
symbolic procedure nordp(u,v);
% TRUE if a>b, FALSE if a=<b. NOT USED HERE.
not ordp(u,v);
symbolic procedure depvarp(u,v)$
% V is an idf. or a kernel$
if depends(u,v) then t else nil$
symbolic procedure alatomp(u)$
% U is any expression . Test if U is an idf. whose only value is its
% printname or another atom$
fixp u or idp u$
symbolic procedure alkernp u$
% U is any expression . Test if U is a kernel.$
not stringp u and kernp(simp!* u)$
symbolic procedure precp(u,v)$
% Tests if the operator U has precedence over the operator V.
begin integer nn$scalar uu,vv,aa$
uu:=u$ vv:=v$aa:=preclis!*$
if or(not(uu member aa),not(vv member aa)) then return nil$
nn:=lpos(u,aa)$;
nn:=nn-lpos(v,aa)$
if nn geq 0 then return t else return nil end$
flag('(nordp alatomp alkernp precp depvarp stringp ),'boolean)$
% THE SUBSEQUENT DECLARATION IS USEFUL FOR "TEACHING PURPOSES".
flag('(alatomp precp depvarp alkernp depatom ) ,'opfn);
% 2. MISCELLANEOUS functions.
symbolic procedure korderlist;
% gives a list of the user defined internal order of the
% indeterminates. Just state KORDERLIST; to get it.
kord!*;
flag('(korderlist), 'opfn);
put('korderlist,'stat,'endstat);
symbolic procedure remsym u;
% ALLOWS TO ELIMINATE THE DECLARED SYMMETRIES.
for each j in u do
if flagp(j,'symmetric) then remflag(list j,'symmetric) else
if flagp(j,'antisymmetric) then remflag(list j,'antisymmetric);
put('remsym,'stat,'rlis);
% 3. Control of SWITCHES.
symbolic procedure switches;
%This procedure allows to see the values of the main switches$
<<terpri();
prin2 " **** exp:=";prin2 !*exp;prin2 " ............. ";
prin2 "allfac:= ";prin2 !*allfac;prin2 " ****";terpri(); terpri();
prin2 " **** ezgcd:=";prin2 !*ezgcd;prin2 " ......... ";
prin2 "gcd:= ";prin2 !*gcd;prin2 " ****";terpri();terpri();
prin2 " **** mcd:=";prin2 !*mcd;prin2 " ............. ";
prin2 "lcm:= ";prin2 !*lcm;prin2 " ****";terpri();terpri();
prin2 " **** div:=";prin2 !*div;prin2 " ........... ";
prin2 "rat:= ";prin2 !*rat;prin2 " ****";terpri();terpri();
prin2 " **** intstr:=";prin2 !*intstr;prin2 " ........ ";
prin2 "rational:= ";prin2 !*rational;prin2 " ****";terpri();terpri();
prin2 " **** precise:=";prin2 !*precise;prin2 " ....... ";
prin2 "reduced:= ";prin2 !*reduced;prin2 " ****";terpri();terpri();
prin2 " **** complex:=";prin2 !*complex;prin2 " ....... ";
prin2 "rationalize:= ";prin2 !*rationalize;
prin2 " ****";terpri();terpri();
prin2 " **** factor:= "; prin2 !*factor;prin2 " ....... ";
prin2 "distribute:= ";prin2 !*distribute;prin2 " ***";>>$
flag('(switches),'opfn)$
symbolic procedure switchorg$
%It puts all switches relevant to current algebra calculations to
% their initial values.
<< !*exp:=t;
!*allfac:=t;
!*gcd:=nil;
!*mcd:=t;
!*div:=nil;
!*rat:=nil;
!*distribute:=nil;
!*intstr:=nil;
!*rational:=nil;
!*ezgcd:=nil;
!*ratarg:=nil;
!*precise:=nil;
!*complex:=nil;
!*heugcd:=nil;
!*lcm:=t;
!*factor:=nil;
!*ifactor:=nil;
!*rationalize:=nil;
!*reduced:=nil;
!*savestructr:=nil;
>>;
flag('(switchorg switchoff),'opfn)$
deflist('((switches endstat) (switchorg endstat) (switchoff endstat)),
'stat)$
% 4. Control of USER DEFINED objects.
% This aims to extract from the history of the run
% the significant data defined by the user. It DOES NOT give insights on
% operations done in the SYMBOLIC mode.
symbolic procedure remvar!:(u,v)$
% This procedure traces and clear both assigned or saved scalars and
% lists.
begin scalar buf,comm,lv;
buf:=inputbuflis!*;
for each x in buf do if not atom (comm:=caddr x)
and car comm = 'setk then
begin scalar obj;
l1: if null cddr comm then return lv;
obj:=cadadr comm;
if gettype obj eq v then
lv:=cons(obj,lv);
comm:=caddr comm;
go to l1 end;
lv:= !:mkset lv;
if null u then
<<for each x in lv do clear x; return t>> else return lv
end;
flag('(displaylst displayscal),'noform);
symbolic procedure displayscal;
% Allows to see all scalar variables which have been assigned
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
union(remvar!:(t,'scalar),remsvar!:(t,'scalar));
symbolic procedure displaylst$
% Allows to see all list variables which have been assigned
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
union(remvar!:(t,'list),remsvar!:(t,'list)) ;
symbolic procedure clearscal$
% Allows to clear all scalar variables introduced
% DIRECTLY ON THE CONSOLE;
<<remvar!:(nil,'scalar);remsvar!:(nil,'scalar)>>$
symbolic procedure clearlst$
% Allows to clear all list variables introduced
% DIRECTLY ON THE CONSOLE;
<<remvar!:(nil,'list);remsvar!:(nil,'list)>>;
symbolic procedure remsvar!:(u,v)$
begin scalar buf,comm,lsv,obj;
buf:= inputbuflis!*;
for each x in buf do
if not atom (comm:=caddr x) and car comm eq 'saveas then
if v eq t then
if gettype (obj:=cadr cadadr comm)
member list('scalar,'list,'matrix,'hvector,'tvector)
then lsv:=cons(obj,lsv)
else nil
else if v eq gettype (obj:=cadr cadadr comm)
then lsv:=cons(obj,lsv);
lsv:= !:mkset lsv$
if null u then
<<for each x in lsv do clear x$ return t>> else return lsv
end;
flag('(displaysvar),'noform);
symbolic procedure displaysvar;
% Allows to see all variables created by SAVEAS.
remsvar!:(t,t) ;
symbolic procedure clearsvar;
% Allows to clear all variables created.
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file.
remsvar!:(nil,t);
symbolic procedure rema!:(u);
% This function works to trace or to clear arrays.
begin scalar buf,comm,la$
buf:=inputbuflis!*$
for each x in buf do if not atom (comm:=caddr x) and
car comm eq 'arrayfn then
begin scalar arl,obj;
arl:=cdaddr comm;
l1: if null arl then return la else
if gettype (obj:=cadadr car arl ) eq 'array then
la:=cons(obj,la);
arl:=cdr arl$
go to l1 end$
la:= !:mkset la$
if null u then
<<for each x in la do clear x$ return t>> else return la
end;
flag('(displayar),'noform);
symbolic procedure displayar;
% Allows to see all array variables created.
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file.
rema!:(t)$
symbolic procedure clearar;
% Allows to clear array variables introduced
% DIRECTLY ON THE CONSOLE;
rema!:(nil)$
% This file shoul be loaded together with remscal.red
symbolic procedure remm!:(u)$
% This function works to trace or to clear matrices. Be CAREFUL to use
% the declaration MATRIX on input (not m:=mat(...) directly).
% declaration MATRIX ..
%x ==> (97 SYMBOLIC (MATRIX (LIST (LIST (QUOTE MM) 1 1))))
% Declaration MM:=MAT((...))
% x==>(104 ALGEBRAIC
% (SETK (QUOTE M2) (AEVAL (LIST (QUOTE MAT) (LIST 1) (LIST 1)))))
begin scalar buf,comm,lm;
buf:= inputbuflis!*;
for each x in buf do if not atom (comm:=caddr x) and
car comm eq 'matrix then
begin scalar lob,obj;
lob:=cdadr comm;
l1: if null lob then return lm else
if gettype(obj:=if length car lob = 2 then cadr car lob else
cadadr car lob) then
lm:=cons(obj,lm);
lob:=cdr lob;
go to l1 end$
lm :=union(lm,remvar!:(t,'matrix));
lm:=!:mkset lm;
if null u then
<<for each x in lm do clear x$ return t>> else return lm
end;
flag('(displaymat),'noform);
symbolic procedure displaymat$
% Allows to see all variables of matrix type
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
union( remm!:(t),remsvar!:(t,'matrix));
symbolic procedure clearmat$
% Allows to clear all user variables introduced
% DIRECTLY ON THE CONSOLE;
<<remm!:(nil);remsvar!:(nil,'matrix)>>;
symbolic procedure remv!:(u)$
% This function works to trace or to clear vectors.
begin scalar buf,av$
buf:= inputbuflis!*$
for each x in buf do if not atom (x:=caddr x) and
car x member list('vector,'tvector,'index)
then
begin scalar uu,xx$
uu:=cdadr x$
l1: if null uu then return av else
if gettype(xx:=cadar uu) or get(xx,'fdegree) then
av:=cons(xx,av);
uu:=cdr uu$
go to l1 end$
av:= !:mkset av$
if null u then
<<for each x in av do clear x$ return t>> else return av
end$
flag('(displayvec),'noform);
symbolic procedure displayvec$
% Allows to see all variables which have been assigned
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
union(remv!:(t),union(remsvar!:(t,'hvector),remsvar!:(t,'tvector)) );
symbolic procedure clearvec$
% Allows to clear all user variables introduced
% DIRECTLY ON THE CONSOLE;
<<remv!:(nil);remsvar!:(nil,'hvector);remsvar!:(nil,'tvector)>>;
symbolic procedure remf!:(u)$
% This function works to trace or to clear arrays.
begin scalar buf,av$
buf:= inputbuflis!*$
for each x in buf do if not atom (x:=caddr x) and
car x eq 'pform then
begin scalar uu,xx$
uu:=cdadr x$
l1: if null uu then return av else
if get(xx:=cadadr cdar uu ,'fdegree) or
(not atom xx and get(xx:=cadr xx,'ifdegree))
then
av:=cons(xx,av);
uu:=cdr uu$
go to l1 end$
av:= !:mkset av$
if null u then
<<for each x in av do clear x$ return t>> else return av
end$
flag('(displayform),'noform);
symbolic procedure displayform$
% Allows to see all variables which have been assigned
% independently DIRECTLY ON THE CONSOLE. It does not work
% for assignments introduced THROUGH an input file;
union(remf!:(t),remvar!:(t,'pform));
symbolic procedure clearform$
% Allows to clear all user variables introduced
% DIRECTLY ON THE CONSOLE;
<<remf!:(nil);remvar!:(nil,'pform)>>;
symbolic procedure clear!_all;
<<remvar!: (nil,'scalar); remvar!:(nil,'list); remvar!:(nil,'pform);
remsvar!:(nil,t);rema!: nil;remv!: nil;remm!: nil; remf!: nil ;t>>;
symbolic procedure show u;
begin u:=car u;
if u eq 'scalars then
return write "scalars are: ", displayscal()
else
if u eq 'lists then
return write "lists are: ", displaylst()
else
if u eq 'arrays then
return write "arrays are: ", displayar()
else
if u eq 'matrices then
return write "matrices are: ",displaymat()
else
if u member list('vectors,'tvectors,'indices) then
return write "vectors are: ", displayvec()
else
if u eq 'forms then
return write "forms are: ", displayform()
else
if u eq 'all then for each i in
list('scalars,'arrays,'lists,'matrices,'vectors,'forms) do
<<show list i;lisp terpri()>>;
end;
put('show,'stat,'rlis);
symbolic procedure suppress u;
begin u:=car u;
if u member list('vectors,'tvectors,'indices) then
return clearvec() else
if u eq 'variables then return clearvar() else
if u eq 'scalars then return clearscal() else
if u eq 'lists then return clearlst() else
if u eq 'saveids then return clearsvar() else
if u eq 'matrices then return clearmat() else
if u eq 'arrays then return clearar() else
if u eq 'forms then return clearform() else
if u eq 'all then return clear!_all() end;
put('suppress,'stat,'rlis);
% 5. Means to CLEAR operators and functions.
symbolic procedure clearop u;
<<clear u; remopr u; remprop(u , 'kvalue);remprop(u,'klist)$
for each x in !:flaglis do
if u eq car x then putflag(u,cadr x,0) else nil;
for each x in !:proplis do
if u eq car x then putprop(u,cadr x,caddr x,0)
else nil;
remflag(list u,'used!*); t>>;
symbolic flag('(clearop),'opfn);
symbolic procedure clearfunctions u$
% U is any number of idfs. This function erases properties of non
% protected functions described by the idfs.
% It is very convenient but is dangerous if applied to the
% basic functions of the system since most of them are NOT protected.
% It clears all properties introduced by PUTFLAG, PUTPROP and DEPEND.
begin scalar uu,vv$
l1: uu:=car u$
vv:=cdr rdisplayflag (list uu )$
if flagp(uu,'lose) then go to l2 else
<< terpri();spaces(5)$
write "*** ",uu," is unprotected : Cleared ***"$
followline(0)>>$
for each x in !:proplis do
if u eq car x then putprop(u,cadr x,caddr x,0)
else nil;
if get(uu,'simpfn) then <<clearop uu; remprop(uu,'!:ft!:);
remprop(uu,'!:gf!:)>> else
if get(uu,'psopfn) then remprop(uu,'psopfn) else
if get(uu,'expr) then remprop(uu,'expr) else
if get(uu,'subr) then remd uu$
remprop(uu,'stat);
remprop(uu,'dfn);
remflag(list uu,'opfn)$
remflag(list uu,'full)$
remflag(list uu,'odd)$
remflag(list uu,'even)$
remflag(list uu,'boolean)$
remflag(list uu,'used!*)$
for each x in vv do putflag( uu,x,0)$
depl!*:=delete(assoc(uu,depl!*),depl!*);
remflag(list uu,'impfun)$ % to be effective in EXCALC;
u:= cdr u$ go to l3$
l2: << spaces(5)$
write "*** ",uu," is a protected function: NOT cleared ***"$
terpri(); u:=cdr u>>$
l3: if null u then <<terpri();
return "Clearing is complete">> else
go to l1 end$
symbolic rlistat '(clearfunctions);
endmodule;
module polyextensions;
%=====================================================================
% ADDITIONAL FUNCTIONS FOR POLYNOME AND RATIONAL EXPRESSION
% MANIPULATIONS.
%=====================================================================
fluid '(!*distribute);
switch distribute;
symbolic procedure addfd (u,v);
% It contains a modification to ADDF to avoid
% a recursive representation.
% U and V are standard forms. Value is a standard form.
if null u then v
else if null v then u
else if domainp u then addd(u,v)
else if domainp v then addd(v,u)
%else if peq(lpow u,lpow v) or ordpp(lpow u,lpow v)
else if ordpp(lpow u,lpow v)
then lt u .+ addfd(red u,v)
else lt v .+ addfd (u,red v);
symbolic procedure distribute u;
% Gives a polynome in distributed form in the algebraic mode.
list('!*sq,distri!_pol numr simp!* u ./ 1,t);
symbolic flag('(distribute),'opfn);
symbolic procedure distri!_pol u;
% This function assumes that u is a polynomial given
% as a standard form. It transforms its recursive representation into
% a distributive representation.
if null u then nil else
if atom u then u else
if red u then
addfd(distri!_pol !*t2f lt u,distri!_pol red u)
else
begin scalar x,y;
x:=1 ;
y:=u;
while not atom y and null red y do
<<x:=multf(!*p2f lpow y,x); y:=lc y>>;
if atom y then return multf(x,y) else
return
addfd(distri!_pol multf(x,distri!_pol !*t2f lt y),
distri!_pol multf(x,distri!_pol red y))
end;
symbolic procedure leadterm u;
<<u:=simp!* u; if !*distribute then u:=distri!_pol numr u ./ denr u
else u; if domainp u then mk!*sq u
else mk!*sq(!*t2f lt numr u ./ denr u)>>;
symbolic flag('(leadterm redexpr ),'opfn);
symbolic procedure redexpr u;
<<u:=simp!* u; if !*distribute then u:=distri!_pol numr u ./ denr u
else u; if domainp u then mk!*sq(nil ./ 1) else
mk!*sq( red numr u ./ denr u)>>;
symbolic procedure list!_of!_monom u;
% It takes a polynomial in distributive form.
% returns a list of monoms.
% u is numr simp!* (algebraic expression)
if domainp u then u else
begin scalar exp,lmon,mon;
exp:=u;
l: if null exp then return lmon ;
mon:=lt exp;
lmon:=(!*t2f mon ) . lmon;
exp:=red exp;
go to l;
end;
symbolic procedure monomterm y;
begin scalar x;
x:=numr simp!* y;
x:=distri!_pol x;
x:=list!_of!_monom x;
x:=for each m in x collect mk!*sq(m ./ 1);
return 'list . x end;
algebraic procedure monom(u);
% Use: monom <polynome>
begin scalar x,xx;
xx:= lisp monomterm u ;
return xx
end;
symbolic procedure !&dpol u$
% RETURNS A LIST WHICH CONTAINS THE QUOTIENT POLYNOMIAL and THE
% REMAINDER.
if length u neq 2 then rederr "divpol must have two arguments"
else
begin scalar poln,pold,aa,ratsav$
if lisp (!*factor) then off factor; % This restriction is
% necessary for some implementatins .
poln:= simp!* car u$
pold:= simp!* cadr u$
if denr poln neq 1 or denr pold neq 1 then
rederr(" arguments must be polynomials")$
poln:=numr poln$ pold:=numr pold$
if lc poln neq 1 or lc poln neq lc pold then
<<ratsav:=lisp (!*rational); on rational>>;
aa:=qremf(poln,pold)$
aa:=mksq(list('list ,prepsq!*( car aa . 1), prepsq!*(cdr aa . 1)),1)$
if not ratsav then off rational;
return aa end$
put('divpol,'simpfn,'!&dpol)$
symbolic procedure lowestdeg(u,v)$
% IT EXTRACTS THE LOWEST DEGREE IN V OF THE POLYNOMIAL U.
begin scalar x,y,uu,vv,mvy$
uu:=simp!* u$
if domainp uu then return 0$
uu:=!*q2f uu;
vv:=!*a2k v$
x:=setkorder list v$
y:=reorder uu$ setkorder x$
y:=reverse y$y$
if fixp y then return 0$
mvy:=mvar y$
if not atom mvy then if car mvy eq 'expt then
rederr("exponents must be integers")$
if mvy neq vv then return 0 else
return ldeg y end$
flag('(lowestdeg),'opfn)$
endmodule;
module transfunctions;
algebraic;
algebraic procedure trigexpand wws;
wws where { sin(~x+~y) => sin(x)*cos(y)+cos(x)*sin(y),
cos(~x+~y) => cos(x)*cos(y)-sin(x)*sin(y),
sin((~n)*~x) => sin(x)*cos((n-1)*x)+cos(x)*sin((n-1)*x)
when fixp n and n>1,
cos((~n)*~x) => cos(x)*cos((n-1)*x)-sin(x)*sin((n-1)*x)
when fixp n and n>1 };
algebraic procedure hypexpand wws;
wws where {sinh(~x+~y) => sinh(x)*cosh(y)+cosh(x)*sinh(y),
cosh(~x+~y) => cosh(x)*cosh(y)+sinh(x)*sinh(y),
sinh((~n)*~x) => sinh(x)*cosh((n-1)*x)+cosh(x)*sinh((n-1)*x)
when fixp n and n>1,
cosh((~n)*~x) => cosh(x)*cosh((n-1)*x)+sinh(x)*sinh((n-1)*x)
when fixp n and n>1 };
operator !#ei!&; !#ei!&(0):=1;
trig!#ei!& := {!#ei!&(~x)**(~n) => !#ei!&(n*x),
!#ei!&(~x)*!#ei!&(~y) => !#ei!&(x+y)};
let trig!#ei!&;
algebraic procedure trigreduce wws;
<<wws:=(wws WHERE {cos(~x) => (!#ei!&(x)+!#ei!&(-x))/2,
sin(~x) => -i*(!#ei!&(x)-!#ei!&(-x))/2});
wws:=(wws WHERE {!#ei!&(~x) => cos x +i*sin x})>>;
algebraic procedure hypreduce wws;
<<wws:=(wws where {cosh(~x) => (!#ei!&(x)+!#ei!&(-x))/2,
sinh(~x) => (!#ei!&(x)-!#ei!&(-x))/2});
wws:=(wws where {!#ei!&(~x) => cosh(x)+sinh(x)})>>;
algebraic procedure pluslog wws;
wws:=(wws where {log(~x*(~n)) => log(x)+log(n),
log(~x/(~n)) => log(x)-log(n),
log(~x**(~n)) => n*log(x),
log sqrt(~x) => 1/2*log(x),
log cbrt(~x) => 1/3*log(x) });
% realizes the concatenation of "sum over i c(i)*log x(i)".
operator e!_log!_conc;
algebraic procedure concsumlog exp;
% This procedure works properly only in ON EXP only though it may lead
% to some simplification also in OFF EXP.
if den exp neq 1 then concsumlog num exp / concsumlog den exp else
<<exp:=(e!_log!_conc(exp) where
{ e!_log!_conc(~x+~y)=e!_log!_conc(x)*e!_log!_conc(y),
e!_log!_conc(log(~x)) => x,
e!_log!_conc(-log(~x)) => 1/x,
e!_log!_conc(~a*log (~x)) => x**a,
e!_log!_conc((- ~a)*log(~x)) => 1/x**a });
exp:=(log exp where
{ log(e!_log!_conc(~y)) => y,
log(~x*e!_log!_conc(~y)) => log(x)+y,
log(~x*e!_log!_conc(-~y)) => log(x)-y,
log(~x*e!_log!_conc(-~y)/(~z)) => log(x/z)-y,
log(~x*e!_log!_conc(~y)/(~z)) => log(x/z)+y })>>;
symbolic;
endmodule;
module vectoroper;
% This small module makes basic operation between EXPLICIT vectors
% available. They are assumed to be represented by BAGS or LISTS.
% Mixed product is restricted to 3-space vectors.
% Generalization is still NEEDED. ;
symbolic procedure depthl1!: u;
if null u then t else (caar u neq 'list) and depthl1!: cdr u;
symbolic procedure depthl1 u;
not null getrtype u and depthl1!: cdr u;
symbolic procedure !:vect(u,v,bool);
%returns a list whose elements are the sum of each list elements.
% null v check not necessary;
if null u then nil
else addsq(car u,if null bool then car v else negsq car v)
. !:vect(cdr u,cdr v,bool);
symbolic procedure rsumvect(u);
begin scalar x,y,prf;
argnochk('sumvect . u);
x:=reval car u;y:=reval cadr u; prf:=car x;
if (rdepth list x = 0) or (rdepth list y = 0) then
rederr " both arguments must be of depth 1 " else
x:=cdr x; y:=cdr y;
if length x neq length y then rederr "vector mismatch";
x:=for each j in x collect simp!* j;
y:=for each j in y collect simp!* j;
return prf . (for each j in !:vect(x,y,nil) collect mk!*sq j) end;
put('sumvect,'psopfn,'rsumvect);
symbolic procedure rminvect(u);
begin scalar x,y,prf;
argnochk('minvect . u);
x:=reval car u;y:=reval cadr u; prf:=car x;
if (rdepth list x = 0) or (rdepth list y = 0) then
rederr " both arguments must be of depth 1 " else
x:=cdr x; y:=cdr y;
if length x neq length y then rederr "vector mismatch";
x:=for each j in x collect simp!* j;
y:=for each j in y collect simp!* j;
return prf . (for each j in !:vect(x,y,'minus) collect mk!*sq j) end;
put('minvect,'psopfn,'rminvect);
symbolic procedure !:scalprd(u,v);
%returns scalar product of two lists;
if null u and null v then nil ./ 1
else addsq(multsq(car u,car v),!:scalprd(cdr u,cdr v));
symbolic procedure sscalvect(u);
begin scalar x,y;
argnochk('scalvect . u);
x:=reval car u;y:=reval cadr u;
if (rdepth list x = 0) or (rdepth list y = 0) then
rederr " both arguments must be of depth 1 " else
if length x neq length y then rederr "vector mismatch";
x:=cdr x; y:=cdr y;
x:=for each j in x collect simp!* j;
y:=for each j in y collect simp!* j;
return mk!*sq !:scalprd(x,y)
end;
symbolic put('scalvect,'psopfn,'sscalvect);
symbolic procedure !:pvect3 u;
begin scalar x,y; integer xl;
if (rdepth list car u = 0) or (rdepth cdr u = 0) then
rederr " both arguments must be of depth 1 " else
x:=reval car u;y:=reval cadr u;
if (xl:=length x) neq 4 then rederr "not 3-space vectors" else
if xl neq length y then rederr "vector mismatch" ;
x:=cdr x; y:=cdr y;
x:=for each j in x collect simp!* j;
y:=for each j in y collect simp!* j;
return
list( addsq(multsq(cadr x,caddr y),negsq multsq(caddr x,cadr y)),
addsq(multsq(caddr x,car y),negsq multsq(car x,caddr y)),
addsq(multsq(car x,cadr y),negsq multsq(cadr x,car y)))
end;
symbolic procedure rcrossvect u;
<<% implemented only with LIST prefix;
argnochk('crossvect . u);
'list . (for each j in !:pvect3 u collect mk!*sq j)>>;
symbolic put ('crossvect,'psopfn,'rcrossvect);
symbolic procedure smpvect u;
begin scalar x;
if (rdepth list car u =0) then
rederr " arguments must be of depth 1 " else
x:=reval car u; u:=cdr u;
x:=cdr x;
if length x neq 3 then rederr " not 3-space vector";
x:=for each j in x collect simp!* j;
return mk!*sq !:scalprd(x,!:pvect3 u) end;
symbolic put('mpvect,'psopfn,'smpvect);
endmodule;
module matrext;
% This module defines additional utility functions for manipulating
% matrices. Coercions to BAG and LIST structures are defined.
symbolic procedure natnumlis u;
% True if U is a list of natural numbers.
% Taken from MATR.RED for bootstrap purpose.
null u
or numberp car u and fixp car u and car u>0 and natnumlis cdr u;
symbolic procedure mkid!:(x,y);
% creates the ID XY from identifier X and (evaluated) atom Y.
if not idp x or null getrtype x then typerr(x,"MKID root")
else if atom y and (idp y or fixp y and not minusp y)
then intern compress nconc(explode x,explode y)
else typerr(y,"MKID index");
symbolic procedure mkidm(u,j);
% This function allows us to RELATE TWO MATRICES by concatanation of
% characters. u AND uj should BOTH be matrices.
matsm cadr get(mkid!:(u,j),'avalue) ;
symbolic put('mkidm,'rtypefn,'getrtypecar);
symbolic flag('(mkidm),'matflg);
symbolic procedure baglmat (u,op);
% this procedure maps U into the matrix whose name is OP;
% it cannot REDEFINE the matrix OP.
% This is to avoid accidental redefinition of a previous matrix;
if getrtype op then rederr list(op,"should be an identifier")
else
begin scalar x,y;
if atom op then if not (y:=gettype op) then put(op,'rtype,'matrix) else
typerr(list(y,op),"matrix");
if rdepth list u neq 2 then rederr("depth of list or bag must be 2");
x:=cdr u;
x:= for each j in x collect for each k in cdr j collect k;
put(op,'avalue,list('matrix,'mat . x));
return t end;
symbolic flag('(baglmat),'opfn);
symbolic procedure rcoercemat u;
% Transforms a matrix into a bag or list. Argument is a list (mat,idp).
% idp is the name to be given to the line or column vectors.
% The idp-envelope of the bag is the same as the one of the one of the
% subbags$
begin scalar x,prf;
x:=reval car u;
if getrtype x neq 'matrix then rederr list(x,"should be a matrix");
prf:= cadr u;
if car x neq 'mat then typerr(x,"matrix") else
if prf neq 'list then <<prf:=reval prf; simpbagprop list(prf,t)>>;
x:=cdr x;
x:= for each j in x collect (prf . j);
return prf . x end;
symbolic put('coercemat,'psopfn,'rcoercemat);
symbolic put('rcoercemat,'number!_of!_args,2);
symbolic procedure n!-1zero(n,k)$
if n=0 then nil else
if k=1 then 1 . nzero(n-1) else
if k=n then append(nzero(n-1) , (1 . nil)) else
append(nzero(k-1), (1 . nzero(n-k)))$
symbolic procedure unitmat u$
% It creates unit matrices. The argument is of the form A(2),B(5)....$
begin scalar l,sy,x,aa$
for each s in u do
<< if idp s or length (l:= revlis cdr s) neq 1 or not natnumlis l
then errpri2(s,'hold) else
<<aa:=nil;sy:=car s; x:=gettype sy; if not null x then if x eq 'matrix
then lprim list(x,sy,"redefined")
else typerr(list(x,sy),"matrix");
l:=car l; for n:=1:l do aa:=n!-1zero(l,l-n+1) . aa$
put(sy,'rtype,'matrix);
put(sy,'avalue,list('matrix,'mat . aa))>>>>;
end$
symbolic put('unitmat,'stat,'rlis);
symbolic procedure submat (u,nl,nc);
% Allows to extract from the matrix M the matrix obtained when
% the row NL and the column NC have been dropped.
% When NL and NC are out of range gives a copy of M;
if getrtype u neq 'matrix then rederr list(u,"should be a matrix")
else
begin scalar x;
x:= matsm u;
if and(nl=0,nc=0) then return x else
if nl neq 0 then x:=remove(x,nl)$
if nc neq 0 then
x:=for each j in x collect remove(j,nc);
return x end;
symbolic put('submat,'rtypefn,'getrtypecar);
symbolic flag('(submat),'matflg);
symbolic procedure matsubr(m,bgl,nr)$
if getrtype m neq 'matrix then rederr list(m,"should be a matrix")
else
begin scalar x,y,res; integer xl;
% It allows to replace row NR of the matrix M by the bag or list BGL;
y:=reval bgl;
if not baglistp y then typerr(y,"bag or list") else
if nr leq 0 then rederr " THIRD ARG. MUST BE POSITIVE"
else
x:=matsm m$ xl:=length x$
if length( y:=cdr y) neq xl then rederr " MATRIX MISMATCH"$
y:= for each j in y collect simp j;
if nr-xl >0 then rederr " row number is out of range";
while (nr:=nr-1) >0
do <<res:=car x . res$ x:=cdr x >>;
rplaca(x,y) ;
res:=append( reverse res, x) ;
return res end;
symbolic put('matsubr,'rtypefn,'getrtypecar);
symbolic flag('(matsubr),'matflg);
symbolic procedure matsubc(m,bgl,nc)$
if getrtype m neq 'matrix then rederr list(m,"should be a matrix")
else
begin scalar x,y,res; integer xl;
%It allows to replace column NC of the matrix M by the bag or list BGL
y:=reval bgl;
if not baglistp y then typerr(y,"bag or list") else
if nc leq 0 then rederr " THIRD ARG. MUST BE POSITIVE"
else
x:=tp1 matsm m$ xl:=length x$
if length( y:=cdr y) neq xl then rederr " MATRIX MISMATCH"$
y:= for each j in y collect simp j;
if nc-xl >0 then rederr " column number is out of range";
while (nc:=nc-1) >0
do <<res:=car x . res$ x:=cdr x >>;
rplaca(x,y) ;
res:=tp1 append( reverse res, x) ;
return res end;
symbolic put('matsubc,'rtypefn,'getrtypecar);
symbolic flag('(matsubc),'matflg);
symbolic procedure rmatextr u$
% This function allows to extract the row N from the matrix A and
% to place it inside a bag whose name is LN$
begin scalar x,y; integer n,nl;
x:= matsm car u; y:= reval cadr u; n:=reval caddr u;
if not fixp n then
rederr "Arguments are: matrix, vector name, line number" else
if not baglistp list y then simpbagprop list(y, t)$
nl:=length x;
if n<= 0 or n>nl then return nil$
while n>1 do <<x:=cdr x$ n:=n-1>>$
if null x then return nil$
return x:=y . ( for each j in car x collect prepsq j) end$
symbolic procedure rmatextc u$
% This function allows to extract the row N from the matrix A and
% to place it inside a bag whose name is LN$
begin scalar x,y; integer n,nc;
x:= tp1 matsm car u; y:= reval cadr u; n:=reval caddr u;
if not fixp n then
rederr "Arguments are: matrix, vector name, line number" else
if not baglistp list y then simpbagprop list(y, t)$
nc:=length x;
if n<= 0 or n>nc then return nil$
while n>1 do <<x:=cdr x$ n:=n-1>>$
if null x then return nil$
return x:=y . ( for each j in car x collect prepsq j) end$
symbolic put('matextr,'psopfn,'rmatextr);
symbolic put('matextc,'psopfn,'rmatextc);
symbolic procedure hconcmat(u,v)$
% Gives the horizontal concatenation of matrices U and V$
hconcmat!:(matsm u,matsm v );
symbolic procedure hconcmat!:(u,v)$
if null u then v else if null v then u else
append(car u,car v) . hconcmat!:(cdr u,cdr v)$
symbolic put('hconcmat,'rtypefn,'getrtypecar);
symbolic flag('(hconcmat),'matflg);
symbolic procedure vconcmat (u,v)$
% Gives the vertical concatenation of matrices U and V$
append(matsm u,matsm v);
symbolic put('vconcmat,'rtypefn,'getrtypecar);
symbolic flag('(vconcmat),'matflg);
symbolic procedure tprodl(u,v)$
begin scalar aa,ul$
l1: if null u then return aa$
ul:=car u$
ul:=multsm(ul,v)$
aa:=hconcmat!:(aa,ul)$
u:=cdr u$
go to l1$
end$
symbolic procedure tpmat(u,v)$
% Constructs the direct product of two matrices;
if null gettype u then multsm(simp u,matsm v) else
if null gettype v then multsm(simp v,matsm u) else
begin scalar aa,uu,vv$
uu:=matsm u$ vv:=matsm v$
for each x in uu do aa:=append (aa,tprodl(x,vv))$
return aa end;
infix tpmat$
put('tpmat,'rtypefn, 'getrtypecar);
flag('(tpmat),'matflg)$
algebraic procedure hermat (m,hm);
% hm must be an identifier with NO value. Returns the
% Hermitiam Conjugate matrix.
begin scalar ml,ll; %ll:=length M;
m:=tp m;
ml:=coercemat(m,list);
ll:=list(length first ml,length ml);
ml:=for j:=1: first ll collect for k:=1:second ll collect
sub(i=-i,(ml.j).k);
baglmat(ml,hm);
return hm end;
symbolic procedure seteltmat(m,elt,i,j);
% Sets the matrix element (i,j) to elt. Returns the modified matrix.
begin scalar res;res:=matsm m;
rplaca(pnth(nth(res,i),j),simp elt);
return res end;
put('seteltmat,'rtypefn,'getrtypecar);
flag('(seteltmat),'matflg);
symbolic procedure simpgetelt u;
% Gets the matrix element (i,j). Returns the element.
begin scalar mm;
mm:=matsm car u;
return nth(nth(mm,cadr u),caddr u) end;
put('geteltmat, 'simpfn,'simpgetelt);
endmodule;
end;