Artifact fc9691d103f30cdb84ef5c731561423283714e7234f18ded255eaae319402cb6:
- Executable file
r37/packages/atensor/dummy2.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: 7034) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/atensor/dummy2.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: 7034) [annotate] [blame] [check-ins using]
%====================================================== % Name: dummy2.red - dummy indices package % Author: A.Kryukov (kryukov@npi.msu.su) % Copyright: (C), 1993, A.Kryukov %------------------------------------------------------ % Version: 2.34 % Release: Dec. 15, 1993 % Mar. 24, 1996 mk_ddsym1 %====================================================== module dummy2$ global '(!*basis); fluid '(!*debug)$ symbolic procedure adddummy(tt)$ % tt - tensor::=(!:tensor . ((th1 . pv1) ...))) % (r.v.) - basis::=((th1 . (pv1 pv2 ...)) ...) adddummy0(cdr tt,!*basis)$ symbolic procedure adddummy0(tt,b)$ % tt - ((th1 . pv1) ...) % b(r.v.) - basis::=((th1 . (pv1 pv2 ...)) ...) if null tt then reversip b else adddummy0(cdr tt,adddummy0b(mk_dsym0 car tt,b))$ symbolic procedure adddummy0b(u,b)$ % u - (th . (pv1 pv2 ...)) %b,b1(r.v.) - basis if null cdr u then b else adddummy0b(car u . cddr u,adddummy0a(car u . cadr u,b,nil))$ symbolic procedure adddummy0a(t1,b,b1)$ % t1 - (th . pv) % b,b1(r.v.) - basis::=((th1 . (pv1 pv2 ...)) ...) if null b then if null t1 then reversip b1 else reversip(adddummy1(t1 ,gperm length cadar t1 ,nil ) . b1 ) else if null t1 then adddummy0a(nil,cdr b,car b . b1) % else if th_match(car t1,caar b) then adddummy0a(nil,b,b1) else if th_match0(car t1,caar b) then adddummy0a(nil,cdr b,adddummy1(t1 ,gperm length cadar t1 ,car t1 . cdar b ) . b1 ) else adddummy0a(t1,cdr b,car b . b1)$ symbolic procedure adddummy1(t1,plist,b)$ << if !*debug then << terpri()$ write " DEBUG: adddummy1"$ terpri()$ t_pri1('!:tensor . list(t1),t)$ terpri()$ for each z in cdr x do t_pri1('!:tensor . list(car x . z),t)$ write " DEBUG=",length cdr x$ terpri()$ >>$ x >> where x=adddummy1a(t1,plist,b)$ symbolic procedure adddummy1a(t1,plist,b)$ % t1 - (th . pv) % plist - (p1 p2 ...) % b,w(r.v.) - (th1 . (pv1 pv2 ...)) if null plist then b else adddummy1a(t1 ,cdr plist ,(if null b then car t1 else car b) . insert_pv(pappl_pv(car plist,cdr t1) ,if null b then b else cdr b ) )$ symbolic procedure mk_dsym0 t1$ car t1 . append(cdr mk_dsym t1,cdr mk_ddsym t1)$ symbolic procedure mk_dsym(t1)$ % t1 - (th . pv) car t1 . mk_dsym1(cdr t1 ,nil ,mk_flips(cadar t1,dl_get cadar t1,nil) )$ symbolic procedure mk_dsym1(pv1,pv2,fs)$ % pv1,pv2(r.v.) - pvector % fs - permutation list if null fs then pv2 else mk_dsym1(pv1 ,pv_add(pv1,pv_neg pv_applp(pv1,car fs)) . pv2 % ,pv_add(pv1,pv_neg pappl_pv(car fs,pv1)) . pv2 ,cdr fs )$ symbolic procedure dl_get(il)$ dl_get2(il,nil)$ symbolic procedure dl_get2(il,d_alst)$ if null il then d_alst else if get(car il,'dummy) then dl_get2(cdr il,di_insert(car il,d_alst,nil)) else dl_get2(cdr il,d_alst)$ symbolic procedure eqdummy(x,y)$ x and car get(x,'dummy) eq car get(y,'dummy)$ symbolic procedure di_insert(di,d_alst1,d_alst2)$ if null d_alst1 then if di then ((di . nil) . d_alst2) else d_alst2 else if eqdummy(di,caar d_alst1) then di_insert(nil,cdr d_alst1,(caar d_alst1 . di) . d_alst2) else di_insert(di,cdr d_alst1,car d_alst1 . d_alst2)$ symbolic procedure il_update(il,d_alst)$ il_update1(il,d_alst,nil)$ symbolic procedure il_update1(il,d_alst,il1)$ if null il then reversip il1 else ((if null y then il_update1(cdr il,d_alst,car il . il1) else ((if x then il_update1(cdr il,delete(x,d_alst),cdr x . il1) else begin scalar z,u$ z:=di_next(d_alst)$ u:=car z$ rplaca(z,y)$ return il_update1(cdr il,d_alst,u . il1 )$ end ) where x=assoc(y,d_alst) ) ) where y=get(car il,'dummy) )$ symbolic procedure di_next(dl)$ if null dl then rederr list('di_next,"+++ Can't find next dummy") else if get(caar dl,'dummy) then car dl else di_next(cdr dl)$ symbolic procedure mk_flips(il,dl,fs)$ if null dl then reversip fs else mk_flips(il,cdr dl,mk_flip(il,car dl) . fs)$ symbolic procedure mk_flip(il,x)$ pfind(il,mk_flip1(il,x,nil))$ symbolic procedure mk_flip1(il,x,w)$ if null il then reverse w else if car x eq car il then mk_flip1(cdr il,(cdr x . car x),cdr x . w) else mk_flip1(cdr il,x,car il . w)$ symbolic procedure mk_flip_(il,di)$ begin scalar il1,il2,w,w1,ok,x$ w:=il$ while w and null ok do if null car w eq caar di then << il1:=car w . il1$ w:=cdr w >> else ok:=t$ if null w then rederr 1; il1:=car w . il1$ il2:=il1$ w:=cdr w$ ok:=nil$ while w do if null car w eq cdar di then << il2:=car w . il2$ w:=cdr w >> else ok:=t$ if null w then rederr 2; il2:=car w . il2$ w:=cdr w$ w1:=il2$ while w do << w1:=car w . w1$ w:=cdr w >>$ x:=car il1$ rplaca(il1,car il2)$ rplaca(il2,x)$ return pfind(il,reversip w)$ end$ %++++++++++++++++++++++++++++++++++ symbolic procedure mk_ddsym(t1)$ % t1 - (th . pv) % r.v. - (th . (pv1 pv2 ...)) car t1 . mk_ddsym1(cdr t1 ,nil ,mk_fflips(cadar t1,dl_get cadar t1,nil) )$ symbolic procedure mk_ddsym1(pv,pvs,fs)$ if null fs then pvs else mk_ddsym1(pv % ,pv_add(pv,pv_neg pappl_pv(car fs,pv)) . pvs % -A.K. 24.03.96 ,pv_add(pv,pv_neg pv_applp(pv,car fs)) . pvs % +A.K. 24.03.96 ,cdr fs )$ symbolic procedure mk_fflips(il,dl,fs)$ if null dl then fs else mk_fflips(il,cdr dl,mk_fflips1(il,car dl,cdr dl,fs))$ symbolic procedure mk_fflips1(il,dp,dl,fs)$ if null dl then fs else mk_fflips1(il,dp,cdr dl,mk_fflip1(il,dp,car dl) . fs)$ symbolic procedure mk_fflip1(il,dp1,dp2)$ pfind(il,mk_fflip2(il,dp1,dp2,nil))$ symbolic procedure mk_fflip2(il,dp1,dp2,il1)$ % dp1,dp2 - (di1 . di2) - contracted indecies if null il then reverse il1 else ((if null(x=get(car dp1,'dummy)) and null(x=get(car dp2,'dummy)) then mk_fflip2(cdr il,dp1,dp2,car il . il1) else if x=get(car dp2,'dummy) then mk_fflip2(il,dp2,dp1,il1) else mk_fflip2(cdr il,dp1,cdr dp2 . car dp2,car dp2 . il1) ) where x=get(car il,'dummy) )$ endmodule; end;