Example 6.5: Random tensor networks for holographic duality

SetDirectory[NotebookDirectory[]];
<<RTNI`

(* subroutine for creating tensor networks representing Tr(\rho\otimes rho) and \tr(\rho_A^2) for a given graph G and subset A of the vertices*)buildTNfromGraph[g_,marginal_,debug_:False]:=Module[{psi,nV,nE,i,e,traceRho,traceRhoASquared,newEdge,degree,v1,v2,v,psiStar,rho},
nV=Length[VertexList[g]];
nE=Length[EdgeList[g]];
degree=ConstantArray[1,nV];
psi={};
psiStar={};
For[i=1,i≤nE,i++,
e=EdgeList[g][[i]];
v1=e[[1]];
v2=e[[2]];
If[debug,Print["edge: ",v1," --- ",v2,"  read."]];
degree[[v1]]++;
degree[[v2]]++;
newEdge={{"U"<>ToString[v1],1,"out",degree[[v1]]},{"U"<>ToString[v2],1,"out",degree[[v2]]}};
AppendTo[psi,newEdge];
newEdge={{"U"<>ToString[v1]<>"*",1,"in",degree[[v1]]},{"U"<>ToString[v2]<>"*",1,"in",degree[[v2]]}};
AppendTo[psiStar,newEdge];
];
rho=Join[psi,psiStar];
traceRho=rho;
For[i=1,i≤nV,i++,
v=i;
newEdge={{"U"<>ToString[v],1,"out",1},{"U"<>ToString[v]<>"*",1,"in",1}};
AppendTo[traceRho,newEdge];
];
traceRhoASquared=cloneGraph[rho,2];
For[i=1,i≤nV,i++,
v=i;
If[MemberQ[marginal,v],
newEdge={{"U"<>ToString[v],1,"out",1},{"U"<>ToString[v]<>"*",2,"in",1}};
AppendTo[traceRhoASquared,newEdge];
newEdge={{"U"<>ToString[v],2,"out",1},{"U"<>ToString[v]<>"*",1,"in",1}};
AppendTo[traceRhoASquared,newEdge];
,
newEdge={{"U"<>ToString[v],1,"out",1},{"U"<>ToString[v]<>"*",1,"in",1}};
AppendTo[traceRhoASquared,newEdge];
newEdge={{"U"<>ToString[v],2,"out",1},{"U"<>ToString[v]<>"*",2,"in",1}};
AppendTo[traceRhoASquared,newEdge];
];
];
{cloneGraph[traceRho,2],traceRhoASquared}
];

(* routine for integrating over all unitaries by invoking integrateHaarUnitary several times *)
integrateAllUs[tn_,d_,s_,debug_:False]:=Module[{listU,i,name,v,p,maxLeg,intTN},
listU={};
maxLeg={};
For[i=1,i≤Length[tn],i++,
For[j=1,j≤2,j++,
name=Characters[tn[[i,j,1]]];
If[debug,Print[name]];
If[name[[1]]=="U"&&Last[name]≠"*",
v=ToExpression[StringJoin[name[[2;;]]]];
If[debug,Print[v]];
If[!MemberQ[listU,v],
AppendTo[listU,v];
AppendTo[maxLeg,1];
];
If[debug,Print[listU]];
p=Position[listU,v][[1,1]];
maxLeg[[p]]=Max[tn[[i,j,4]],maxLeg[[p]]];
If[debug,Print[maxLeg]];
];
]];
intTN=tn;
For[i=1,i≤Length[listU],i++,
intTN=integrateHaarUnitary[intTN,"U"<>ToString[listU[[i]]],{},Join[{d},ConstantArray[s,maxLeg[[i]]-1]],d s^(maxLeg[[i]]-1)];
];
intTN
];
(* routines for computing the averages via the Ising model formulation*)
computeenergy[spinconfig_,g_,marginal_]:=Module[{result=0,nV,nE,degree,v1,v2,v},
nV=Length[VertexList[g]];
nE=Length[EdgeList[g]];
degree=ConstantArray[1,nV];(* add energy contribution from Ising interaction *)
For[i=1,i≤nE,i++,
e=EdgeList[g][[i]];
v1=e[[1]];
v2=e[[2]];
(*Print["vertex v1=", v1," v2=",v2," energy contrib=",spinconfig[[v1]]*spinconfig[[v2]]];*)
result=result+spinconfig[[v1]]*spinconfig[[v2]];
];
(* add energy contribution from field *)
For[i=1,i≤nV,i++,
v=i; 
(*Print["vertex v=", v,"  field energy contrib=",spinconfig[[v]]*If[MemberQ[marginal,v],1,-1]];*)
result=result+spinconfig[[v]]*If[MemberQ[marginal,v],-1,1];
];
result=result/2;
result
];
findallenergies[g_,marginal_]:=Module[{spinconfiglist,nV,result,j},
nV=Length[VertexList[g]];
spinconfiglist=Tuples[{-1,1},nV];
result=Table[{spinconfiglist[[j]],computeenergy[spinconfiglist[[j]],g,marginal]},{j,1,2^nV}];
result=SortBy[result,#[[2]]&];
result
];
computeexponents[g_,marginal_]:=Module[{allspinsE,marginalspinsE,Eminall,Eminmarginal,result},
nV=Length[VertexList[g]];
allspinsE=findallenergies[g,{}];
marginalspinsE=findallenergies[g,marginal];
Emaxall=allspinsE[[Length[allspinsE]]][[2]];
Emaxmarginal=marginalspinsE[[Length[allspinsE]]][[2]];
result={Emaxall,Emaxmarginal};(*,Emaxall-Emaxmarginal,marginalspinsE[[1]]};*)
result
];

Triangle graph example

g=Graph[{1\[UndirectedEdge]2,2\[UndirectedEdge]3,3\[UndirectedEdge]1}];
edgeNormalization=d^(-2EdgeCount[g]);(* This pre-factor corresponds to using normalized maximally entangled states in the main text *)
marginal={1,2};
GraphPlot[g,VertexRenderingFunction->({If[MemberQ[marginal,#2],Green,Red],EdgeForm[Black],Disk[#,.1],Black,Text[#2,#1]}&)]
Export["triangle-1.pdf",%];
tn=buildTNfromGraph[g,marginal];
visualizeTN[tn[[1]]]
Export["triangle-2.pdf",%];
visualizeTN[tn[[2]]]
Export["triangle-3.pdf",%];
Z0=edgeNormalization integrateAllUs[tn[[1]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z0]/Log[d],d->Infinity]
ZA=edgeNormalization  integrateAllUs[tn[[2]],d,d][[1,2]]//FullSimplify
Limit[-Log[ZA]/Log[d],d->Infinity]
computeexponents[g,marginal]

(* TO BE FIXED *)

g=Graph[{1\[UndirectedEdge]2}];
edgeNormalization=d^(-2 EdgeCount[g]);
marginal={1};
GraphPlot[g,VertexRenderingFunction->({If[MemberQ[marginal,#2],Green,Red],EdgeForm[Black],Disk[#,.1],Black,Text[#2,#1]}&)]
tn=buildTNfromGraph[g,marginal];
visualizeTN[tn[[1]]]
visualizeTN[tn[[2]]]
Z0=edgeNormalization integrateAllUs[tn[[1]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z0]/Log[d],d->Infinity]
ZA=edgeNormalization  integrateAllUs[tn[[2]],d,d][[1,2]]//FullSimplify
Limit[-Log[ZA]/Log[d],d->Infinity]
(*renyi2=Z1/Z0//FullSimplify*)
computeexponents[g,marginal]
(*Series[renyi2/.{s->d},{d,Infinity,20}]*)

g=Graph[{1\[UndirectedEdge]2,2\[UndirectedEdge]3}];
marginal={1,3};
GraphPlot[g,VertexRenderingFunction->({If[MemberQ[marginal,#2],Green,Red],EdgeForm[Black],Disk[#,.1],Black,Text[#2,#1]}&)]
tn=buildTNfromGraph[g,marginal];
visualizeTN[tn[[1]]]
visualizeTN[tn[[2]]]
Z0=integrateAllUs[tn[[1]],d,d][[1,2]]//FullSimplify
Z1=integrateAllUs[tn[[2]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z0]/Log[d],d->Infinity]
Limit[-Log[Z1]/Log[d],d->Infinity]
computeexponents[g,marginal]
(*renyi2=Z1/Z0;
Series[renyi2,{d,Infinity,4}]
computeexponents[g,marginal]*)

g=CompleteGraph[6];
marginal={1,2,3};
GraphPlot[g,VertexRenderingFunction->({If[MemberQ[marginal,#2],Green,Red],EdgeForm[Black],Disk[#,.1],Black,Text[#2,#1]}&)]
tn=buildTNfromGraph[g,marginal];
visualizeTN[tn[[1]]]
visualizeTN[tn[[2]]]
Z0=edgeNormalization integrateAllUs[tn[[1]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z0]/Log[d],d->Infinity]
Z1=edgeNormalization integrateAllUs[tn[[2]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z1]/Log[d],d->Infinity]
computeexponents[g,marginal]
(*Series[Z1/Z0,{d,Infinity,3}]
computeexponents[g,marginal]*)

21-15

squareLatticeGraph[m_,n_]:=Module[{g,i,j},
g={};
For[i=1,i≤m,i++,
For[j=1,j≤n-1,j++,
AppendTo[g,UndirectedEdge[n(i-1)+j,n(i-1)+j+1]];
]];
For[i=1,i≤m-1,i++,
For[j=1,j≤n,j++,
AppendTo[g,UndirectedEdge[n(i-1)+j,n(i)+j]];
]];
Graph[g]
];

g=Graph[{1\[UndirectedEdge]2,2\[UndirectedEdge]3,3\[UndirectedEdge]4,4\[UndirectedEdge]5,5\[UndirectedEdge]6,6\[UndirectedEdge]1,2\[UndirectedEdge]5}];
edgeNormalization=d^(-2EdgeCount[g]);
marginal={1,2,3};
GraphPlot[g,VertexRenderingFunction->({If[!MemberQ[marginal,#2],Red,Green],EdgeForm[Black],Disk[#,.1],Black,Text[#2,#1]}&)]
tn=buildTNfromGraph[g,marginal];
visualizeTN[tn[[1]]]
visualizeTN[tn[[2]]]
Z0=edgeNormalization integrateAllUs[tn[[1]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z0]/Log[d],d->Infinity]
Z1=edgeNormalization integrateAllUs[tn[[2]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z1]/Log[d],d->Infinity]
computeexponents[g,marginal]
(*Series[Z1/Z0,{d,Infinity,3}]
computeexponents[g,marginal]*)

g=Graph[{1\[UndirectedEdge]2,2\[UndirectedEdge]3,3\[UndirectedEdge]4,4\[UndirectedEdge]5,5\[UndirectedEdge]6,6\[UndirectedEdge]1,2\[UndirectedEdge]5}];
g=EdgeDelete[g,{2\[UndirectedEdge]5}];edgeNormalization=d^(-2EdgeCount[g]);
GraphPlot[g,VertexRenderingFunction->({If[!MemberQ[marginal,#2],Red,Green],EdgeForm[Black],Disk[#,.1],Black,Text[#2,#1]}&)]
tn=buildTNfromGraph[g,marginal];
visualizeTN[tn[[1]]]
visualizeTN[tn[[2]]]
Z0=edgeNormalization integrateAllUs[tn[[1]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z0]/Log[d],d->Infinity]
Z1=edgeNormalization integrateAllUs[tn[[2]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z1]/Log[d],d->Infinity]
computeexponents[g,marginal]

g=squareLatticeGraph[4,4];
marginal={6,7,10,11};
GraphPlot[g,VertexRenderingFunction->({If[!MemberQ[marginal,#2],Red,Green],EdgeForm[Black],Disk[#,.1],Black,Text[#2,#1]}&)]
tn=buildTNfromGraph[g,marginal];
visualizeTN[tn[[1]]]
visualizeTN[tn[[2]]]
Z0=edgeNormalization integrateAllUs[tn[[1]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z0]/Log[d],d->Infinity]
Z1=edgeNormalization integrateAllUs[tn[[2]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z1]/Log[d],d->Infinity]
(*Series[Z1/Z0,{d,Infinity,3}]*)
computeexponents[g,marginal]

g=squareLatticeGraph[4,4];
marginal={6,7,10};
GraphPlot[g,VertexRenderingFunction->({If[!MemberQ[marginal,#2],Red,Green],EdgeForm[Black],Disk[#,.1],Black,Text[#2,#1]}&)]
tn=buildTNfromGraph[g,marginal];
visualizeTN[tn[[1]]]
visualizeTN[tn[[2]]]
Z0=edgeNormalization integrateAllUs[tn[[1]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z0]/Log[d],d->Infinity]
Z1=edgeNormalization integrateAllUs[tn[[2]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z1]/Log[d],d->Infinity]
(*Series[Z1/Z0,{d,Infinity,3}]*)
computeexponents[g,marginal]

g=squareLatticeGraph[4,4];
marginal={1,2,5,6};
GraphPlot[g,VertexRenderingFunction->({If[!MemberQ[marginal,#2],Red,Green],EdgeForm[Black],Disk[#,.1],Black,Text[#2,#1]}&)]
tn=buildTNfromGraph[g,marginal];
visualizeTN[tn[[1]]]
visualizeTN[tn[[2]]]
Z0=edgeNormalization integrateAllUs[tn[[1]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z0]/Log[d],d->Infinity]
Z1=edgeNormalization integrateAllUs[tn[[2]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z1]/Log[d],d->Infinity]
computeexponents[g,marginal]

g=squareLatticeGraph[4,4];
marginal={1,2,3,5,6,7};
GraphPlot[g,VertexRenderingFunction->({If[!MemberQ[marginal,#2],Red,Green],EdgeForm[Black],Disk[#,.1],Black,Text[#2,#1]}&)]
tn=buildTNfromGraph[g,marginal];
visualizeTN[tn[[1]]]
visualizeTN[tn[[2]]]
Z0=edgeNormalization integrateAllUs[tn[[1]],d,d][[1,2]]//FullSimplify
Limit[-Log[Z0]/Log[d],d->Infinity]
ZA=edgeNormalization integrateAllUs[tn[[2]],d,d][[1,2]]//FullSimplify
Limit[-Log[ZA]/Log[d],d->Infinity]

computeexponents[g,marginal]