reduce-historical/r38/packages/hephys/evalmaps.red

module evalmaps;  % Interaction with alg mode: variant without nonlocs;

  exports    strand!-alg!-top $
  imports    color!-strand,contract!-strand $

%------------------ AUXILIARY ROUTINES -----------------------------$

symbolic procedure permpl(u,v)$
if null u then t
else if car u = car v then permpl(cdr u,cdr v)
     else not permpl(cdr u,l!-subst1(car v,car u,cdr v))$

symbolic procedure repeatsp u$
if null u then nil
else (member(car u,cdr u) or repeatsp cdr u )$

symbolic procedure l!-subst1(new,old,l)$
if null l then nil
else if old = car l then new . cdr l
     else (car l) . l!-subst1(new,old,cdr l)$

%-------------------FORMING ANTISYMMETRIHERS -----------------------$

symbolic procedure propagator(u,v)$
if null u then      1
else if (repeatsp u) or (repeatsp v) then 0
     else 'plus . propag(u,permutations v,v)$

symbolic procedure propag(u,l,v)$
if null l then      nil
else (if permpl(v,car l) then 'times . prpg(u,car l)
      else list('minus,'times . prpg(u,car l) ) ) . propag(u,cdr l,v)$

symbolic procedure prpg(u,v)$
if null u then nil
else list('cons,car u,car v) . prpg(cdr u,cdr v)$

symbolic procedure line(x,y)$
propagator(cdr x,cdr y)$

%------------------ INTERFACE  WITH CVIT3 ---------------------------$

symbolic procedure strand!-alg!-top(strand,map_,edlst)$
begin
  scalar rlst$
      strand:=deletez1(strand,edlst)$
      rlst:=color!-strand(edlst,map_,1)$
      strand:=contract!-strand(strand,rlst) $
 %RINT STRAND$ TERPRI()$
 %RINT RLST$ TERPRI()$
 %RINT EDLST$ TERPRI()$
 return dstr!-to!-alg(strand,rlst,nil)
%ATHPRINT REVAL(W)$ RETURN W
end$


symbolic procedure mktails(side,rlst,dump)$
begin
  scalar pntr,newdump,w,z$
    if null side then return nil . dump$
    pntr:=side$
    newdump:=dump$
 while pntr do  <<  w:=mktails1(car pntr,rlst,newdump)$
                    newdump:=cdr w$
                    z:=sappend(car w,z)$
                    pntr:=cdr pntr >>$
    return z . newdump
end$

symbolic procedure mktails1(rname,rlst,dump)$
begin
 scalar color,prename,z$
       color:=getroad(rname,rlst)$
     if 0 = color then return nil . dump$
     if 0 = cdr rname then
      return (list replace_by_vector car rname) . dump$
 %   IF FREEIND CAR RNAME THEN RETURN (LIST CAR RNAME) . DUMP$
       z:=assoc(rname,dump)$
     if z then return
                if null cddr z then  cdr z . dump
                else (sreverse cdr z) . dump$
  %    PRENAME:=APPEND(EXPLODE CAR RNAME,EXPLODE CDR RNAME)$
       prename:=rname$
       z:= mkinds(prename,color)$
   return z . ((rname . z) . dump)
end$

symbolic procedure mkinds(prename,color)$
if color = 0 then nil
else
     begin
         scalar indx$
    %     INDX:=INTERN COMPRESS APPEND(PRENAME,EXPLODE COLOR)$
          indx:=                       prename . color $
       return indx . mkinds(prename,sub1 color)
     end$

symbolic procedure getroad(rname,rlst)$
if null rlst then 1 % ******EXT LEG IS ALWAYS SUPPOSET TO BE SIMPLE $
else if cdr rname = cdar rlst then
	      cdr qassoc(car rname,caar rlst)
     else getroad(rname,cdr rlst) $


symbolic procedure qassoc(atm,alst)$
if null alst then nil
else if eq(atm,caar alst) then car alst
     else qassoc(atm,cdr alst)$

%------------- INTERACTION WITH RODIONOV ---------------------------$

symbolic procedure from!-rodionov x$
begin scalar strand,edges,edgelsts,map_,w$
    edges:=car x$
    map_:=cadr x$
    edgelsts:=cddr x$
    strand := map_!-to!-strand(edges,map_)$
    w:= for each edlst in edgelsts collect
	     strand!-alg!-top(strand,map_,edlst)$
    return reval('plus . w )
end$

symbolic procedure top1 x$
mathprint from!-rodionov to_taranov x$

%----------------------- COMBINATORIAL COEFFITIENTS -----------------$

symbolic procedure f!^(n,m)$
if n<m then cviterr "Incorrect args of f!^"
else if n = m then 1
     else n*f!^(sub1 n,m)$

%% This exists in basic REDUCE these days -- JPff
%%symbolic procedure factorial n$
%%f!^(n,0)$

symbolic procedure mk!-coeff1(alist,rlst)$
if null alist then 1
else
   eval ('times .
   for each x in alist collect factorial getroad(car x,rlst) )$

%--------------- CONTRACTION OF DELTA'S -----------------------------$

symbolic procedure prop!-simp(l1,l2)$
prop!-simp1(l1,l2,nil,0,1)$

symbolic procedure prop!-simp1(l1,l2,s,lngth,sgn)$
if null l2 then list(lngth,sgn) . (l1 . sreverse s)
else
 (lambda z$ if null z then
			  prop!-simp1(l1,cdr l2,car l2 . s,lngth,sgn)
	    else prop!-simp1(cdr z,cdr l2,s,add1 lngth,
         (car z)*sgn*(-1)**(length s)) )
      prop!-simp2(l1,car l2)$

symbolic procedure prop!-simp2(l,ind)$
begin
  scalar sign$
if sign:=index!-in(ind,l) then
      return ((-1)**(length(l)-length(sign))) . delete(ind,l)
 else return nil
end$

symbolic procedure mk!-contract!-coeff u$
if caar u = 0 then 1
else
    begin
      scalar numr,denr,pk,k$
              pk:=caar u$
               k:=length cadr u$
              numr:=constimes ((cadar u) .mk!-numr(ndim!*,k,k+pk))$
       %      denr:=f!^(pk+k,k)*(cadar u)$
         return                numr
    end$

symbolic procedure mk!-numr(n,k,p)$
if k=p then nil
else (if k=0 then n else list('difference,n,k)) . mk!-numr(n,add1 k,p)$

symbolic procedure mod!-index(term,dump)$
%-------------------------------------------------------------------
% MODYFIES INDECES OF "DUMP" VIA DELTAS IN "TERM"
% DELETES UTILIZED DELTAS FROM "TERM"
% RETURNS "TERM" . "DUMP"
%------------------------------------------------------------------$
begin
  scalar coeff,sign$
      coeff:=list 1$
      term:= if sign:= eq(car term,'minus) then cdadr term
             else cdr term$
  while term do << if free car term       then
                                coeff:=(car term) . coeff
                   else dump:=mod!-dump(cdar term,dump)$
                   term:=cdr term                         >>$
  return
       ( if sign then
              if null cdr coeff then (-1)
              else 'minus . list(constimes coeff)
        else if null cdr coeff then 1
             else constimes coeff ) . dump
end$

symbolic procedure dpropagator(l1,l2,dump)$
(lambda z$
     if z=0       then z
     else if z=1 then nil . dump
          else  for each trm in cdr z collect
                             mod!-index(trm,dump) )
   propagator(l1,l2)$

symbolic procedure dvertex!-to!-projector(svert,rlst,dump)$
begin
  scalar l1,l2,coeff,w$
       l1:=mktails(cadr svert,rlst,dump)$
       if repeatsp car l1 then return 0$
       l2:= mktails(caddr svert,rlst,cdr l1)$
       if repeatsp car l2 then return 0$
       dump:=cdr l2$
       w:=prop!-simp(car l1,sreverse car l2)$
       coeff:=mk!-contract!-coeff w$
 return coeff . dpropagator(cadr w,cddr w,dump)
end$

%SYMBOLIC PROCEDURE DSTR!-TO!-ALG(STRAND,RLST,DUMP)$
%IF NULL STRAND THEN LIST('RECIP,MK!-COEFF1(DUMP,RLST))
%ELSE
%  BEGIN
%    SCALAR VRTX$
%      VRTX:=DVERTEX!-TO!-PROJECTOR(CAR STRAND,RLST,DUMP)$
%      IF 0=VRTX THEN RETURN 0$
%      IF NULL CADR VRTX THEN RETURN
%      LIST('TIMES,CAR VRTX,DSTR!-TO!-ALG(CDR STRAND,RLST,CDDR VRTX))$
%
% RETURN LIST('TIMES,CAR VRTX,
%        'PLUS . (FOR EACH TRM IN CDR VRTX COLLECT
%      LIST('TIMES,CAR TRM,DSTR!-TO!-ALG(CDR STRAND,RLST,CDR TRM))) )

%===MODYFIED 4.07.89

remflag('(dstr!-to!-alg),'lose)$

symbolic procedure dstr!-to!-alg(strand,rlst,dump)$
%IF NULL STRAND THEN LIST('RECIP,MK!-COEFF1(DUMP,RLST))
if null strand then consrecip list(mk!-coeff1(dump,rlst))
else
  begin
    scalar vrtx$
      vrtx:=dvertex!-to!-projector(car strand,rlst,dump)$
      if 0=vrtx then return 0$
      if null cadr vrtx then return
         if 1 = car(vrtx) then
                           dstr!-to!-alg(cdr strand,rlst,cddr vrtx)
         else
           cvitimes2(car vrtx,
                     dstr!-to!-alg(cdr strand,rlst,cddr vrtx))$


      return
        cvitimes2(car vrtx,
                  consplus (for each trm in cdr vrtx collect
                            cvitimes2(car trm,
				      dstr!-to!-alg(cdr strand,rlst,
						    cdr trm))))$
end$

flag('(dstr!-to!-alg),'lose)$

symbolic procedure cvitimes2(x,y)$
if (x=0) or (y=0) then 0
else if x = 1 then y
     else if y = 1 then x
          else list('times,x,y)$


symbolic procedure free dlt$
(freeind cadr dlt) and (freeind caddr dlt)$

symbolic procedure freeind ind$
atom ind $
%       AND
%LAGP(IND,'EXTRNL)$

symbolic procedure mod!-dump(l,dump)$
if not freeind car l then mod!-dump1(cadr l,car l,dump)
else mod!-dump1(car l,cadr l,dump)$

symbolic procedure mod!-dump1(new,old,dump)$
if null dump then nil
else ( (caar dump) . l!-subst(new,old,cdar dump) ) .
                    mod!-dump1(new,old,cdr dump)$

symbolic procedure l!-subst(new,old,l)$
if null l then nil
else if old = car l then new . l!-subst(new,old,cdr l)
     else car l . l!-subst(new,old,cdr l) $

endmodule;

end;