Artifact 07eacbdbae692c86f83e30075c6bec6755706a0171ea1e5ad745fb7d440902f5:
- File
r34/lib/assist.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 63505) [annotate] [blame] [check-ins using] [more...]
module assist; % Header Module for REDUCE 3.4 Extensions. % ******************************************************************** % % Author: H. Caprasse <u214001@bliulg11.bitnet>. % or <u214001@vm1.ulg.ac.be> % % Version and Date: Version 1.0, 1 June 1991. % Revision history : none % % ******************************************************************** endmodule; module switchext$ fluid '(!*distribute); switch distribute; %********** Functions for the manipulation of the switches.$ % Notice that the switches FLOAT,.. are not included . If the user % wants it can be done in the same way as shown here$ %********** Functions for the manipulation of the switches.$ symbolic procedure switches$ %This procedure allows to see the values of the main switches$ <<prin2 " **** exp:=";prin2 !*exp;prin2 " ************* "; prin2 "div:= ";prin2 !*div;prin2 " ****";terpri(); terpri(); prin2 " **** gcd:=";prin2 !*gcd;prin2 " *********** "; prin2 "mcd:= ";prin2 !*mcd;prin2 " ****";terpri();terpri(); prin2 " **** allfac:=";prin2 !*allfac;prin2 " *********** "; prin2 "intstr:= ";prin2 !*intstr;prin2 " ****";terpri();terpri(); prin2 " **** rat:=";prin2 !*rat;prin2 " *********** "; prin2 "rational:= ";prin2 !*rational;prin2 " ****";terpri();terpri(); prin2 " *** factor:= "; prin2 !*factor;prin2 " *********** "; prin2 "distribute:= ";prin2 !*distribute;prin2 " ***";>>$ flag('(switches),'opfn)$ flag('(!*factor !*mcd !*div !*exp !*gcd !*rat !*rational !*intstr !*reduced !*ratpri !*revpri !*distribute),'share)$ symbolic procedure switchoff$ %It puts off all switches.It is provided for convenience$ << !*exp:=nil$ !*allfac:=nil$ !*gcd:=nil$ !*rat:=nil$ !*factor:=nil$ !*intstr:=nil$ !*mcd:=nil$ !*div:=nil$ !*rational:=nil>>$ symbolic procedure switchorg$ %It puts all switches to their value when entering the system$ << !*exp:=t$ !*allfac:=t$ !*gcd:=nil$ !*mcd:=t$ !*div:=nil$!*rat:=nil$ !*intstr:=nil$ !*rational:=nil>>$ flag('(switchorg switchoff),'opfn)$ deflist('((switches endstat) (switchorg endstat) (switchoff endstat)), 'stat)$ 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 list('bag,'bag),!:flaglis))$ symbolic procedure !:delete(u,prop,val)$ if prop then for each x in !:proplis do if x=list(u,prop,val) then !:proplis:=delete(x,!:proplis) else nil else for each x in !:flaglis do if x=list(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 list(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>>$ 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; begin scalar x,y; argnochk ('cons . u); if (y := getrtype(x := reval cadr u)) eq 'vector then return prepsq simpdot u else if y eq 'list then return 'list . reval car u . cdr x else if bagp x then return car x . reval car u . cdr x else if fixp x then return x:=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!*(x,y)) then nil else prf . y end; symbolic procedure rassoc!*(u,v); % Finds term in which U is the first term in the right part of a term % in the association list V, or NIL if term is not found. if null v then nil else if u = cadar v then car v else rassoc!*(u,cdr v); 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; symbolic procedure minlist u; % Selects the smallest number in a list of numbers. if null cdr u then nil else expand(cdr u,'inf2); symbolic procedure maxlist u; % Selects the biggest number from the list of numbers u . if null cdr u then nil else expand(cdr u,'sup2); flag('(inf2,sup2,minlist maxlist),'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); symbolic procedure simpfact u; begin scalar var; var:=reval cadr u; if not (fixp var) or (var < 0) then return mksq(u,1) else return fact!-num var . 1; end; symbolic procedure fact!-num n; % simple factorial % then error(50,list(n,"invalid factorial argument")) if (n > 16) then facpart(1,n) else begin scalar m; m:=1; for i:=1:n do m:=m*i; return m; end; symbolic procedure facpart (a,e); if a = e then a else if (e-1) = a then a * e else facpart(a,(a+e)/2) * facpart((a+e)/2 + 1,e); put('fact,'simpfn,'simpfact); flag('(fact), 'full); 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 fact(n)/fact(nu)/fact(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); % 4. FUNCTIONS TO DEAL WITH PROPERTIES IN THE ALGEBRAIC MODE. global('(!:flaglis !:proplis)); symbolic(!:flaglis:=union(list list('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 list(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 list(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); symbolic procedure remvar!:(u,v)$ begin scalar buf,av$ buf:=cdr inputbuflis!*$ for each x in buf do if car (x:=cadr x) ='setk then begin scalar uu,xx$ uu:=x; l1: if null cddr uu then return av$ xx:=cadadr uu$ if gettype xx eq v then av:=cons(xx,av)$ uu:=caddr 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('(displayvar displaylst displatscal),'noform); symbolic procedure displayvar$ % 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; remvar!:(t,'variable); symbolic procedure displayscal$ % 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; remvar!:(t,'scalar); symbolic procedure displaylst$ % 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; remvar!:(t,'list) $ symbolic procedure clearvar$ % Allows to clear all user variables introduced % DIRECTLY ON THE CONSOLE; remvar!:(nil,'variable)$ symbolic procedure clearscal$ % Allows to clear all user variables introduced % DIRECTLY ON THE CONSOLE; remvar!:(nil,'scalar)$ symbolic procedure clearlst$ % Allows to clear all user variables introduced % DIRECTLY ON THE CONSOLE; remvar!:(nil,'list)$ symbolic procedure rema!:(u)$ % This function works to trace or to clear arrays. begin scalar buf,av$ buf:=cdr inputbuflis!*$ for each x in buf do if car(x:=cadr x) eq 'arrayfn then begin scalar uu,xx$ uu:=cdaddr x$ l1: if null uu then return av else if gettype (xx:=cadadr car uu ) eq 'array 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('(displayar),'noform); symbolic procedure displayar$ % 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; rema!:(t)$ symbolic procedure clearar$ % Allows to clear all user variables introduced % DIRECTLY ON THE CONSOLE; rema!:(nil)$ symbolic procedure remsvar!:(u)$ begin scalar buf,av$ buf:=cdr inputbuflis!*$ for each x in buf do if car (x:=cadr x) eq 'saveas then if gettype (x:=cadr cadadr x) member list('scalar,' variable,'list) then av:=cons(x,av)$ av:= !:mkset av$ if null u then <<for each x in av do clear x$ return t>> else return av end$ flag('(displaysavar),'noform); symbolic procedure displaysvar$ % 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; remsvar!:(t) $ symbolic procedure clearsvar$ % 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; remsvar!:(nil)$ 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). begin scalar buf,av$ buf:=cdr inputbuflis!*$ for each x in buf do if car(x:=cadr x) eq 'matrix then begin scalar uu,xx$ uu:=cdadr x$ l1: if null uu then return av else if gettype(xx:=if length car uu = 2 then cadr car uu else cadadr car uu) 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$ symbolic flag('(displaymat),'noform); symbolic procedure displaymat$ % 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; remm!:(t)$ symbolic procedure clearmat$ % Allows to clear all user variables introduced % DIRECTLY ON THE CONSOLE; remm!:(nil)$ symbolic procedure remv!:(u)$ % This function works to trace or to clear matrices. begin scalar buf,av$ buf:=cdr inputbuflis!*$ for each x in buf do if car(x:=cadr 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; remv!:(t) $ symbolic procedure clearvec$ % Allows to clear all user variables introduced % DIRECTLY ON THE CONSOLE; remv!:(nil)$ symbolic procedure remf!:(u)$ % This function works to trace or to clear arrays. begin scalar buf,av$ buf:=cdr inputbuflis!*$ for each x in buf do if car(x:=cadr 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 get(xx:=cadr cadadr cdar uu,'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; remf!:(t) $ symbolic procedure clearform$ % Allows to clear all user variables introduced % DIRECTLY ON THE CONSOLE; remf!:(nil)$ symbolic procedure clear!_all; <<remvar!: (nil,'variable);remvar!: (nil,'scalar); remvar!:(nil,'list);remsvar!: nil; rema!: nil;remv!: nil;remm!: nil; remf!: nil ;t>>; symbolic procedure show u; begin u:=car u; if u member list('vectors,'tvectors,'indices) then return displayvec() else if u eq 'variables then return displayvar() else if u eq 'scalars then return displayscal() else if u eq 'lists then return displaylst() else if u eq 'saveids then return displaysvar() else if u eq 'matrices then return displaymat() else if u eq 'arrays then return displayar() else if u eq 'forms then return displayform() 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); % 3. 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); 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)>>; flag('(leadterm redexpr ),'opfn); flag('(leadterm redexpr ),'noval); 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); begin scalar aa,ratsav; %ratsav:=rational; % if rational=0 then on rational; aa:=wws; for all x,y let sin(x+y)=sin(x)*cos(y)+cos(x)*sin(y), cos(x+y)=cos(x)*cos(y)-sin(x)*sin(y); for all x,n such that fixp n and n>1 let sin(n*x)=sin(x)*cos((n-1)*x)+cos(x)*sin((n-1)*x), cos(n*x)=cos(x)*cos((n-1)*x)-sin(x)*sin((n-1)*x); aa:=aa; for all x,y clear cos(x+y),sin(x+y); for all x,n such that fixp n and n>1 clear sin(n*x),cos(n*x); return aa end; algebraic procedure hypexpand(wws); begin scalar aa,ratsav; %ratsav:=rational; aa:=wws; for all x,y let sinh(x+y)=sinh(x)*cosh(y)+cosh(x)*sinh(y), cosh(x+y)=cosh(x)*cosh(y)+sinh(x)*sinh(y); for all x,n such that fixp n and n>1 let sinh(n*x)=sinh(x)*cosh((n-1)*x)+cosh(x)* sinh((n-1)*x), cosh(n*x)=cosh(x)*cosh((n-1)*x)+sinh(x)* sinh((n-1)*x); aa:=aa; for all x,y clear cosh(x+y),sinh(x+y); for all x,n such that fixp n and n>1 clear sinh(n*x),cosh(n*x); return aa end; operator !#ei!&; !#ei!&(0):=1; for all x,n let !#ei!&(x)**n=!#ei!&(n*x); for all x,y let !#ei!&(x)*!#ei!&(y)=!#ei!&(x+y); algebraic procedure trigreduce(wws); begin scalar aa;aa:=wws; for all x let cos(x)=(!#ei!&(x)+!#ei!&(-x))/2, sin(x)=-i*(!#ei!&(x)-!#ei!&(-x))/2; aa:=aa; for all x clear cos(x),sin(x); for all x let !#ei!&(x)=cos(x)+i*sin(x); aa:=aa; for all x clear !#ei!&(x); return aa end; algebraic procedure hypreduce(wws); begin scalar aa;aa:=wws; for all x let cosh(x)=(!#ei!&(x)+!#ei!&(-x))/2, sinh(x)=(!#ei!&(x)-!#ei!&(-x))/2; aa:=aa; for all x clear cosh(x),sinh(x); for all x let !#ei!&(x)=cosh(x)+sinh(x); aa:=aa; for all x clear !#ei!&(x); return aa end; algebraic procedure logplus(wws); begin scalar aa; aa:=wws; for all x,n let log(x/n)=log(x)-log(n), log(x*n)=log(x)+log(n), log(sqrt(x))=1/2*log(x), log(x**n)=n*log(x); aa:=aa; for all x,n clear log(x/n),log(x*n),log(sqrt(x)),log(x**n); return aa end; algebraic procedure concsumlog (exp); if den exp neq 1 then concsumlog(num exp)/concsumlog(den exp) else begin scalar ex; ex:=exp; % realizes the concatenation of "sum over i c(i)*log x(i)". operator e!_log!_conc; for all x,y,z let log(x*e!_log!_conc(y)/z)=log(x/z)+y, log(x*e!_log!_conc(-y)/z)=log(x/z)-y, log(x*e!_log!_conc(-y))=log(x)-y, log(x*e!_log!_conc(y))=log(x)+y, log(e!_log!_conc(y))=y; for all a,x,y let e!_log!_conc(-a*log(x)) = 1/x**a, e!_log!_conc(a*log (x)) = x**a, e!_log!_conc(-log x)=1/x, e!_log!_conc(log x)=x, e!_log!_conc(x+y)=e!_log!_conc(x)*e!_log!_conc(y); ex:=log e!_log!_conc(ex); for all x,y,z clear log(x*e!_log!_conc(y)/z), log(x*e!_log!_conc(-y)/z), log(x*e!_log!_conc(-y)), log(x*e!_log!_conc(y)), log(e!_log!_conc(y)); for all a,x,y clear e!_log!_conc(-a*log(x)), e!_log!_conc(a*log (x)) , e!_log!_conc(-log x), e!_log!_conc(log x), e!_log!_conc(x+y); clearop e!_log!_conc; return ex end; 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;