Pensieve header: A full implementation of $gl_n^\epsilon$.

SetDirectory["C:/drorbn/AcademicPensieve/Projects/glneps"];

Conventions

(Subscript[x, α,β]) is always with α<=β and represents a basis element of the upper triangular matrices. (Subscript[y, α,β]) is always with β<=α and represents a basis element of the lower triangular matrices. The adjoint of (Subscript[x, α,β]) is (Subscript[y, β,α]).

Variable declarations:

VarPattern=((y|x|η|ξ)|(Subscript[(y|x|η|ξ), __]))[_];

Greek - Latin duality:

{(SuperStar[y]),(SuperStar[x]),(SuperStar[η]),(SuperStar[ξ])}={η,ξ,y,x}; 
(SuperStar[((Subscript[u_, αβ__]))]):=(Subscript[((SuperStar[u])), αβ]);
(SuperStar[((u:((y|x|η|ξ)|(Subscript[(y|x|η|ξ), __])))[i_])]):=(SuperStar[u])[i];
(SuperStar[(vs_List)]):=(v|->(SuperStar[v]))/@vs;

(SuperStar[{(Subscript[x, 1,2]),(Subscript[y, 2,3]),(Subscript[η, 1,2])[7]}])

Weights:

({{Wt[(Subscript[x, α_,β_])]:={1,α-β};, Wt[(Subscript[y, α_,β_])]:={0,α-β};}, {Wt[(Subscript[ξ, α_,β_])]:={0,β-α};, Wt[(Subscript[η, α_,β_])]:={1,β-α};}});
Wt[u_[_]] := Wt[u];

$k=2;

The Engine

Canonical Forms:

LogReduce[ℰ_]:=ℰ/.c_*Log[a_]:>Log@Factor[(a^c)]//.Log[a_]+Log[b_]:>Log@Factor[a b];
CF[ℰ_] := Expand@Collect[ℰ,Cases[ℰ,VarPattern,∞],CCF]/.CCF->Factor;
CF[ℰ_𝔼]:=CF/@MapAt[LogReduce,ℰ,1];
CF[ℰ:(Subscript[𝔼, __])[___]]:=CF/@ℰ;

𝔼 operations:

ℰ_𝔼[$]:=Length[ℰ]-1; (Subscript[𝔼, _])[ℰs___][$]:=𝔼[ℰs][$];ℰ_𝔼[k_Integer]:=ℰ[[k+1]]; (Subscript[𝔼, _])[ℰs___][k_Integer]:={ℰs}[[k+1]];
𝔼/:ℰ1_𝔼≡ℰ2_𝔼:=Inner[CF@#1==CF@#2&, ℰ1,ℰ2,And];
(Subscript[𝔼, d1_->r1_])[ℰ1s___]≡(Subscript[𝔼, d2_->r2_])[ℰ2s___] ^:= (d1==d2)∧(r1==r2)∧(𝔼[ℰ1s]≡𝔼[ℰ2s]);
𝔼/:ℰ1_𝔼*ℰ2_𝔼:=𝔼@@Table[CF[ℰ1[kk]+ℰ2[kk]],{kk,0,Min[ℰ1[$],ℰ2[$]]}];
(Subscript[𝔼, d1_->r1_])[ℰ1s___](Subscript[𝔼, d2_->r2_])[ℰ2s___] ^:= (Subscript[𝔼, (d1⋃d2)->(r1⋃r2)])@@(𝔼[ℰ1s]𝔼[ℰ2s]);

(Subscript[𝔼, d1_->r1_])[ℰ1s___]//(Subscript[𝔼, d2_->r2_])[ℰ2s___] :=Module[{is=r1⋂d2,lvs,llvs},
lvs=Cases[{ℰ1s},(Subscript[(x|y), __])[i_]/;MemberQ[is,i],∞]⋃(SuperStar[Cases[{ℰ2s},(Subscript[(ξ|η), __])[i_]/;MemberQ[is,i],∞]]);
llvs=Map[$,lvs,{2}];
(Subscript[𝔼, (d1⋃Complement[d2,is])->(r2⋃Complement[r1,is])])@@((Subscript[Zip, llvs⋃(SuperStar[llvs])])[{(SuperStar[(llvs)]).(llvs),Times[
𝔼[ℰ1s]/.Thread[lvs->llvs],
𝔼[ℰ2s]/.Thread[(SuperStar[lvs])->(SuperStar[llvs])]
]}])
]

Zipping! Lemmas 2 and 3 are combined, yet they must be applied first to the middle weight variables and then to the heavy and light variables.

Comment. Zip3 of the outer variables must occur after all other operations are completed, because we must allow for gluings of the weight n variables in perturbations with the weight 0 variables in the coefficients of Q.

dvs stands for “Diagonal Variables”. In (Subscript[gl, n]) they are the (Subscript[x, ii])’s and the (Subscript[y, ii])’s. They have weights {1,0} and {0,0}.

(Subscript[Zip, vs_])[{ℱ_,ℰ_}]:=Module[{dvs=Select[vs,(Wt[#]=={0,0}∨Wt[#]=={1,0})&]},
{ℱ,ℰ}//(Subscript[Zip1, vs])(*//(Subscript[Zip2, Complement[vs,dvs]])*)//(Subscript[Zip2, dvs])//(Subscript[Zip3, Complement[vs,dvs]])//(Subscript[Zip3, dvs])
]//Last

Getting rid of the quadratic.

(Subscript[Zip1, {}])=Identity;
(Subscript[Zip1, vs_])@{ℱ_,𝔼[Q_,P___]} := Module[{ℐ,F,G,u,v},
ℐ=IdentityMatrix@Length@vs;
F=Table[If[Wt[u]+Wt[v]=={1,0},(∂_(u,v))ℱ,0],{u,vs},{v,vs}];
G=Table[If[Wt[u]+Wt[v]=={1,0},(∂_(u,v))Q,0],{u,vs},{v,vs}];
{CF[(vs).(F.Inverse[ℐ-G.F]).(vs)/2], 𝔼[CF[Q-PowerExpand@Log[Det[ℐ- G.F]]/2-vs.G.vs/2],P]}
]

Getting rid of linear terms.

(Subscript[Zip2, {}])=Identity;
(Subscript[Zip2, vs_])@{ℱ_,𝔼[Q_,P___]} := Module[{F,Y,u,v},
F=Table[If[Wt[u]+Wt[v]=={1,0},CF[(∂_(u,v))ℱ],0],{u,vs},{v,vs}];
Y=Table[(∂_v)Q,{v,vs}]/.Table[v->0,{v,vs}];
CF/@{ℱ, 𝔼[Q-Y.vs+Y.F.Y/2, P]/.Thread[vs->vs+F.Y]}
]

Dealing with Feynman diagrams.

Note that the power m of λ is at most k-1+((2k+2)/2)=2k. We write (Subscript[Z, λ])=∑Z[m](λ^m).

(Subscript[Zip3, vs_])@{ℱ_,ℰ_𝔼} := Module[{F,u,v,Z,kk,jj,$m=0,m,n},
Do[Z[0,kk]=ℰ[[kk+1]],{kk,0,ℰ@$}];
F[u_,v_]:=F[u,v]=CF@If[Wt[u]+Wt[v]=={1,0},(∂_(u,v))ℱ,0];
Z[m_,kk_,u_]:=Z[m,kk,u]=(∂_u)Z[m,kk];
Z[m_,kk_,u_,v_]:=Z[m,kk,u,v]=(∂_v)Z[m,kk,u];
For[m=0,m≤2$m,++m,For[kk=0,kk≤ℰ@$,++kk,
Z[m+1,kk]=CF@Sum[
If[F[u,v]===0,0,((F[u,v])/(2(m+1)))(Z[m,kk,u,v]+Sum[Z[n,jj,u]*Z[m-n,kk-jj,v],{n,0,m},{jj,0,kk}])],
{u,vs},{v,vs}];
If[Z[m+1,kk]=!=0, $m=m+1]
]];
CF/@({
ℱ-Sum[F[u,v]*u*v/2,{u,vs},{v,vs}],
𝔼@@Table[Sum[Z[m,kk],{m,0,$m}],{kk,0,ℰ@$}]
}/.Table[v->0,{v,vs}])
]

“Define” Code

SetAttributes[Define, HoldAll];
Define[def_,defs__] := (Define[def]; Define[defs];);
Define[op_[is__]=ℰ_] := Module[{SD,ii,jj,kk,isp,nis,nisp,sis},Block[{i,j,k},
ReleaseHold[Hold[
SD[op[nisp,$k_Integer],Block[{i,j,k},op[isp,$k]=ℰ;op[nis,$k]]];
SD[op[isp],op[{is},$k]];
SD[op[sis__],op[{sis}]];
]/. {SD->SetDelayed,
isp->{is}/.{i->i_,j->j_,k->k_},
nis->{is}/.{i->ii,j->jj,k->kk},
nisp->{is}/.{i->ii_,j->jj_,k->kk_}
}]  ]]

TriangularSolve[eqns_,vars_]:=Module[{sol={},e,v},
MapThread[
{e,v}|->sol=sol⋃First@Solve[e/.sol,v],
Flatten/@{eqns,vars}
];
sol
]

(Subscript[Λ2𝔼, d_->r_])[Λ_]:=(Subscript[Λ2𝔼, d->r])[$k,Λ];
(Subscript[Λ2𝔼, d_->r_])[$k_,Λ_]:=Module[{k},(Subscript[𝔼, d->r])@@Table[SeriesCoefficient[Λ,{ϵ,0,k}],{k,0,$k}]];

The Objects

n=5;
bas=Flatten@Table[(Subscript[x, α,β]),{β,1,n},{α,1,β}]

(Subscript[BaseChange, n_])[b1_->b2_]:=Module[{A,α,β,lhs,rhs,eqns,δα,vars,sol,ζ},
A1=A2=IdentityMatrix[n];
Do[A1=A1.MatrixExp[SparseArray[x1/.(Subscript[x, α_,β_]):>({α,β}->(Subscript[ξ1, α,β])),{n,n}]],{x1,b1}];
Do[A2=A2.MatrixExp[SparseArray[x2/.(Subscript[x, α_,β_]):>({α,β}->(Subscript[ξ2, α,β])),{n,n}]],{x2,b2}];
solSS=Table[(Subscript[ξ2, α,α])->(Subscript[ξ1, α,α]),{α,n}];
eqns=Table[A1[[α,α+δα]]==A2[[α,α+δα]]/.solSS,{δα,1,n-1},{α,1,n-δα}];
vars=Table[(Subscript[ξ2, α,α+δα]),{δα,1,n-1},{α,1,n-δα}];
Join[solSS,Simplify@TriangularSolve[eqns,vars] ]
];

n=10;
bas=Flatten@Table[(Subscript[x, α,β]),{β,1,n},{α,1,β}];
Table[
b1=Permute[bas,RandomPermutation[Length@bas]];
b2=Permute[bas,RandomPermutation[Length@bas]];
{(Subscript[BC, b1->b2]),(Subscript[BaseChange, n])[b1->b2]},
{10}
]//Monitor