Artifact bd0fbf382d6c9b84321a73e4b2412fb0c7c561a0759a1ddb3caa780c1f906e71:
- Executable file
r37/packages/atensor/tensor1.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: 9683) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/atensor/tensor1.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: 9683) [annotate] [blame] [check-ins using]
%====================================================== % 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;