Artifact f127e239925e28d365f653c0e14db4b5c01570c09b3bc7119b3ecd43d16f7ffd:
- Executable file
r37/packages/atensor/tensor.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: 12371) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/atensor/tensor.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: 12371) [annotate] [blame] [check-ins using]
%====================================================== % Name: tensor - tensor arithmetics % Author: A.Kryukov (kryukov@npi.msu.su) % Copyright: (C), 1993-1996, A.Kryukov % Version: 2.02 28/03/96 %------------------------------------------------------ % Release: Nov. 13, 1993 th_match, th_match1 % Jul. 13, 1994 symmetry generated by multiplication. % Mar. 28, 1996 t_gcd, t_prep, t_times4 %====================================================== module tensor$ fluid '(!*debug)$ switch debug$ %================================================= % tensor::=(!:tensor . ((th1 . pv1) (th2 . pv2) ...)) % th::=(tn . il . dl) % tn::=(id1 id2 ...) %================================================== global '(!*basis)$ symbolic procedure t_simp v$ begin scalar x; if !*debug then << terpri()$ print list('t_simp . v) >>$ if (x:=get(car v,'!:tensor))=99 then put(car v,'!:tensor,length cdr v) else if null(x = length cdr v) then rederr list('t_simp,"*** Invalid number of indices:",v)$ % v:='!:tensor . list((list car v . il_simp cdr v . nil) % -AK 28/03/96 v:='!:tensor . list((list car v . il_simp cdr v . 1) % +AK 28/03/96 . list(1 . mkunitp length cdr v) )$ return (((if cdr z then z else nil) where z=sieve_t(v,!*basis)) ./ 1 )$ end$ global '(domainlist!*)$ switch tensor$ domainlist!*:=union('(!:tensor),domainlist!*)$ put('tensor,'tag,'!:tensor)$ put('!:tensor,'dname,'tensor)$ %flag('(!:tensor),'field)$ % !:tensor is not a field! put('!:tensor,'minus,'t_minus)$ put('!:tensor,'minusp,'t_minusp)$ put('!:tensor,'plus,'t_plus)$ put('!:tensor,'times,'t_times)$ % v*c put('!:tensor,'difference,'t_difference)$ put('!:tensor,'zerop,'t_zerop)$ put('!:tensor,'onep,'t_onep)$ put('!:tensor,'prepfn,'t_prep)$ put('!:tensor,'prifn,'t_pri)$ put('!:tensor,'intequivfn,'t_intequiv)$ put('!:tensor,'i2d,'i2tensor)$ put('!:tensor,'expt,'t_expt)$ put('!:tensor,'quotient,'t_quotient)$ put('!:tensor,'divide,'t_divide)$ put('!:tensor,'gcd,'t_gcd)$ flag('(!:tensor),'tmode)$ symbolic procedure t_minus u$ if atom cdr u then -cdr u else sieve_t(car u . t_minus1(cdr u,nil),!*basis)$ symbolic procedure t_minus1(u,v)$ if null u then reversip v else t_minus1(cdr u,(caar u . pv_neg cdar u) . v)$ symbolic procedure t_minusp u$ nil$ symbolic procedure t_plus(u,v)$ if atom cdr u then rederr list('t_plus,"*** Tensor can't be added to:",cdr u) else if atom cdr v then t_plus(v,u) else sieve_t(car u . t_plus1(cdr u,cdr v),!*basis)$ symbolic procedure t_plus1(u,v)$ if null u then v else if null v then u else t_plus1(cdr u,t_plus2(car u,v,nil))$ symbolic procedure t_plus2(x,v,w)$ if null v then reversip(x . w) else if th_match(car x,caar v) then append(cdr v, reversip(t_add2(x,car v) . w)) else t_plus2(x,cdr v, car v . w)$ symbolic procedure t_times(u,v)$ % u,v - tensor::=(!:tensor . tlist) if t_intequiv u then t_times(v,u) else if atom cdr v then car u . t_timesc(cdr u,cdr v,nil) else (sieve_t(x,!*basis) where x=car u . t_times1(cdr u,cdr v,nil) % ,y=b_expand(u,v) )$ symbolic procedure t_timesc(tt,c,w)$ % tt,w - tlist::=((th1 . pv1) ...) % c - integer if null tt then reversip w else t_timesc(cdr tt ,c ,(caar tt . pv_multc(cdar tt,c)) . w )$ symbolic procedure t_times1(u,v,w)$ % u,v,w - tlist::=((th1 . pv1) ...) if null u then reversip w else t_times1(cdr u,v,t_times2(v,car u,w))$ symbolic procedure t_times2(v,x,w)$ % u,w - tlist::=((th1 . pv1) ...) % x - (th . pv) if null v then w % else t_times2(cdr v,x,t_plus2(t_times3(car v,x),w,nil))$ else t_times2(cdr v,x,t_plus2(t_times4(car v,x),w,nil))$ symbolic procedure t_times3(y,x)$ % x,y - (th . pv) if null ordp(caar y,caar x) then t_times3(x,y) else (append(caar y,caar x) . il_simp append(cadar y,cadar x) . append(cddar y,cddar x) ) . cdr pv_times('!:pv . cdr y,'!:pv . cdr x)$ symbolic procedure t_times4(x,y)$ % mod. AK 28/03/96 % x,y - (th . pv) % return product of x by y. % side effect: the !*basis will be updated by symmetry properties % generate by multiplication. begin scalar tf1,tf2,z,den$ den := cddar x * cddar y$ % + AK 28/03/96 tf1 := t_split(x)$ tf2 := t_split(y)$ z := t_fuse(tf1,tf2)$ rplacd(cdar z,den)$ % + AK 28/03/96 return z$ end$ symbolic procedure t_split(x)$ % x - (th . pv) % r.v. - list of tensor factors: (tf1 ...) % where tf - (th . pv) and th is a simple tname, i.e. (id) if null cdaar x then list x else (t_split1(caar x,pappl(p,cadar x) ,unpkpv pappl_pv(p,cdr x),nil ) where p = prev(cdadr x) )$ symbolic procedure t_split1(tn,il,pv,tfl)$ % tfl (r.v.) - list of tfactors. if null tn then reversip tfl else if cdr pv then rederr list('t_split1,": too long pvector ",pv) else ( (t_split1(cdr tn,cdr ils,list(caar pv . cdr pvs), ((list car tn . list car ils) . list(1 . p_rescale car pvs) ) . tfl ) where ils = l_split(il,n,nil), pvs = l_split(cdar pv,n,nil) ) where n = get(car tn,'!:tensor) )$ symbolic procedure pv_rescale(pv)$ pv_rescale1(pv,nil)$ symbolic procedure pv_rescale1(pv,pv1)$ if null pv then reversip pv1 else pv_rescale1(cdr pv,(caar pv . p_rescale cdar pv). pv1)$ symbolic procedure p_rescale p$ (for each x in p collect (x-n)) where n = car p - 1$ symbolic procedure l_split(lst,n,lst1)$ % Split list lst into two lists where first one contain n items. % (r.v.) - (lst1 . lst_rest) if n<=0 then (reversip lst1) . lst else l_split(cdr lst,n-1,car lst . lst1)$ symbolic procedure unpkpv(pv)$ unpkpv1(pv,nil)$ symbolic procedure unpkpv1(pv,upv)$ if null pv then reversip upv else unpkpv1(cdr pv,(caar pv . unpkp cdar pv) . upv)$ symbolic procedure t_fuse(tf1,tf2)$ % tf1, tf2 - list of tensor factors % r.v. - the result of "multiplication" of them with order. t_fuse1(reversip tf1,reversip tf2,nil)$ symbolic procedure t_fuse1(tf1,tf2,tf3)$ % r.v. - tf3 - total ordered tensor factor list. (if null tf1 then t_fuse2(reversip append(reversip tf2,tf3),nil) else if null tf2 then t_fuse2(reversip append(reversip tf1,tf3),nil) else if null ordp(caaar tf1,caaar tf2) then t_fuse1(cdr tf1,tf2,car tf1 . tf3) else t_fuse1(tf1,cdr tf2,car tf2 . tf3) ) % where x=if tf1 and tf3 and caaar tf1 = caaar tf3 % then addmultsym(car tf1,car tf3) % else if tf2 and tf3 and caaar tf2 = caaar tf3 % then addmultsym(car tf2,car tf3) % else if tf3 % then !*basis:=b_expand1(if tf1 then car tf1 else car tf2 % ,car tf3,!*basis,!*basis % ) % else nil $ symbolic procedure t_fuse2(tf,te)$ if null tf then te else t_fuse2(cdr tf,t_fuse3(car tf,te))$ symbolic procedure t_fuse3(t1,t2)$ % t1,t2 - tensors % r.v. - it's product. % side effect: !*basis will be updated. if null t2 then pkt t1 else if null caar t1 then pkt t2 else ((( ((caaar t1 . caar t2) .il_simp append(cadar t1,cadar t2) .nil ) . cdr pv_times('!:pv . cdr t1,'!:pv . cdr t2) ) where x=addmultsym(t1,t2) ) where zz = b_expand(list('!:tensor,t1),list('!:tensor,t2)) % Aug. 06, 1994 )$ symbolic procedure addmultsym(t1,t2)$ % AK, Nov. 20, 1994 addmsym(t1,t2,caar t1,caar t2)$ symbolic procedure addmsym(t1,t2,k1,k2)$ % t1,t2 - tensors the product of them generate new symmtries. % k1,k2 - current name of t1,t2. if null k2 then !*basis:=b_expand1(t1,t2,!*basis,!*basis) else if null k1 then addmsym(t1,t2,caar t1,cdr k2) else if null(car k1 eq car k2) then addmsym(t1,t2,cdr k1,k2) else (addmsym(t1,t2,cdr k1,k2) where zz:=addmsym0(t1,t2,msymperm0(car t1,car t2,k1,k2)) )$ symbolic procedure addmsym0(t1,t2,pz)$ (addmultsym1(th . cdr pv_difference(z,'!:pv . pappl_pv(car pz,cdr z))) )where th = ((caaar t1 . caar t2) . cdr pz . nil), z = pv_times('!:pv . cdr t1,'!:pv . cdr t2)$ symbolic procedure msymperm0(th1,th2,k1,k2)$ begin scalar il1,il2,n0,nam1,nam2,w1,w2,zl$ nam1:=car th1$ nam2:=car th2$ il1:=cadr th1$ il2:=cadr th2$ n0:=length il1$ il2:=il_simp append(il1,il2)$ zl:=il2$ il1:=nil$ for i:=1:n0 do << il1:=car il2 . il1$ il2:=cdr il2 >>$ il1:=reversip il1$ w1:=nil$ while null(nam1 eq k1) do << n0:=get(car nam1,'!:tensor)$ for i:=1:n0 do << w1:=car il1 . w1$ il1:=cdr il1 >>$ nam1:=cdr nam1$ >>$ w2:=nil$ while null(nam2 eq k2) do << n0:=get(car nam2,'!:tensor)$ for i:=1:n0 do << w2:=car il2 . w2$ il2:=cdr il2 >>$ nam2:=cdr nam2$ >>$ n0:=get(car nam1,'!:tensor)$ for i:=1:n0 do << w1:=car il2 . w1$ w2:=car il1 . w2$ il1:=cdr il1$ il2:=cdr il2$ >>$ w1:=append(reversip w1,il1)$ w2:=append(reversip w2,il2)$ return pfind(append(w1,w2),zl) . zl$ end$ symbolic procedure addmultsym_(t1,t2)$ nil$ symbolic procedure addmultsym__(t1,t2)$ if caaar t1 neq caaar t2 then !*basis:=b_expand1(t1,t2,!*basis,!*basis) else((addmultsym1(th . cdr pv_difference(z,'!:pv . pappl_pv(car pz,cdr z))) )where th = ((caaar t1 . caar t2) . cdr pz . nil), z = pv_times('!:pv . cdr t1,'!:pv . cdr t2) )where pz = msymperm(cadar t1,cadar t2) % ,zz = b_expand1(t1,t2,!*basis,!*basis) % Aug. 06, 1994 $ symbolic procedure msymperm(il1,il2)$ begin scalar zl,w,k; k:=length il1; zl:=il_simp append(il1,il2)$ il2:=zl; for i:=1:k do << w:=car il2 . w; il2:=cdr il2>>; il1:=reversip w; w:=nil; for i:=1:k do << w:=car il2 . w; il2:=cdr il2>>; w:=reversip w; return pfind(append(w,append(il1,il2)),zl) . zl; end$ symbolic procedure addmultsym2(t1,t2,bs)$ if null bs then nil else if null th_match0(car t2,caar bs) then addmultsym2(t1,t2,cdr bs) else rederr list "b_xpand?"$ symbolic procedure addmultsym1(te)$ !*basis:=tsym2(list te,!*basis,nil)$ symbolic procedure pkt(t1)$ car t1 . pkpv(cdr t1,nil)$ symbolic procedure pkpv(pv,ppv)$ if null pv then reversip ppv else pkpv(cdr pv,(caar pv . pkp cdar pv) . ppv)$ symbolic procedure t_difference(u,v)$ t_plus(u,t_minus v)$ symbolic procedure t_zerop(u)$ null cdr u$ symbolic procedure t_onep u$ cdr u = 1$ symbolic procedure t_prep u$ % mod. AK 28/03/96 (if not(cddr caadr u = 1) then 'quotient . x . list cddr caadr u else x) where x=t_prep1(cdr u,nil)$ symbolic procedure t_prep1(u,v)$ if null u then if null v then nil else if cdr v then 'plus . reversip v else car v else t_prep1(cdr u,th2pe(caar u,cdar u) . v)$ %symbolic procedure t_prep u$ th2pe(cadr u,cddr u)$ symbolic procedure t_pri(u)$ t_pri1(u,nil)$ symbolic procedure t_intequiv u$ atom cdr u$ symbolic procedure i2tensor n$ '!:tensor . n$ symbolic procedure t_expt(u,n)$ if n=1 then u else if atom cdr u then cdr u^n else rederr list('t_expt,"*** Can't powered tensor")$ symbolic procedure t_quotient(u,c)$ if t_intequiv c and cdr c = 1 then u else rederr list('t_quotient,"*** Tensor can't be divided by: ",c)$ symbolic procedure t_divide(u,v)$ rederr list('t_divide,"*** Can't divide tensor by tensor")$ symbolic procedure t_gcd(u,v)$ % AK 28/03/96 if atom cdr v then 1 else rederr list('t_gcd,"*** Can't find gcd of two tensors")$ initdmode 'tensor$ endmodule; end;