Artifact f968fdd3e221e9efcccc576642291ef1e53a3bd23b364256c6e271458eb3f380:
- File
r34.1/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: 64591) [annotate] [blame] [check-ins using] [more...]
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;