reduce-historical/r38/packages/atensor/dummy2.red

%======================================================
%       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;