Artifact 71a7061ee0f05d04fcd425b97ff94932ac0f6dee4ec4d8653ccff97e93f4f4ef:
- File
r35/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: 79689) [annotate] [blame] [check-ins using] [more...]
module assist; % Header Module for ASSIST package. % create!-package('(assist switchext baglist genpurfunc control % polyextensions transfunctions vectoroper grassman % matrext), % '(contrib assist)); % % ******************************************************************** % % Author: H. Caprasse <caprasse@vm1.ulg.ac.be>. % % Version and Date: Version 2.0, 30 Mai 1993. % % Revision history to versions 1.0, 1.1, 1.2 and 1.3 : % % 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. % 10 March.1992 : Correction in MONOM. % 1 June 1992 : Second correction to MONOM to include constant terms. % 3 August 1992: LIST2 and LIST3 replaced by LIST. % 19 August 1992: SPLITPLUSMINUS and SPLITTERMS introduced in module % PolyExtensions. % 26 Jan. 1993 : Function MKIDNEW is introduced. It generates a % fresh identifier from a given already used id. % 26 Feb. 1993 : Correction to DISTRIBUTE to make it work correctly % when non-commuting operators are involved. % Addition of the function DELLASTDIGIT. % INF2, SUP2 eliminated since in the kernel of % REDUCE under the names MIN and MAX. % EVENP eliminated for the same reason. % 5 March 1993 : Introduction of module GRASSMAN % Additional functions for LIST-like objects % 1 April 1993 : Generalization of FUNVAR to arguments which % : are themselves lists. % DELPAIR function created. % : Basic function for deleting all obj of a given % : given type created. % 1 May 1993 : Correction to SPLITTERMS and RCONS % : New functions CYCLICPERMLIST,APPENDN,INSERT_KEEP_ORDER % : CHECKPROPLIST, EXTRACTLIST, SORTNUMLIST. % 15 May 1993 : LIST_TO_IDS replaces MKIDN. % : SORTLIST generalises SORTNUMLIST to sort list of ids. % : ALG_TO_SYMB et SYMB_TO_ALG created. % : MERGE_LIST complementary function to INSERT_KEEP_ORDER % 17 May 1993 : Creation of SYMMETRIZE % 28 May 1993 : Generalization of SYMMETRIZE and SYMB_TO_ALG % ******************************************************************** % 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$ global('(!:flaglis !:proplis)); % 1. Functions which works on LIST_like objects. algebraic procedure frequency lst; % gives a LIST of PAIRS {{el1,freq1} ...{eln,freqn}}. % Procedure created by E. Schruefer. <<clear count!?!?; operator count!?!?; frequency1 lst>>; algebraic procedure frequency1 lst; if lst = {} then {} else begin scalar r,el; el := first lst; if numberp count!?!? el then <<count!?!? el := count!?!? el + 1; r := frequency1 rest lst>> else r := {el,count!?!? el} . <<count!?!? el := 1; frequency1 rest lst>>; return r end; symbolic procedure sequences n; % Works properly, both in the symbolic and in the algebraic mode. if !*mode eq 'symbolic then sequsymb n else algebraic sequalg n; flag('(sequences),'opfn); symbolic procedure sequsymb n; % Corresponds to the one below in the symbolic mode. if n=1 then list(list(0),list(1)) else for each s in sequsymb (n-1) conc list(0 . s,1 . s); algebraic procedure sequalg n; % Gives the list {{0,0 ...,0},{0,0, ..., 1}, ...{1,1, ..., 1}} % "conc" used in an explicit way. if n = 1 then {{0},{1}} else for each s in sequalg(n - 1) conc {0 . s,1 . s}; symbolic procedure rmklis u$ begin scalar s,ss;integer n; 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); symbolic procedure insert_keep_order(u,l,fn); if get(fn,'number!-of!-args)=2 and not atom l then 'list . insert_keep_order1(u,cdr l,fn) else typerr(list(l,fn),"list and binary function"); flag('(insert_keep_order),'opfn); symbolic procedure insert_keep_order1(u,l,fn); % u is any object, l is a list and fn is a BINARY boolean function. if null l then list u else if apply(fn,list(u,car l)) then u . l else car l . insert_keep_order1(u,cdr l,fn); symbolic procedure merge_list(l1,l2,fn); % fn is a binary boolean function 'list . merge_list1(cdr l1,cdr l2,fn); flag('(merge_list),'opfn); symbolic procedure merge_list1(l1,l2,fn); % Returns the (physical) merge of the two sorted lists l1 and l2. % Example of use : % l1:=list(1,2,3)$ l2:=list(1,4,5)$ % merge(l1,l2,'lessp); ==> (1 1 2 3 4 5) % l1 and l2 are destroyed % This is complementary to the function INSERT_KEEP_ORDER if null l1 then l2 else if null l2 then l1 else if apply2(fn,car l1,car l2) then rplacd(l1,merge_list1(cdr l1,l2,fn)) else rplacd(l2,merge_list1(l1,cdr l2,fn)); % 2. Introduction of BAG-like objects. 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); algebraic procedure split(u,v); % split(list(a,b,c),list(1,1,1)); ==> {{A},{B},{C}} % split(bag(a,b,c,d),list(1,1,2)); ==> {{A},{B},{C,D}} % etc. if baglistp u and baglistp v then begin scalar x; return for each n in v collect for i := 1:n collect <<x := u.1; u := rest u; x>> end else lisp rederr(list(u,v,": must be lists or bags")); 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. if atom ( u:=reval car u) then nil else % if kernp mksq(u,1) then 'list . cdr u ; if kernp mksq(u,1) then 'list . for each i in cdr u collect mk!*sq simp!* i ; put('kernlist,'psopfn,'rexplis); symbolic procedure rlisbag u$ begin scalar x,prf; 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('listbag,'psopfn,'rlisbag); symbolic procedure rfirst 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; 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; 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; 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; <<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; <<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; <<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; 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('append,'psopfn,'rappend); symbolic procedure rappendn u; % This append function works for any number of arguments and all % types of kernels. begin scalar x,y; x:= revlis u; y:=for each i in x collect mkquote if atom i then rederr("arguments must be kernels or lists") else cdr i; x:= eval expand(y,'append); return 'list . x end ; put('appendn,'psopfn,'rappendn); symbolic procedure rcons u; % Dans ASSIST.RED % 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 if (y := getrtypeor(x := revlis u)) eq 'hvector then return if get('cons,'opmtch) and (z := opmtch('cons . x)) then reval z else prepsq subs2 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:= if get('rcons,'cleanupfn) then 'bag . revalpart u else revalpart u else typerr(x,"list or bag") end; symbolic procedure isimpa(u,v); if eqcar(u,'list) then u else if eqcar(u,'bag) then cdr u else !*q2a1(isimpq simp u,v); flag('(isimpa),'lose); symbolic put('cons,'setqfn,'(lambda (u v w) (setpart!* u v w))); 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; 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('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 delete_all(ob,u); 'list . del_all_obj(ob,cdr u); flag('(delete_all),'opfn); symbolic procedure del_all_obj(ob,u); % Deletes from list u ALL objects ob if null u then nil else if car u = ob then del_all_obj(ob,cdr u) else car u . del_all_obj(ob,cdr u); symbolic procedure rmember u; % First argument is anything, second argument is a bag or list. begin scalar x,y$ 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('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; 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('elmult,'psopfn,'relmult); % Use is " elmult (any , < bag OR list> ) " . symbolic procedure rpair u$ begin scalar x,y,prf$ 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('pair,'psopfn,'rpair); symbolic procedure delpair(elt,u); 'list . for each j in delasc(elt,for each i in cdr u collect cdr i) collect 'list . j ; flag('(delpair),'opfn); 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; 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; 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,'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('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; 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('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; 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('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; 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('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; 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('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; 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('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; reval subst(reval car u,reval cadr u,reval caddr u); 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; 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('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; 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('represt,'psopfn,'!:repld); symbolic procedure rinsert u; begin scalar x,bg,bbg,prf; integer n; 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,'psopfn,'rinsert); % Use is : insert(<any>, <list or bag>, <integer>). % HERE ARE FUNCTIONS FOR SETS. symbolic procedure !:union u$ begin scalar x,y,prf; 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,'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$ 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; 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('diffset,'psopfn,'!:setdiff); symbolic procedure !:symdiff u$ begin scalar x,y,prf; 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,'psopfn,'!:symdiff); symbolic procedure !:xn u$ begin scalar x,y,prf; 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('intersect,'psopfn,'!:xn); endmodule ; module genpurfunc; %=====================================================================$ % $ % VARIOUS GENERAL PURPOSE FUNCTIONS $ % $ %=====================================================================$ % 1. GENERALIZATION OF EXISTING FUNCTIONS symbolic procedure rmkidnew(u); if null u or null (u:=reval car u) then gensym() else mkid(u,gensym()); put('mkidnew,'psopfn,'rmkidnew); % Usage mkidnew() or mkidnew(<id>). symbolic procedure list_to_ids l; if atom l then rederr "argument for list_to_ids must be a list" else intern compress for each i in cdr l join explode i; flag('(list_to_ids),'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 ==; 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; not evenp u; flag('(oddp),'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 dellastdigit u; % Strips an integer from its last digit. if fixp u then compress reverse cdr reverse explode u else typerr(u,"integer"); flag('(dellastdigit),'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 transpose(l,i,j); % i,j are integers, l is a list. % DESTROYS the initial list. begin scalar tmp; tmp:=nth(l,i); nth(l,i):=nth(l,j); nth(l,j):=tmp; return l end; 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 cyclicpermlist l; % Gives all cyclic permutations of elements of the list l. if atom l then nil else begin scalar x; integer le; l:=cdr l; le:=length l; x:= ('list . l) . x; for i:=2:le do x:=('list . (l:=append(cdr l,list car l))) . x; return 'list . reversip x end; flag('(cyclicpermlist),'opfn); symbolic procedure rpermutation 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; 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); put('symmetrize,'simpfn,'simpsumsym); flag('(symmetrize),'listargp); symbolic procedure simpsumsym(u); % The use is SYMMETRIZE(LIST(A,B,...J),operator,perm_function) % or SYMMETRIZE(LIST(LIST(A,B,C...)),operator,perm_function). % Works both for OPFN and symbolic procedure functions. % Does not yet allow odd permutations. if length u neq 3 then rederr("3 arguments required for symmetrize") else begin scalar uu,x,res,oper,fn,bool,boolfn; integer n; fn:= caddr u; if not gettype fn eq 'procedure then typerr(fn,"procedure"); uu:=(if flagp(fn,'opfn) then <<boolfn:=t; reval x>> else cdr reval x) where x=car u; n:=length uu; oper:=cadr u; if not idp oper then typerr(oper,"operator") else if null flagp(oper,'opfn) then if null get(oper,'simpfn) then put(oper,'simpfn,'simpiden); flag(list oper, 'listargp); % << put(oper,'simpfn,'simpiden); flag(list oper, 'listargp)>>; x:=if listp car uu and not boolfn then <<bool:=t;apply1(fn, cdar uu)>> else if boolfn and listp cadr uu then <<bool:=t;apply1(fn,cadr uu)>> else apply1(fn,uu); if flagp(fn,'opfn) then x:=alg_to_symb x; n:=length x -1; if not bool then << res:=( oper . car x) .** 1 .* 1 .+ nil; for i:=1:n do << uu:=cadr x; aconc(res,(oper . uu) .** 1 .* 1 ); delqip(uu,x);>>; >> else << res:=(oper . list('list . for each i in car x collect mk!*sq simp!* i)) .** 1 .* 1 .+ nil; for i:=1:n do << uu:=cadr x; aconc(res,(oper . list('list . for each i in uu collect mk!*sq simp!* i)) .** 1 .* 1 ); delqip(uu,x);>>; >>; if get(oper,'opmtch) or flagp(oper,'opfn) then res:=resimp( res ./ 1) else res:=res ./ 1; return res end; symbolic procedure delqip1(u,v); if not pairp cdr v then nil else if u eq cadr v then rplacd(v,cddr v) else delqip1(u,cdr v); symbolic procedure delqip(u,v); if not pairp v then v else if u eq car v then cdr v else <<delqip1(u,v); v>>; symbolic procedure extremum(l,fn); if atom l then l else (if null x then nil else maximum3(x ,cadr l,fn))where x=cdr l; flag('(extremum),'opfn); symbolic procedure maximum3(l,m,fn); if null l then m else if apply2(fn,car l,m) then maximum3(cdr l,car l,fn) else maximum3(cdr l, m,fn); symbolic procedure sortnumlist l; % Procedure valid only for list of integers. % Returns the sorted list without destroying l. 'list . (if length x < 10 then bubblesort1 x else quicksort_i_to_j(x,1,length x))where x=cdr l ; flag('(sortnumlist),'opfn); symbolic procedure sortlist(l,fn); if null cdr l then list('list) else if numlis cdr l then if fn eq 'lessp then sortnumlist l else if fn eq 'geq then ( 'list . (reverse(if length x <10 then bubblesort1 x else quicksort_i_to_j(x,1,length x))) where x=cdr l) else nil else 'list . bubsort1(cdr l,fn); flag('(sortlist),'opfn); symbolic procedure bubblesort1 l; % Elements of l are supposed to be numbers. begin integer ln; ln:=length l; for i:=1:ln do for j:=i+1:ln do if i neq j and nth(l,i)>nth(l,j) then transpose(l,i,j) else nil; return l end; symbolic procedure bubsort1(l,fn); % Elements of l are numbers or identifiers. % fn is any ordering function. begin integer ln; ln:=length l; for i:=1:ln do for j:=i+1:ln do if i neq j and apply2(fn,nth(l,j),nth(l,i)) then transpose(l,i,j) else nil; return l end; symbolic procedure find_pivot_index(l,i,j); % l is the list, i and j are integers. begin scalar key; integer k; key:=nth(l,i); k:=i+1; a: if k=J+1 then return -1; if nth(l,k) > key then return k else if nth(l,k) < key then return i; k:=k+1; go to a end; symbolic procedure partition(l,i,j,pivot); % Writes l, all elements less than pivot to the left % and elements greater or equal to the right of pivot. % returns the new pivot. begin integer le,ri; le:=i; ri:=j; a: if le>ri then return le; transpose(l,le,ri); while nth(l,le) < pivot do le:=le+1; while nth(l,ri) >= pivot do ri:=ri-1; go to a end; symbolic procedure quicksort_i_to_j(l, i,j); begin integer k,pi; pi:=find_pivot_index(l,i,j); return if pi neq -1 then <<pi:=nth(l,pi); k:=partition(l,i,j,pi); quicksort_i_to_j(l,i,k-1);quicksort_i_to_j(l,k,j);l>> else l end; symbolic procedure listofvars u $ if null u or numberp u then nil else if atom u then list u else varsinargs if eqcar(u,'list) then cdr reval u else cdr u$ symbolic procedure varsinargs(u)$ if null u then nil else append(listofvars car u,varsinargs cdr u)$ 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 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 >>; symbolic put('funcvar,'psopfn ,'rfuncvar); flag('(e i),'reserved); 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. symbolic procedure checkproplist(l,fn); % fn may be the name of a function or the expression 'function <name if atom l then rederr("First argument must be a list") else checkproplist1(cdr l,fn); flag('(checkproplist),'boolean); symbolic procedure checkproplist1(l,fn); % Checks if the list l has the property defined by the function fn. % fn should preferably be 'function <name_function>'. if null l then t else if fn eq 'numberp then if apply1(function evalnumberp, car l) then checkproplist1(cdr l,fn) else nil else if fn eq 'floatp then if atom car l then nil else if apply1(function floatp, cdar l ) then checkproplist1(cdr l,fn) else nil else if get(fn,'number!-of!-args)=1 then if apply1(fn,car l) then checkproplist1(cdr l,fn) else nil else if get(fn,'number!-of!-args)=2 then if apply(fn,list(car l,cadr l)) then checkproplist1(cdr l,fn) else nil; symbolic procedure extractlist(l,fn); if get(fn,'number!-of!-args) > 1 then rederr("UNARY booelean function required as argument") else 'list . extractlist1(cdr l,fn); flag('(extractlist),'opfn); symbolic procedure extractlist1(l,fn); % fn is a boolean function. Result is a new list which contains the % elements satisfying the fn selection criteria. % Does NOT work yet for floating point numbers. if null l then nil else if fn eq 'numberp then if apply1(function evalnumberp,car l) then car l . extractlist1(cdr l,fn) else nil else if fn eq 'floatp then if atom car l then nil else if apply1(function floatp,cdar l) then car l . extractlist1(cdr l,fn) else nil else if apply1(fn,car l) then car l . extractlist1(cdr l,fn) else extractlist1(cdr l,fn); 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)$ flg>> 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 if length aa = 1 then car aa else '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); % NOT COMMENTED symbolic procedure nordp(u,v); % TRUE if a>b, FALSE if a=<b. 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 ),'opfn)$ deflist('((switches endstat) (switchorg 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,'number!_og!_args); remprop(uu,'stat); remprop(uu,'dfn); remflag(list uu,'opfn)$ remflag(list uu,'listargp); 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. %===================================================================== symbolic procedure alg_to_symb u; % transforms standard quotient expressions into prefix symbolic ones. % dd => (LIST 1 (!*SQ ((((A . 2) . 1)) . 1) T) % (!*SQ ((((A . 1) . 1)) . 1) T) % 3 (LIST 4)) % alg_to_symb dd ==> (1 (EXPT A 2) A 3 (4)) % if null u then nil else if atom u then u else if car u neq 'list then reval u else if car u eq 'list then for each i in cdr u collect alg_to_symb i; symbolic procedure fix_or_str u; fixp u or stringp u; symbolic procedure symb_to_alg u; % transforms prefix lisp list into an algebraic list. if null u then nil else if fix_or_str u then u else if atom u then mk!*sq simp!* u else if listp u and getd car u then mk!*sq simp!* u else if atomlis u then 'list . for each i in u collect if fix_or_str i then i else mk!*sq simp!* i else 'list . for each i in u collect symb_to_alg i ; %symbolic procedure symb_to_alg u; % transforms prefix lisp list into an algebraic list. %if null u then nil else %if fixp u then u else %if atom u then mk!*sq simp!* u else %if listp u and getd car u then mk!*sq simp!* u else % 'list . for each i in u collect symb_to_alg i ; 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 ordpp(lpow u,lpow v) then lt u .+ addfd(red u,v) else lt v .+ addfd (u,red v); symbolic procedure distribute u; % Works ONLY when RATIONAL is OFF. begin scalar s; s:=simp!* u; return mk!*sq (distri!_pol(numr s) ./ denr s) end; % symbolic procedure distribute u; % Gives a polynome in distributed form in the algebraic mode. % NO LONGER USED %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(x,!*p2f lpow y); 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) begin scalar exp,lmon,mon; exp:=u; l: if null exp then return lmon else if domainp exp then return exp . lmon ; mon:=if atom exp then exp else lt exp; lmon:=(!*t2f mon ) . lmon; exp:=red exp; go to l; end; symbolic procedure monom y; % This procedure works ONLY for polynomials in the strict sense. It is % left to generalize it when RATIONAL or RATARG are on but why ...? begin scalar x; x:=numr simp!* y; x:=distri!_pol x; x:=reversip list!_of!_monom x; x:=for each m in x collect mk!*sq(m ./ 1); return 'list . x end; symbolic flag('(monom),'opfn); 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 OUT OF THE POLYNOMIAL U. % U is the POLYNOMIAL. V is an ID or a KERNEL. 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)$ % splitting expressions % splitterms retuns list of plus-terms and minus-terms. symbolic operator splitterms; % necessary to make it algebraic. symbolic procedure splitterms u; begin scalar a,b; if fixp u and evallessp(u, 0) then return 'list . ('list . 0 . nil) . ('list . list('minus, u) . nil) . nil else if atom u or not(car u member(list('plus,'minus))) then return 'list . ('list . u . nil) . ('list . 0 . nil) . nil else if car u eq 'minus then return 'list . ('list . 0 . nil) . ('list . cdr u) . nil; while(u:=cdr u) do if atom car u or not (caar u eq 'minus) then a:= car u . a else b:=cadar u . b; if null a then a:=0 . nil; if null b then b:=0 . nil; return 'list . ('list . reversip a) . ('list . reversip b) . nil; end; algebraic procedure splitplusminus(u); % Applies to rational functions. begin scalar uu; uu:=splitterms num u; return list((for each j in first uu sum j) /den u, - (for each j in second uu sum j)/den u) end; 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)}); % 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; 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; 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; 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; '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 grassman; % fichier de manipulation des variables de Grassmann. % RATIONAL functions involving Grasman variables inside the % denominator NOT ALLOWED. % symbolic procedure putgrass u; % Allows to define Grassmann variables. for each i in u do if not idp i then typerr(i,"grassman variable") else <<flag(list i,'noncom); put(i,'simpfn,'simpiden); flag(list i, 'grassman);>> ; rlistat '(putgrass remgrass); symbolic procedure remgrass u; % Erase the Grassman properties of the identifiers in u. for each i in u do if flagp(i,'grassman) then <<remflag(list i,'grassman);remflag(list i ,'noncom); clearop i;>>; symbolic procedure grassp u; not atom u and flagp(car u, 'grassman); lisp flag('(grassp),'boolean); %symbolic procedure grassparityini u; % Not used anymore %if grassp u then 1 else 0; symbolic procedure grassparity u; if atom u then 0 else if flagp(car u,'grassman) then 1 else if car u eq 'plus then "parity undefined" else if car u eq 'minus then grassparity cadr u else if car u eq 'times then remainder(for each i in cdr u sum grassparity i,2) else if car u eq 'expt then if oddp caddr u then grassparity cadr u else 0 else if car u eq 'quotient then grassparity cadr u else 0; flag('(grassparity ghostfactor),'opfn); symbolic procedure ghostfactor(u,v); % (-1)^(grassparity u * grassparity v) if reval list('times, grassparity u, grassparity v) = 0 then 1 else -1; % ***************** % For the time being we let the explicit manipulation of % Grassman variables as matching rules : % here is an example of use of the previous functions : % to try them erase the % % putgrass eta,prond; % grasskernel:= % {(~x)*(~y) => y*x when grassp x and not grassp y, % prond(~x)*eta(~y) => -eta(y)*prond(x), % eta(~x)*eta(~y) => -eta y*eta x when nordp(x,y), % prond(~x)*prond(~y) => -prond y*prond x when nordp(x,y), % (~x)*(~x) => 0 when grassp x}; % let grasskernel; % *********************** 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 row N from 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 column N from 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;