%======================================================
% Name: tensor1.red - tensor continuation
% Author: A.Kryukov (kryukov@theory.npi.msu.su)
% Copyright: (C), 1993-1996, A.Kryukov
% Version: 2.22 Apr. 02, 1996
%------------------------------------------------------
% Release: Dec. 15, 1993
% Mar. 25, 1996 sieve_t2
% Apr. 02, 1996 t_add2
%======================================================
module tensor1$
global '(!*basis)$
global '(pv_den)$
symbolic procedure th2pe(th,v)$
% th - tensor header
% th::=(tname ...) . (i ...) . (d ...)
% v - vector
% return prefix expression
begin scalar pe,r,i,il,tt,tt1$
% tt,tt1 - tensor term
while v do <<
il:=pappl(cdar v,di_restore cadr th)$
tt1:=nil$
for each x in car th do <<
r:=get(x,'!:tensor)$
tt:=list x$
for i:=1:r do << tt:=car il . tt$ il:=cdr il >>$
tt1:=reversip tt . tt1$
>>$ % for each
tt1:=reversip tt1$
if null(caar v = 1) then tt1:=caar v . tt1$
if tt1 and cdr tt1 then tt1:='times . tt1$
if tt1 and null cdr tt1 then tt1:=car tt1$
pe:=tt1 . pe$
v:=cdr v$
>>$ % while v
pe:=reversip pe$
if pe and cdr pe then pe:='plus . pe
else if pe then pe:=car pe$
return pe$
end$
symbolic procedure t_pri1(tt,sw)$
% tt - tensor expression
% tt::=!:tensor . ((th . v) ...)
begin scalar pe,den$ %mod AK 28/03/96
tt:=cdr tt$
den:=cddr caar tt$ %+ AK 28/03/96
while tt do <<
pe:=th2pe(caar tt,cdar tt) . pe$
tt:=cdr tt$
>>$
if pe and cdr pe then pe:='plus . reversip pe
else if pe then pe:=car pe$
if not(den = 1) then pe:='quotient . pe . list den$%+ AK 28/03/96
% terpri()$ print list(">>>>>> t_pri1: pe=",pe)$ terpri()$
assgnpri(pe,nil,sw)$ % WN 10.4.96
end$
symbolic procedure pappl_t(p,tt)$
for each x in tt collect
(caar x . pappl(p,cadar x) . cddar x) . pappl_pv(p,cdr x)$
symbolic procedure t_add(t1,t2)$
if null cdr t1 then t2
else if null cdr t2 then t1
else if th_match(cadr t1,cadr t2)
then sieve_t(t_add2(t1,t2),!*basis)
else t_addf(t1,t2)$
symbolic procedure sieve_t(tt,bs)$
% tt:=(!:tensor . (ten1 ten2 ...))
car tt . sieve_t0(cdr tt,nil,bs)$ % -AK 250396
% ((car tt . car x) . cdr x) % +AK 250396
% where x=sieve_t0(cdr tt,nil,bs)$ % +AK 250396
symbolic procedure sieve_t0(u,v,bs)$ % July 13, 1994
% u::=(ten1 ten2 ...)
% v - sieved tensor (r.v.)
if null u then reversip v
else sieve_t0(cdr u
,((if cdr x then x . v else v) % -AK 250396
% ,((if cdr x then (x.pv_den) . v else v) % +AK 250396
where x=sieve_t2(car u,bs)
)
,bs
)$
symbolic procedure sieve_t1(tt,bs)$
% tt::=(th . pv)
begin scalar bs$
bs:=!*basis$
while bs and null th_match(car tt,caar bs) do bs:=cdr bs$
if bs then return car tt . sieve_pv(cdr tt,cdar bs)$
if dl_get(cadar tt) then <<
!*basis:=append(adddummy('!:tensor . list tt),!*basis)$
bs:=!*basis$
while bs and null th_match(car tt,caar bs) do bs:=cdr bs$
if bs then return car tt . sieve_pv(cdr tt,cdar bs)$
>>$
return tt$
end$
%symbolic procedure sieve_t2(tt,bs1)$ % Jul 13, 1994
% % tt::=(th . pv)
% begin scalar bs$
% bs:=bs1$
% if dl_get(cadar tt) then bs:=append(adddummy0(list tt,bs),bs)$
% while bs and null th_match(car tt,caar bs) do bs:=cdr bs$
% if bs then tt := car tt . sieve_pv(cdr tt,cdar bs)$
% return tt$
% end$
symbolic procedure sieve_t2(tt,bs1)$ % Mar. 25, 1996
% tt::=(th . pv)
begin scalar bs,tt1$
bs:=bs1$
if dl_get(cadar tt) then bs:=append(adddummy0(list tt,bs),bs)$
while bs and null th_match(car tt,caar bs) do bs:=cdr bs$
tt1:=tt$
pv_den:=1$
if bs then tt := car tt . sieve_pv0(cdr tt,cdar bs,nil)$
rplacd(cdar tt,cddar tt * pv_den)$ % + AK 28/03/96
if !*debug then
<< terpri()$
write " DEBUG: sieve_t2"$
terpri()$
t_pri1('!:tensor.list tt1,t);
if bs then
for each z in cdar bs
do t_pri1('!:tensor.list(caar bs.z),t);
terpri()$
t_pri1('!:tensor.list tt,t);
terpri()$
>>$
return tt$
end$
symbolic procedure t_addf(t1,t2)$
if ordp(cadr t1,cadr t2)
% then ( t1 .+ (t2 .+ nil) )
then ( ((t1 .** 1) .* 1) .+ ( ((t2 .** 1 ) .* 1) .+ nil) )
else t_addf(t2,t1)$
symbolic procedure t_add2(tx1,tx2)$
begin scalar w$
w:=il_update(cadar tx2,dl_get cadar tx1)$
w:=pfind(w,cadar tx1)$
% w:=for each x in cdr tx2 collect car x . pappl0(w,cdr x)$
% - AK 02/04/96
w:=for each x in cdr tx2 collect car x . pappl0(cdr x,w)$
% + AK 02/04/96
return car tx1 . pv_add(cdr tx1,w)$
end$
symbolic procedure t_match(t1,t2)$ th_match(car t1,car t2)$
symbolic procedure th_match(th1,th2)$
th_match0(th1,th2) and
(length dl_get cadr th1 = length dl_get cadr th2)$
symbolic procedure th_match0(th1,th2)$
(car th1 = car th2) and (length cadr th1 = length cadr th2)$
symbolic procedure th_match_(th1,th2)$
if car th1 = car th2 and th_match1(cadr th1,cadr th2)
then pfind(cadr th1,cadr th2)
else nil$
symbolic procedure th_match1(il1,il2)$
if null il1 then null il2
else if null(il2 = (il2:=delete(car il1,il2)))
then th_match1(cdr il1,il2)
else nil$
symbolic procedure t_neg te$
if numberp car te then list(-car te)
else for each x in te collect car x . pv_neg cdr x$
symbolic procedure t_mult(te1,te2)$
if null te1 then te2
else if numberp car te1 then c_mult(car te1,te2)
else if numberp car te2 then c_mult(car te2,te1)
else t_mult(cdr te1,t_mult1(car te1,te2))$
symbolic procedure t_mult1(te1,te)$
for each x in te collect t_mult2(te1,x)$
symbolic procedure t_mult2(tt1,tt2)$
begin scalar tt$
if cddr tt1 or cddr tt2
then rederr list('t_mult2," *** Must be tterms: ",tt1,tt2)$
tt:=tt1$
tt1:=t_upright(tt1,car tt2)$
tt2:=t_upleft(tt2,car tt)$
return (car tt1 . pv_multc(caadr tt1,cdr tt2))$
end$
symbolic procedure c_mult(c,te)$
if null te then nil
else if numberp car te then list(c*car te)
else for each x in te collect car x . pv_multc(c,cdr x)$
symbolic procedure t_upright(tt,th)$
begin scalar th1,tt1$
th1:=car tt$
th1:=append(car th1,car th) . append(cadr th1,cadr th)
. append(cddr th1,cddr th)$
return (th1 . pv_upright(cdr tt,length cadr th))$
end$
symbolic procedure t_upleft(tt,th)$
begin scalar th1,tt1$
th1:=car tt$
th1:=append(car th,car th1) . append(cadr th,cadr th1)
. append(cddr th,cddr th1)$
return (th1 . pv_upleft(cdr tt,length cadr th))$
end$
global '(!*debug_times)$
switch debug_times$
symbolic procedure b_expand(u,v)$
(if !*debug_times then !*basis else !*basis := x
) where x = b_expand1(cadr u,cadr v,!*basis,!*basis)$
symbolic procedure b_expand1(t1,t2,bs,bs1)$ % Jul 13, 1994
% t1,t2 - (th . pv)
% bs,bs1(r.v.) - (b1 b2 ...) where b::=(th . (pv1 pv2 ...))
if null bs then reversip bs1
else if th_match0(car t1,caar bs)
then b_expand1(t1,t2,cdr bs,b_expand2(car bs,t2,bs1))
else if th_match0(car t2,caar bs)
then b_expand1(t1,t2,cdr bs,b_expand2(car bs,t1,bs1))
else b_expand1(t1,t2,cdr bs,bs1)$
symbolic procedure b_expand2(b,t1,bs)$
% t1 - (th . pv)
% b - (th . (pv1 pv2 ...))
% bs(r.v.) - (b1 b2 ...)
% b_expand2a(car b,cdr b,t1,nil,bs)$
b_expand2b(car b,cdr b,t1,bs)$
symbolic procedure b_expand2b(th,b,t1,bs)$
% t1 - (th . pv)
% b - (th . (pv1 pv2 ...))
% bs(r.v.) - (b1 b2 ...)
if null b then bs
else b_expand2b(th
,cdr b
,t1
,tsym2(list t_prod(th . car b,t1),bs,nil)
)$
symbolic procedure b_expand2a(th,b,t1,b1,bs)$
% t1 - (th . pv)
% b - (th . (pv1 pv2 ...))
% bs(r.v.) - (b1 b2 ...)
if null b then b_join(caar b1 . b_expand3(b1,nil),bs)
else b_expand2a(th,cdr b,t1,t_prod(th . car b,t1) . b1,bs)$
symbolic procedure b_expand3(b,b1)$
if null b then b1
else b_expand3(cdr b,cdar b . b1)$
symbolic procedure b_join(b,bs)$ b_join1(b,bs,nil)$
symbolic procedure b_join1(b,bs,bs1)$
if null bs then reversip(if b then b . bs1 else bs1)
else if b and th_match(car b,caar bs)
then b_join1(nil,cdr bs,(car b . b_join2(cdr b,cdar bs)) . bs1)
else b_join1(b,cdr bs,car bs . bs1)$
symbolic procedure b_join2(b1,b2)$
if null b1 then b2
else b_join2(cdr b1,insert_pv(car b1,b2))$
symbolic procedure t_prod(t1,t2)$
% t1,t2 - tensors::=(th . pv)
% r.v. - direct product of t1 and t2
if null ordp(caar t1,caar t2) then t_prod(t2,t1)
else (append(caar t1,caar t2)
. il_join(cadar t1,cadar t2)
. append(cddar t1,cddar t2)
) . cdr pv_times('!:pv . cdr t1,'!:pv . cdr t2)$
symbolic procedure il_join(l1,l2)$
if null l1 then l2
else if memq(car l1,l2) then wi_new(car l1) . il_join(cdr l1,l2)
else car l1 . il_join(cdr l1,l2)$
global '(wi_number)$
wi_number:=0$
symbolic procedure wi_new(x)$
begin scalar z$
wi_number := wi_number + 1$
z := intern mkid('!:,wi_number)$ %++++++ intern ?!
put(z,'windex,list x)$
return z$
end$
endmodule;
end;