module opertens;
% This module generalizes CANONICAL to make it active
% on expressions which are arguments of OPERATORS. The typical
% case, presently implemented, is when the expression is under
% the derivative df.
% A general operator, to be treated as df must be endowed
% with a specific property which makes it "transparent" to canonical
% so that CANONICAL can see the argument(s) it contains, recognize the
% (eventually explicitly declared) dummy indices these depend on
% and, finally, find their normal form.
switch onespace;
!*onespace:=t; % working inside a unique space is the default.
fluid '(opertensnewids!*);
symbolic procedure restorealldfs u;
begin scalar y,z,w;
z:=fullcopy u;
w:=z;
l: if domainp z then return w
else if (not atom mvar z) and (y:=get(car mvar z, 'Translate2))
then mvar z:=apply1(car y,mvar z);
z:= lc z;
go to l;
end;
%symbolic procedure restorealldfs u;
%begin scalar y,z;
% z:=u;
% l: if domainp z then return u
% else if (not atom mvar z) and (y:=get(car mvar z, 'Translate2))
% then mvar z:=apply1(car y,mvar z);
% z:= lc z;
% go to l;
%end;
symbolic procedure clearallnewids;
% the ephemerous operators created by 'dftypetooper' must
% be eliminated after the normal form is found.
% This is done here.
<<for each x in opertensnewids!* do
<<if flagp(x,'tensor) then
rem_tensor1 x
else clear x;
remprop(x,'Translate2)>>;
opertensnewids!*:=nil>>;
symbolic procedure dftypetooper(u);
% (df (g a) (n b) 2) as arg and gives back (df_g_n_2 a b)
% df_g_n_2 gets property (dfprop df (g 1) (n 1) 2)
% same occurs for dfpart if it is given the prop ('Transtocanonical 'dftypetooper)
% Declares the results as being a tensor if one of the args at least is tensor
begin scalar name,proplist,arglist,varlist,switchid,IsTens,spacel,z;
name:=list(car u);
proplist:= name;
for each y in cdr u do
<< if listp y then
<< name:=car y . ('!_ . name);
if flagp(car y,'tensor) then
<< IsTens:=t;
if null !*onespace and null((z:=get(car y,'belong_to_space)) memq spacel)
then spacel:=z . spacel;
if (listp cadr y) and ((caadr y) eq 'list ) then
<< proplist:= list(car y, length cdr y - 1, length cadr y - 1) . proplist;
varlist:=append(varlist, cdadr y);
for each z in cddr y do
arglist:=<<if switchid then id_switch_variance z
else z>> . arglist ;>>
else
<< proplist:= list(car y, length cdr y) . proplist ;
for each z in cdr y do
arglist:= <<if switchid then id_switch_variance z
else z>> . arglist ;>>; >>
else
<< proplist:= list(car y,length cdr y) . proplist;
varlist:=append(varlist,cdr y); >>;
>>
else
<< name:= y . ('!_ . name);
proplist:= y . proplist ; >>;
switchid:=t;
>>;
arglist:=reverse(arglist);
proplist:=reverse(proplist);
name:=list_to_ids!:(reverse name);
if IsTens then
<< if flagp(name,'tensor)
then
<< if get(name,'translate2) and ((cdr get(name,'translate2)) neq proplist) then
rerror(cantens,13,"problem in number of arg") >>
else
<<make_tensor(name,t);
intern name;
if (null !*onespace) and (length(spacel)=1)
then put(name,'belong_to_space,car spacel);
opertensnewids!*:= name . opertensnewids!* ;
put(name,'translate2,'opertodftype . proplist)>>;
if varlist then arglist := ('list . varlist) . arglist >>
else
<< if (get(name,'translate2)) and ( cdr get(name,'translate2) neq proplist) then
rerror(cantens,13,"problem in number of arg")
else
<<if null (gettype name = 'operator)
then << mkop name;
opertensnewids!*:= name . opertensnewids!* ;
intern name>>;
put(name,'Translate2,'opertodftype . proplist);
arglist:=varlist>> >>;
return name . arglist;
end;
symbolic procedure opertodftype(u);
% u is an operator (df_g_n_2 a b) where df_g_n_2 has property
% (dfprop (g 1) (n 1) 2)
% gives back the df : (df (g a) (n b) 2)
begin scalar proplist,idslist,varlist,argres,name,i,switchid,y,idsl,varl;
proplist:=cdr get(car u,'translate2);
name:=car proplist;
proplist:=cdr proplist;
idslist:=cdr u;
% get variables if there are some
if ((listp car idslist) and (caar idslist eq 'list)) then
<<varlist:=cdar idslist; idslist:=cdr idslist>>;
if flagp(car u,'tensor) then
for each y in proplist do
<<if listp y then
if flagp(car y,'tensor) then
<< idsl:=nil;
for i:=1:cadr y do
<< idsl:=(if switchid then id_switch_variance car idslist
else car idslist) . idsl;
idslist:=cdr idslist; >>;
idsl:=reverse idsl;
if cddr y then
<< varl:=nil;
for i:=1:caddr y do
<< varl:= car varlist . varl;
varlist:=cdr varlist >>;
varl:=reverse varl;
argres:=((car y . ( ('list . varl) . idsl)) . argres) >>
else argres:=((car y . idsl) . argres); >>
else
<< varl:=nil;
for i:=1:cadr y do
<< varl:=(car varlist) . varl;
varlist:=cdr varlist >>;
varl:=reverse varl;
argres:=(((car y) . varl) . argres)>>
else argres:=y . argres;
switchid:=t; >>
else
<< for each y in proplist do
if listp y then
<< varl:=nil;
for i:=1:cadr y do
<< varl:=((car idslist) . varl);
idslist:=cdr idslist >>;
varl:=reverse varl;
argres:=(((car y) . varl) . argres)>>
else argres:= y. argres; >>;
return name . (reverse argres)
end;
symbolic procedure makedfperm;
put('df,'Translate1,'dftypetooper);
flag ('(makedfperm), 'opfn);
deflist('((makedfperm endstat)),'stat);
makedfperm;
endmodule;
end;