module intfierz; % Interface with Rodionov-Fierzing Routine.
exports calc_map_tar,calc_den_tar,pre!-calc!-map_ $
imports mk!-numr,map_!-to!-strand $
lisp$
%----------- DELETING VERTS WITH _0'S ------------------------------$
%symbolic procedure sort!-map_(map_,tadepoles,deltas,s)$
%if null map_ then list(s,tadepoles,deltas)
%else
% begin
% scalar vert,edges$
% vert:=incident1('!_0,car map_,'ll)$
% return
% if null vert then sort!-map_(cdr map_,tadepoles,deltas,
% car map_ . s)
% else if car vert = cadr vert then
% sort!-map_(cdr map_,caar vert . tadepoles,deltas,s)
% else sort!-map_(cdr map_,tadepoles,list('cons,caar vert,
% caadr vert) . deltas,s)
% end$
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%% modified 17.09.90 A.Taranov %%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
symbolic procedure sort!-map_(map_,tadepoles,deltas,poles,s)$
% tadepoles are verts with 1 0_ edge and contracted others
% deltas are verts with 1 0_ edge
% poles are verts with at list 2 0_ edges
if null map_ then list(s,tadepoles,deltas,poles)
else
begin
scalar vert,tdp$
vert:=incident1('!_0,car map_,'ll)$
if null vert then tdp:=tadepolep car map_
else %%%% vertex contain !_0 edge
return
if (caar vert = '!_0) then
sort!-map_(cdr map_,tadepoles,deltas,caadr vert . poles,s)
else if (caadr vert = '!_0) then
sort!-map_(cdr map_,tadepoles,deltas,caar vert . poles,s)
else if car vert = cadr vert then
sort!-map_(cdr map_,caar vert . tadepoles,deltas,
poles,s)
else sort!-map_(cdr map_,tadepoles,list('cons,
caar vert,caadr vert) . deltas,poles,
s)$
%%%%% here car Map_ was checked to be a real tadpole
return
if null tdp then sort!-map_(cdr map_,tadepoles,deltas,
poles,car map_ . s)
else sort!-map_(cdr map_,cadr tdp . tadepoles,deltas,
caar tdp . poles,s)
end$
symbolic procedure tadepolep vrt; %%%%%% 17.09.90
% return edge1 . edge2 if vrt is tadpole,
% NIL otherwise.
% edge1 correspond to 'pole', edge2 - to 'loop' of a tadpole.
if car vrt = cadr vrt then caddr vrt . car vrt
else if car vrt = caddr vrt then cadr vrt . car vrt
else if cadr vrt = caddr vrt then car vrt . cadr vrt
else nil;
symbolic procedure del!-tades(tades,edges)$
if null tades then edges
else del!-tades(cdr tades,delete(car tades,edges))$
symbolic procedure del!-deltas(deltas,edges)$
if null cdr deltas then edges
else del!-deltas(cdr deltas,del!-tades(cdar deltas,edges))$
%--------------- EVALUATING MAP_S -----------------------------------$
symbolic procedure pre!-calc!-map_(map_,edges)$
% : (STRAND NEWMAP_ TADEPOLES DELTAS)$
begin
scalar strand,w$
w:=sort!-map_(map_,nil,list 1,nil,nil)$
% delete from edge list deltas,poles and tades
edges:=del!-deltas(caddr w,
del!-tades(cadr w,delete('!_0,edges)))$
strand:= if car w then map_!-to!-strand(edges,car w)
else nil$
return strand . w
end$
symbolic procedure calc_map_tar(gstrand,alst)$
% THIRD VERSION.$
begin
scalar poles,edges,strand,deltas,tades,map_$
strand:=car gstrand$
map_:=cadr gstrand$
tades:=caddr gstrand $
deltas:=car cdddr gstrand $
poles:= car cddddr gstrand $
if ev!-poles(poles,alst) then return 0; %%%%% result is zero
return constimes list(constimes deltas,
constimes ev!-tades(tades,alst),
(if null map_ then 1
else strand!-alg!-top(strand,map_,alst)))
end$
symbolic procedure ev!-poles(poles,alst)$ %%% 10.09.90
if null poles then nil
else if getedge(car poles,alst) = 0 then ev!-poles(cdr poles,alst)
else poles$
symbolic procedure ev!-deltas(deltas)$
if null deltas then list 1
else ('cons . car deltas) . ev!-deltas(cdr deltas)$
symbolic procedure ev!-tades(tades,alst)$
if null tades then list 1
else binc(ndim!*,getedge(car tades,alst))
. ev!-tades(cdr tades,alst)$
%------------------------ DENOMINATOR CALCULATION -------------------$
symbolic procedure ev!-edgeloop(edge,alst)$
% EVALUATES LOOP OF 'EDGE' COLORED VIA 'ALST'$
binc(ndim!*,getedge(s!-edge!-name edge,alst) )$
symbolic procedure ev!-denom2(vert,alst)$
% EVALUATES DENOM FOR PROPAGATOR$
ev!-edgeloop(car vert,alst)$
symbolic procedure ev!-denom3(vert,alst)$
% EVALUATES DENOM FOR 3 - VERTEX$
begin
scalar e1,e2,e3,lines,sign,!3j,numr$
e1:=getedge(s!-edge!-name car vert,alst)$
e2:=getedge(s!-edge!-name cadr vert,alst)$
e3:=getedge(s!-edge!-name caddr vert,alst)$
lines:=(e1+e2+e3)/2$
e1:=lines-e1$
e2:=lines-e2$
e3:=lines-e3$
sign:=(-1)**(e1*e2+e1*e3+e2*e3)$
numr:=mk!-numr(ndim!*,0,lines)$
numr:=(if numr then (constimes numr)
else 1)$
!3j:=listquotient(numr,
factorial(e1)*factorial(e2)*factorial(e3)*sign)$
return !3j
end$
symbolic procedure binc(n,p)$
% BINOMIAL COEFF C(N,P)$
if 0 = p then 1 else
listquotient(constimes mk!-numr(n,0,p),factorial p)$
symbolic procedure calc_den_tar(den_,alst)$
(lambda u$ if null u then 1
else if null cdr u then car u
else constimes u )
denlist(den_,alst)$
symbolic procedure denlist(den_,alst)$
if null den_ then nil
else if length car den_ = 2 then
ev!-denom2(car den_,alst) . denlist(cdr den_,alst)
else ev!-denom3(car den_,alst) . denlist(cdr den_,alst)$
endmodule;
end;