Artifact 12b58c444b8639216158188f70208358365abbde484001baca1b0125307e85a2:
- Executable file
r37/packages/hephys/intfierz.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: 6135) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/hephys/intfierz.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: 6135) [annotate] [blame] [check-ins using]
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;