Tree-level n-pt formula, examples

The following code computes 3-pt and 4-pt functions of single-traces in several ways, 
either by using Wick contractions or by evaluating the fomulae given in the paper.
We do not check the agreement for 2-pt functions, which is straightforward.

Usage:
Put “treepack.m” and “tree3pt4pt.m” in the directorey same as this one. Evaluate the cells from top to bottom. 
One can change the operator lengths in “Input” subsections.

Initialization

SetDirectory[NotebookDirectory[]];
(* definitions *)
<<"treepack.m" 
(* data from Wick contractions *)
<<"tree3pt4pt.m"

(* Parallelize in order to accelerate some of the computations;
   we used 6 CPU, intel Core i9 at 2.9 GHz *)
LaunchKernels[];
DistributeDefinitions[numberOfCycles];

Evaluating (Subscript[S, 2L]) vertex-based formula

We check
    
 where  α=(∏_(k=1)^n)(Subscript[α, k]) ∈(Subscript[S, 2L]). We assume each (Subscript[O, k]) is a single-trace for simplicity.

Input

ClearAll[Llis,αlis,LL,W0];
Llis={4,4,2};

You can choose the operator lengths from the following list.
However, since |(Subscript[S, 2L])|=(2L)!, it takes a long time to evaluate the formula; e.g. ~4 minutes at  LL=2L=10 with 6 CPU parallelization
Parallelization reduces the computational time by a factor of 2-3.

Grid[Partition[opLis3,5],{Frame->All,Background->{None,{2->LightGray,3->LightGray}}}]

Grid[Partition[opLis4,5],{Frame->All,Background->{None,{2->LightGray,3->LightGray},{{1,3}->LightGray,{1,5}->LightGray}}}]

Compute and compare

αlis=singleTraceCyc[Llis];
LL=Total@Llis;
W0=Cycles[Partition[Range[LL],2]];
alpos=subsListToPositions[Plus@@αlis];

(* apply the vertex-based formula *)

preGV=ParallelTable[Product[h[p,PRe[p,PPr[γ,W0,InvP@γ]]],{p,LL}]*ℕ^(numberOfCycles[#,LL]&@PPr[αlis,γ,W0,InvP@γ]),{γ,GroupElements@SymmetricGroup[LL]}];

GV[Llis]=((Total@preGV)/((2^(LL/2))(LL/2)!))/.(Subscript[h, i1_,j1_]^2)->(Subscript[ht, Min[i1,j1],Max[i1,j1]])//Collect[#,ℕ,Expand]&;

(* Change the flavor label and remove self-contractions. If 4pt, remove the disconnected part *)

GVC[Llis]/.(Subscript[ht, i1_,j1_]):>Δ[alpos[[i1]],alpos[[j1]]]/.Δ[{i_,a_},{i_,b_}]:>0//Collect[#,ℕ,Expand]&

(* check agreement *)

genCyclic[Gcyc[Llis],Llis]-%//Expand

Evaluating (Subscript[S, L]) edge-based formula

We check
      
where
    
We can set  (Subscript[σ, 1])=1  by gauge choice, which removes 1/L! in the second equation.  We assume each (Subscript[O, k]) is a single-trace for simplicity.

Input

ClearAll[Llis,αlis,LL];
Llis={6,4,2};

You can choose the operator lengths from the following list.
For 3pt, it takes ~5+1 min at LL=12 with 6 CPU parallelization
For 4pt, it takes ~30+15 min at LL=10 with 6 CPU parallelization
Note also that one may encounter memory problem for a larger L.

Grid[Partition[opLis3,5],{Frame->All,Background->{None,None,{{2,5}->LightGray,{3,3}->LightGray,{3,4}->LightGray,{3,5}->LightGray}}}]

Grid[Partition[opLis4,5],{Frame->All,Background->{None,{2->LightGray,3->LightGray},{{1,3}->LightGray,{1,5}->LightGray}}}]

Compute and compare

αlis=singleTraceCyc[Llis];
LL=Total@Llis;

(* apply the edge-based formula for 3pt or 4pt *)

preGE=Which[Length@Llis==3,ParallelTable[Product[H@{A[1,p],A[2,PRe[p,σ2]],A[3,PRe[p,σ3]]},{p,LL/2}]*ℕ^(numberOfCycles[#,LL/2]&@PPr[Cycles[{Range[Llis[[1]]]}],Cycles[{PRe[Range[Llis[[2]]],InvP@σ2]}],Cycles[{PRe[Range[Llis[[3]]],InvP@σ3]}]]),
{σ2,GroupElements@SymmetricGroup[LL/2]},{σ3,GroupElements@SymmetricGroup[LL/2]}],
Length@Llis==4,
ParallelTable[Product[H@{A[1,p],A[2,PRe[p,σ2]],A[3,PRe[p,σ3]],A[4,PRe[p,σ4]]},{p,LL/2}]*ℕ^(numberOfCycles[#,LL/2]&@PPr[Cycles[{Range[Llis[[1]]]}],Cycles[{PRe[Range[Llis[[2]]],InvP@σ2]}],Cycles[{PRe[Range[Llis[[3]]],InvP@σ3]}],Cycles[{PRe[Range[Llis[[4]]],InvP@σ4]}]]),
{σ2,GroupElements@SymmetricGroup[LL/2]},{σ3,GroupElements@SymmetricGroup[LL/2]},{σ4,GroupElements@SymmetricGroup[LL/2]}]];

(* normalization and remove fictitious terms *)

GE[Llis]=((Total[Flatten@preGE])/(Product[(LL/2-Llis[[ii]])!,{ii,Length@Llis}]))/.A[i_,k_]:>1/;k>Llis[[i]]/.{KroneckerDelta[1,A[any___]]->0,h[{1,1}]->0}//Expand//Collect[#,ℕ]&

(* Change the flavor label and check agreement. If 4pt, remove the disconnected part *)

genCyclic[Gcyc[Llis],Llis]-GEC[Llis]/.h[A[a_,k_],A[b_,l_]]->Δ[{a,k},{b,l}]//Expand

Evaluating (Subscript[S, 2L]) face-based formula, rim labels by W

We check
    
where we sum ω over permutations without one-cycles, and 
     
Here (Subscript[μ, β]) is a Wick contraction matrix induced by the canonical labelling α=ω W, and we sum β over the stabilizer subgroup of α.
 We assume each (Subscript[O, k]) is a single-trace for simplicity.

Input

ClearAll[Llis,LL,W0];
Llis={4,3,3};

You can choose the operator lengths from the following list.
It takes ~2 min at LL=10 without parallelization. However, it is difficult to reach LL=12 due to insufficient memory.

Grid[Partition[opLis3,5],{Frame->All,Background->{None,{2->LightGray,3->LightGray}}}]

Grid[Partition[opLis4,5],{Frame->All,Background->{None,{2->LightGray,3->LightGray},{{1,3}->LightGray,{1,5}->LightGray}}}]

Compute and compare

αlis=singleTraceCyc[Llis];
LL=Total@Llis;
W0=Cycles[Partition[Range[LL],2]];

(* generate face permutations without one-cycles *)
Position[Total/@Map[Length,(GroupElements@SymmetricGroup[LL]/.Cycles->Plus),{2}],LL];
faceGroup=Extract[GroupElements@SymmetricGroup[LL],%];
(* vertex permutations induced by α=ωW *)
vertexGroup=PPr[W0,#]&/@faceGroup;
(* extract the vertex permutations having the correct cycle type, assuming L1≥L2≥ ... *)
posαlis=Flatten@Join[Position[Map[Length,(vertexGroup/.Cycles->Plus),{2}],#]&/@Permutations[Llis]];
Length@posαlis

(* the desired vertex permutations *)
vertexGroupExternal=Part[vertexGroup,posαlis];
(* count powers of Nc *)
facePowers=Map[Length,Part[faceGroup,posαlis]/.Cycles->Plus,{1}]/.num_:>(ℕ^num);
(* Flavor factors;
   first we generate canonically ordered lists from cycles,
   second we sum the flavor factors over the orbit of cyclic translation, and remove self-contractions *)
vertexListExternal=ReverseSort[#,Length[#1]<Length[#2]&]&/@(vertexGroupExternal/.Cycles->Plus);
tabFlavors=Total/@Table[flavorFromCycles[#,LL/2]&/@wreathOrbitsFromCycles[vertexListExternal[[kk]]]/.h[A[i_,p_],A[i_,q_]]:>0,{kk,Length@posαlis}];

(* the face-based formula *)
GF[Llis]=((facePowers.tabFlavors)/(wreathLength@ConstantArray[2,LL/2]))/.h[A[a_,k_],A[b_,l_]]:>Δ[{a,k},{b,l}]//Collect[#,ℕ,Expand]&

(* check agreement *)
genCyclic[Gcyc[Llis],Llis]-GFC[Llis]//Expand

Evaluating 2,3,4-pt of half-BPS operators

We compare the results from the literature for specific examples, as an extra consistency check.
This is trivial in the sense that our formula agrees with the direct computation by Wick contractions.

Analytic results from hep-th/0205033 and hep-th/0208178

(* extremal correlators of half-BPS n-point functions *)
bps2pt[L_,N_]:=(1/(L+1))(((Gamma[N+L+1])/(Gamma[N]))-((Gamma[N+1])/(Gamma[N-L])));
bps3pt[L_,J1_,N_]:=(1/(L+1))(((Gamma[N+L+1])/(Gamma[N]))+((Gamma[N+1])/(Gamma[N-L]))-((Gamma[N+L-J1+1])/(Gamma[N-J1]))-((Gamma[N+J1+1])/(Gamma[N-L+J1])));
bps4pt[L_,J1_,J2_,N_]:=(1/(L+1))(((Gamma[N+L+1])/(Gamma[N]))-((Gamma[N+L-J1+1])/(Gamma[N-J1]))-((Gamma[N+L-J2+1])/(Gamma[N-J2]))-((Gamma[N+L-J3+1])/(Gamma[N-J3]))+((Gamma[N+J1+1])/(Gamma[N-L+J1]))+((Gamma[N+J2+1])/(Gamma[N-L+J2]))+((Gamma[N+J3+1])/(Gamma[N-L+J3]))-((Gamma[N+1])/(Gamma[N-L])))/.J3->L-J1-J2;

(* non-extremal correlators of half-BPS 4-point functions, J1+J2=K1+K2 *)
mm4pt[J1_,J2_,K1_,K2_,N_]:=(1/(J1+J2+1))((((N+J1+J2)!)/((N-1)!))+(((N+Min[J1,J2,K1,K2])!)/((N-Max[J1,J2,K1,K2]-1)!))-(((N+Max[J1,J2,K1,K2])!)/((N-Min[J1,J2,K1,K2]-1)!))-((N!)/((N-J1-J2-1)!)))-Sum[(((N+m)!)/((N+m-J2)!))(((N+m+J1-K1)!)/((N+m-K1)!)),{m,Max[0,K1-J1],Min[J2,K1]-1}]-Sum[(((N+m)!)/((N+m-J1)!))(((N+m+J2-K1)!)/((N+m-K1)!)),{m,Max[0,K1-J2],Min[J1,K1]-1}];

Comparison with Wick data

2pt

Table[G[m,m],{m,2,6}]/.{(Subsuperscript[Δ, {b_,Ib_}, {a_,Ia_}])->1,x[any_]->1}
Table[bps2pt[m,ℕ],{m,2,6}]-%//FS

Extremal 3pt

extremalLis3=Select[opLis3,#[[1]]==#[[2]]+#[[3]]&]

genCyclic[Gcyc[#],#]&/@extremalLis3/.{(Subsuperscript[Δ, {b_,Ib_}, {1,Ia_}])->1,(Subsuperscript[Δ, {3,Ib_}, {2,Ia_}])->0}
Table[bps3pt[extremalLis3[[m,1]],extremalLis3[[m,2]],ℕ],{m,Length@extremalLis3}]-%//FS

Extremal 4pt

In order to generate various extremal 4pt functions, we use the fomula for multi-trace 2pt functions,
   
where α=(1,2,...,L) and β=(1...(Subscript[J, 1]))((Subscript[J, 1])+1 ... (Subscript[J, 1])+(Subscript[J, 2]))((Subscript[J, 1])+(Subscript[J, 2])+1 .... L)

tabBPS4pt=ParallelTable[Table[Table[Total@((ℕ^(#))&/@(numberOfCycles[#,L]&/@Table[PPr[Cycles[{Range[L]}],σ,InvP@Cycles[{Range[J1],Range[J2]+J1,Range[L-J1-J2]+J1+J2}],InvP@σ],{σ,GroupElements@SymmetricGroup[L]}])) ,{J1,L-J2-1}],{J2,L-2}],{L,8}];

Table[Table[Table[bps4pt[L,J1,J2,ℕ],{J1,L-J2-1}],{J2,L-2}],{L,8}]-tabBPS4pt//FS

Non-extremal 4pt at cross-ration=1

The computation of non-extremal 4-pt functions of half-BPS operators reduces to those of a matrix model 
only if the space-time dependence is trivial, e.g. if the cross-ratio is 1.

(* list of operator lengths to be checked *)
lisBMN={{2,2,2,2},{3,2,3,2},{3,3,3,3},{4,2,3,3},{4,2,4,2},{4,3,4,3},{5,2,4,3},{5,2,5,2}};

(* simplify Wick contractions for half-BPS correlators;
   we keep the cross ratio q, but neglect the overall spacetime dependence given by 
Dz[{j1_,j2_,j3_,j4_}]:=1/(((Subscript[x, 2,4])^(2j2))((Subscript[x, 1,3])^(2j3))((Subscript[x, 1,4])^(2j1-2j3)));*)
subChiral={(Subsuperscript[Δ, {b_,Ib_}, {a_,Ia_}]):>1/;MemberQ[{1,2},a]&&MemberQ[{3,4},b],(Subsuperscript[Δ, {b_,Ib_}, {a_,Ia_}]):>0/;Sort[{a,b}]=={1,2},(Subsuperscript[Δ, {b_,Ib_}, {a_,Ia_}]):>0/;Sort[{a,b}]=={3,4},(Subscript[x, 1,3])->(((Sqrt[q]) (Subscript[x, 1,4]) (Subscript[x, 2,3]))/(Subscript[x, 2,4]))};

(* Wick results -- it takes ~2 min with 6 CPU parallelization *)

tabWickBPS4pt=ParallelTable[Expand[wick[o[1,lisBMN[[ii,1]]]o[2,lisBMN[[ii,2]]]o[3,lisBMN[[ii,3]]]o[4,lisBMN[[ii,4]]]]],{ii,Length@lisBMN}];

(* simplify the results and take the connected part of 4pt *)Do[G[lisBMN[[ii,1]],lisBMN[[ii,2]],lisBMN[[ii,3]],lisBMN[[ii,4]]]=tabWickBPS4pt[[ii]]/.subChiral//.indices//Collect[#,ℕ]&,{ii,Length@lisBMN}];
Do[wickgN[ii]=Collect[GC[lisBMN[[ii]]]/.subChiral,ℕ,FS],{ii,Length@lisBMN}];

Compare with the analytic formula -- agreement

Table[wickgN[ii]/.q->1,{ii,Length@lisBMN}]
Table[mm4pt[lisBMN[[ii,1]],lisBMN[[ii,2]],lisBMN[[ii,3]],lisBMN[[ii,4]],ℕ],{ii,Length@lisBMN}]-%//FS