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;