SetOptions[$FrontEndSession,ShowCellLabel->False]
LasagnaColor = RGBColor[{241,177,70}/255];
SetOptions[Graphics3D,Boxed->False,Lighting->"Neutral" ,ImageSize->Large];
SetOptions[Animate,AnimationRepetitions->1,AnimationRate->.5,AnimationRunning->False];
SetOptions[GraphicsGrid,ImageSize->800];
SetOptions[ListPlot,ImageSize->Full];
SetOptions[ListLogLogPlot,ImageSize->Full];
Tent[n_]:=Module[{rot,ver,Base,h,hcoor},
rot=RotationTransform[2π/n];
ver[1]= {0,0};
ver[2]= {1,0};
Do[ver[idx]=rot[ver[idx-1]];,{idx,3,n}];
Base=Join[#,{0}]&/@Table[Sum[ver[idx],{idx,1,L}],{L,1,n}];
h={x,y,z};
hcoor=h/.Last@Solve[Table[Norm[Base[[idx]]-h]==1,{idx,1,n}],{x,y,z}];
Base=Join[Base,{{0,0,0}}];
Return[Table[{LasagnaColor,Polygon[{Base[[idx]],Base[[idx+1]],hcoor}]},{idx,1,n}]]
]
t=Polygon[5{{-1/2,-1/2 1/Sqrt[3]},{1/2,-1/2 1/Sqrt[3]},{0,1/Sqrt[3]}}];
v= Arrow[{{0,0},{0,1}}];
flip=RotationTransform[{t[[1,3]]-t[[1,1]],t[[1,3]]-t[[1,2]]}];
backgroundt= {EdgeForm[Directive[Thick,Blue]],White,t};
v0={Red,v};
ptransp[v_,s_]:= {Thick,Translate[Arrow[{{0,0},v}],s{-1,0}]}
face[n_]:= Nest[flip,{0,1},n-1]
title[n_]:=StringJoin["Face ",ToString[n]];
midfaceanimation[n_]:=Animate[Labeled[Graphics[{backgroundt,ptransp[face[n],s]}],title[n],Top],{s,-5/3,5/3}]
startfaceanimation:=Animate[Labeled[Graphics[{backgroundt,v0,ptransp[face[1],s]}],"Face 1",Top],{s,0,5/3}]
endfaceanimation[n_]:=Animate[Labeled[Graphics[{backgroundt,v0,ptransp[face[n],s]}],"Face 1",Top],{s,-5/3,0}]
midfaceanimation[n_]:=Animate[Labeled[Graphics[{backgroundt,ptransp[face[n],s]}],title[n],Top],{s,-5/3,5/3}]
Lasagna = Cuboid[{0,0,0},{3,2,1}];
center[P_]:= Point[Mean[First[P]]]
areadjacentT[{P1_,P2_}]:=(Length[Intersection[First[P1],First[P2]]]==3)
lineT[{P1_,P2_}]:=If[areadjacentT[{P1,P2}],Line[{Mean[First[P1]],Mean[First[P2]]}]]
SplitTetrahedron[t_,r_,e_]:= Module[{o,t1,t2},
o= Complement[First[t],r];
t1 = Join[o,{First[r],e}];
t2 = Join[o,{Last[r],e}];
Return[{Tetrahedron[t1],Tetrahedron[t2]}]
]
TopBias[e_]:=(Chop[First[e].{0,0,1}]==1)&&(Chop[Last[e].{0,0,1}]==1)
BotBias[e_]:=(Chop[First[e].{0,0,1}]==0)&&(Chop[Last[e].{0,0,1}]==0)
DELTA=MeshPrimitives[DiscretizeRegion[Lasagna,MaxCellMeasure->2],3];
edges=DeleteDuplicates[Flatten[Subsets[First[#],{2}]&/@DELTA,1]];
redge = First[RandomChoice[Select[edges,TopBias],1] ];
(*find tets that I need to split*)
involvedtets=Select[DELTA,MemberQ[First[#],First[redge]]&&MemberQ[First[#],Last[redge]]&];
(*split the edge*)
e = Mean[redge];
(*split the tets with that edge*)
newtets=Flatten[SplitTetrahedron[#,redge,e]&/@involvedtets];
DELTA=Join[Complement[DELTA,involvedtets],newtets];
edges=DeleteDuplicates[Flatten[Subsets[First[#],{2}]&/@DELTA,1]];
redge = First[RandomChoice[Select[edges,TopBias],1] ];
(*find tets that I need to split*)
involvedtets=Select[DELTA,MemberQ[First[#],First[redge]]&&MemberQ[First[#],Last[redge]]&];
(*split the edge*)
e = Mean[redge];
(*split the tets with that edge*)
newtets=Flatten[SplitTetrahedron[#,redge,e]&/@involvedtets];
DELTA=Join[Complement[DELTA,involvedtets],newtets];
edges=DeleteDuplicates[Flatten[Subsets[First[#],{2}]&/@DELTA,1]];
redge = First[RandomChoice[Select[edges,TopBias],1] ];
(*find tets that I need to split*)
involvedtets=Select[DELTA,MemberQ[First[#],First[redge]]&&MemberQ[First[#],Last[redge]]&];
(*split the edge*)
e = Mean[redge];
(*split the tets with that edge*)
newtets=Flatten[SplitTetrahedron[#,redge,e]&/@involvedtets];
DELTA=Join[Complement[DELTA,involvedtets],newtets];
edges=DeleteDuplicates[Flatten[Subsets[First[#],{2}]&/@DELTA,1]];
redge = First[RandomChoice[Select[edges,TopBias],1] ];
(*find tets that I need to split*)
involvedtets=Select[DELTA,MemberQ[First[#],First[redge]]&&MemberQ[First[#],Last[redge]]&];
(*split the edge*)
e = Mean[redge];
(*split the tets with that edge*)
newtets=Flatten[SplitTetrahedron[#,redge,e]&/@involvedtets];
DELTA=Join[Complement[DELTA,involvedtets],newtets];
edges=DeleteDuplicates[Flatten[Subsets[First[#],{2}]&/@DELTA,1]];
redge = First[RandomChoice[Select[edges,TopBias],1] ];
(*find tets that I need to split*)
involvedtets=Select[DELTA,MemberQ[First[#],First[redge]]&&MemberQ[First[#],Last[redge]]&];
(*split the edge*)
e = Mean[redge];
(*split the tets with that edge*)
newtets=Flatten[SplitTetrahedron[#,redge,e]&/@involvedtets];
DELTA=Join[Complement[DELTA,involvedtets],newtets];
edges=DeleteDuplicates[Flatten[Subsets[First[#],{2}]&/@DELTA,1]];
redge = First[RandomChoice[Select[edges,TopBias],1] ];
(*find tets that I need to split*)
involvedtets=Select[DELTA,MemberQ[First[#],First[redge]]&&MemberQ[First[#],Last[redge]]&];
(*split the edge*)
e = Mean[redge];
(*split the tets with that edge*)
newtets=Flatten[SplitTetrahedron[#,redge,e]&/@involvedtets];
DELTA=Join[Complement[DELTA,involvedtets],newtets];
edges=DeleteDuplicates[Flatten[Subsets[First[#],{2}]&/@DELTA,1]];
redge = First[RandomChoice[Select[edges,BotBias],1] ];
(*find tets that I need to split*)
involvedtets=Select[DELTA,MemberQ[First[#],First[redge]]&&MemberQ[First[#],Last[redge]]&];
(*split the edge*)
e = Mean[redge];
(*split the tets with that edge*)
newtets=Flatten[SplitTetrahedron[#,redge,e]&/@involvedtets];
DELTA=Join[Complement[DELTA,involvedtets],newtets];
edges=DeleteDuplicates[Flatten[Subsets[First[#],{2}]&/@DELTA,1]];
redge = First[RandomChoice[Select[edges,BotBias],1] ];
(*find tets that I need to split*)
involvedtets=Select[DELTA,MemberQ[First[#],First[redge]]&&MemberQ[First[#],Last[redge]]&];
(*split the edge*)
e = Mean[redge];
(*split the tets with that edge*)
newtets=Flatten[SplitTetrahedron[#,redge,e]&/@involvedtets];
DELTA=Join[Complement[DELTA,involvedtets],newtets];
edges=DeleteDuplicates[Flatten[Subsets[First[#],{2}]&/@DELTA,1]];
redge = First[RandomChoice[Select[edges,BotBias],1] ];
(*find tets that I need to split*)
involvedtets=Select[DELTA,MemberQ[First[#],First[redge]]&&MemberQ[First[#],Last[redge]]&];
(*split the edge*)
e = Mean[redge];
(*split the tets with that edge*)
newtets=Flatten[SplitTetrahedron[#,redge,e]&/@involvedtets];
DELTA=Join[Complement[DELTA,involvedtets],newtets];
IsOnTop[T_]:=(Count[Last/@First[T],1.]==3)
TopFace[T_]:= Select[First[T],Last[#]==1.&]
IsOnBot[T_]:=(Count[Last/@First[T],0.]==3)
BotFace[T_]:= Select[First[T],Last[#]==0.&]
BoundaryLine[T_]:=If[IsOnTop[T],Line[{Mean[First[T]],Mean[TopFace[T]]}],Line[{Mean[First[T]],Mean[BotFace[T]]}]]
triangles=Polygon/@DeleteDuplicates[Flatten[Subsets[First[#],{3}]&/@DELTA,1]];
TopDELTA=Select[triangles,IsOnTop];
BotDELTA=Select[triangles,IsOnBot];
areadjacent[{P1_,P2_}]:=(Length[Intersection[First[P1],First[P2]]]==2)
line[{P1_,P2_}]:=If[areadjacent[{P1,P2}],Line[{Mean[First[P1]],Mean[First[P2]]}]]
BoundEdge[Tr_]:=Module[{edges},
edges = Subsets[First[Tr],{2}];
Select[edges,(First[#][[1]]==0.&&Last[#][[1]]==0.)||(First[#][[1]]==3.&&Last[#][[1]]==3.)||(First[#][[2]]==0.&&Last[#][[2]]==0.)||(First[#][[2]]==2.&&Last[#][[2]]==2.)&]
]
BoundaryLineb[Tr_]:=Module[{lines},
lines=Line[{Mean[First[Tr]],Mean[#]}]&/@BoundEdge[Tr];
Return[lines];
]

Numerical methods in LQG

Lecture 3: Elements of spin foams

Content
	Regge calculus and triangulations
	Spin foam transition amplitudes
	Ponzano Regge model and its connection with 3D GR
	

Minimal references -
	[(HyperlinkURL["BOOK", http://www.cpt.univ-mrs.fr/~rovelli/IntroductionLQG.pdf])] Rovelli and Vidotto, “Covariant Loop Quantum Gravity”
	[(HyperlinkURL["VIDEO", https://www.youtube.com/channel/UCZ4fso22jORv9aeGc9dEAxw])] Rovelli, “Introduction to Loop Quantum gravity”
	[(HyperlinkURL["PAPER", https://link.springer.com/article/10.1007/BF02733251])] Regge “General relativity without coordinates”
	[(HyperlinkDefault["PAPER", boh, boh])] Ponzano and Regge “Semiclassical limit of Racah coefficients”

Regge Calculus

Describe curved spacetime in an approximate way with piecewise flat triangulation. Truncate degrees of freedom.

Building blocks: 2D triangles, 3D tetrahedra, 4D 4-simplices.

We focus on 2D for simplicity. What surfaces can we approximate using 6 equilateral triangles? What about 5,4,3? What about 7 or more?

Manipulate[Graphics3D[Tent[n]],{n,{6,5,4,3}}]

Local gaussian curvature encoded in deficit angles around hinges: 2D vertices, 3D sides, 4D triangles. 

This is equivalent to the parallel transport.

Start with a vector, choose a path and parallel transport it to the side

Animate[Graphics[{backgroundt,v0,ptransp[{0,1},s]}],{s,0,5/3}]

To parallel transport to the next face we use the notion inherited from

Graphics[{{EdgeForm[Directive[Thick,Blue]],White,Polygon[5{{-1,1/Sqrt[3]},{-1/2,-1/2 1/Sqrt[3]},{0,1/Sqrt[3]}}]},{EdgeForm[Directive[Thick,Blue]],White,Polygon[5{{-1/2,-1/2 1/Sqrt[3]},{1/2,-1/2 1/Sqrt[3]},{0,1/Sqrt[3]}}]},{Thick,Translate[Arrow[{{0,0},{0,1}}],{-5/3,0}]},{Thick,Arrow[{{0,0},{0,1}}]},{Thick,Translate[Arrow[{{0,0},{0,1}}],{-8/3,1}]}}]

GraphicsGrid[{{Graphics[{backgroundt,ptransp[{0,1},5/3]}],Graphics[{backgroundt,ptransp[face[2],-5/3]}]}}]

Keep parallel transporting from one adjacent triangle to the next one until we return to the initial face. Flat space can be triangulated with 6 flat equilateral tetrahedra.

Grid[{{startfaceanimation,midfaceanimation[2],midfaceanimation[3]},{midfaceanimation[4],midfaceanimation[5],midfaceanimation[6]},{Null,endfaceanimation[7]}}]

With less (or more) than six equilateral triangles when a vector come back to itself it is rotated.

Grid[{{startfaceanimation,midfaceanimation[2],midfaceanimation[3]},{midfaceanimation[4],midfaceanimation[5],endfaceanimation[6]}}]

Curvature is encoded in deficit angles
	
	
 labels the the simplices sharing a hinge (co-dimension 2).

Given a triangulation the deficits angles are a function of the lengths, and you can compute them.  If  the gaussian curvature is 0 around that hinge, if positive is positive, if negative is negative.

Next step is building a path integral.

Exercise

In 2D the curvature invariant is related to the Euler characteristic. Prove that the Regge action is independent of both the triangulation and the lengths and is  or  the Euler characteristic of the triangulation.

Exercise (difficult)

In 3D the equation of motions of  are equivalent to .

Triangulations

Compact region of (Euclidean 3D) space time with boundary formed by two disconnected components (past/future):

	

Let’s model it for simplicity of drawing

Graphics3D[{LasagnaColor,Lasagna}]

Fix a triangulation  of the space-time:

Graphics3D[{{LasagnaColor,Opacity[0.5],DELTA}}]

BoundaryGraphicsTop=Graphics3D[{{LasagnaColor,TopDELTA},{Blue,Thick,line/@Subsets[TopDELTA,{2}]},{Red,PointSize[Large],center/@TopDELTA},
{Blue,Thick,Flatten[BoundaryLineb/@TopDELTA]}}];
BoundaryGraphicsBot=Graphics3D[{{LasagnaColor,BotDELTA},{Blue,Thick,line/@Subsets[BotDELTA,{2}]},{Red,PointSize[Large],center/@BotDELTA},
{Blue,Thick,Flatten[BoundaryLineb/@BotDELTA]}}];

The triangulation induces a triangulation of the boundary , which is dual to a graph  and . 
Each triangle in the boundary is dual to a 3-valent node.
Each side of the triangles in the boundary is dual to a link of  and  node.

Show[BoundaryGraphicsTop,BoundaryGraphicsBot]

BulkGraphics=Graphics3D[{{LasagnaColor,Opacity[0.5],DELTA},{Darker[Green],Thick,lineT/@Subsets[DELTA,{2}]},
{Darker[Green],Thick,BoundaryLine/@Select[DELTA,IsOnTop]},
{Darker[Green],Thick,BoundaryLine/@Select[DELTA,IsOnBot]},{Black,PointSize[Large],center/@DELTA},{Red,PointSize[Large],center/@BotDELTA},{Red,PointSize[Large],center/@TopDELTA}}];

The triangulation in the bulk is dual to a 2-skeleton. 

Each tetrahedron is dual to a vertex.

Each triangle is dual to a edge connecting two vertices.

Each side of a tetrahedron is dual to a face.

Edges intersect the boundary in nodes and faces in links.

BulkGraphics

We can look at everything together

Show[BulkGraphics,BoundaryGraphicsTop,BoundaryGraphicsBot]

Transition amplitudes between geometries

We dress the triangulation with quantum numbers:
	
			a spin  to each face
	
			an intertwiner to each edge
	
At the boundary this association of quantum numbers identify a spin network state.

Show[BoundaryGraphicsBot]

The transition amplitude is defined by the association of a
			 face amplitude to each face 
	
			 edge amplitude to each edge 
	
	 	 vertex amplitude to each vertex 
	
The full transition amplitude between the two boundary states is a sum over all the possible bulk geometries

The Ponzano - Regge model - 1968

Quantum version of Regge calculus, a discrete formulation of General Relativity. The first state sum model for quantum gravity (Euclidean in 3D), also known as spin foam models. 

				 				
	
			
			

with
	
									   

The six spins are constrained by triangular inequalities.

Fortunately for us Mathematica have a compact (fast to evaluate) expression to compute the symbol.

SixJSymbol[{j1,j2,j3},{j4,j5,j6}]

Question

What is the connection with 3D Regge calculus?

Exercise

Study the scaling of the Ponzano-Regge vertex amplitude for a global rescaling

Experiment

Solution

Choose a set of 6 spins that satisfy triangular inequalities (without saturating them) and rescale them all together with a scale factor

{j1,j2,j3,j4,j5,j6}={3,3,3,2,2,2}

data=Table[{λ,SixJSymbol[{λ j1 ,λ j2,λ j3},{λ j4,λ j5,λ j6}]},{λ,1,200}];

ListPlot[data]

To deduce the rescaling we can look at the LOG LOG plot of the absolute value

ListLogLogPlot[Abs[data]]

We can try to eyeball a fit

Show[ListLogLogPlot[Abs[data]],LogLogPlot[0.15 x^{-3/2},{x,1,200},PlotStyle->Red]]

Exercise

Given six spins satisfying triangular inequalities reconstruct a tetrahedron with those edge lengths. Rescale the rescaling data by .

Experiment

Solution

v1={0,0,0};
v2={j1,0,0};
v3= {(((j1^2)-(j2^2)+(j3^2))/(2 j1)),((Sqrt[-(j1^4)+2 (j1^2) (j2^2)-(j2^4)+2 (j1^2) (j3^2)+2 (j2^2) (j3^2)-(j3^4)])/(2 j1)),0};
v4tmp={x,y,z};

v4=First[v4tmp/.Solve[{(v4tmp-v3).(v4tmp-v3)==j4^2,(v4tmp-v1).(v4tmp-v1)==j5^2,(v4tmp-v2).(v4tmp-v2)==j6^2,z≥0},{x,y,z}]];

Graphics3D[{LasagnaColor,Tetrahedron[{v1,v2,v3,v4}]}]

vol=Volume[Tetrahedron[{v1,v2,v3,v4}]];

datarescaled={First[#],Sqrt[12 π vol] First[#]^(3/2)Last[#]}&/@data;

ListPlot[datarescaled]

Exercise

Compute the Regge action for this tetrahedron.

Experiment

Solution

Normals[{v1_,v2_,v3_,v4_}]:= Module[{n1,n2,n3,n4},
n1 = Normalize[Cross[v3-v1,v2-v1]];
n2 = Normalize[Cross[v2-v1,v4-v1]];
n3 = Normalize[Cross[v4-v1,v3-v1]];
n4 = Normalize[Cross[v3-v2,v4-v2]];
Return[{n1,n2,n3,n4}]
]
LengthsAndDihedralAngles[{v1_,v2_,v3_,v4_}]:= Module[{n1,n2,n3,n4,edge1,edge2,edge3,edge4,edge5,edge6},
{n1,n2,n3,n4}=Normals[{v1,v2,v3,v4}];
edge1 ={Norm[v2-v1],VectorAngle[n1,n2]};
edge2 ={Norm[v3-v1],VectorAngle[n1,n3]};
edge3 ={Norm[v2-v3],VectorAngle[n1,n4]};
edge4 ={Norm[v4-v1],VectorAngle[n2,n3]};
edge5 ={Norm[v2-v4],VectorAngle[n2,n4]};
edge6 ={Norm[v3-v4],VectorAngle[n3,n4]};
Return[{edge1,edge2,edge3,edge4,edge5,edge6}]
]
S[λ_]:=Total[(First[#] λ +1/2)Last[#]&/@LengthsAndDihedralAngles[{v1,v2,v3,v4}]]

S[λ_]:= 3 (1/2 +2λ)ArcCos[1/7] + 3 (1/2 + 3λ)ArcCos[-Sqrt[3/7]]

Exercise

Compare the rescaled 6j symbol with the

Experiment

Solution

datacos=Table[{λ,Cos[S[λ]+π/4]},{λ,1,200}];

Show[{ListPlot[datarescaled],ListPlot[datacos,PlotMarkers->□,PlotStyle->Red]}]

Summary

For large spins if an euclidean tetrahedron with lengths given by those spins exists, then the vertex amplitude of the Ponzano Regge model reduces to

Path Integral of the 1D harmonic oscillator

Consider the 1D harmonic oscillator with mass m and frequency . 
	
	

The classical solution of the equation of motion that at time  is in  and at time  is in  is

xcl[t_,t1_,t2_,x1_,x2_] := x1 Sin[ω (t2-t)]/Sin[ω (t2-t1)]+x2 Sin[ω (t-t1)]/Sin[ω (t2-t1)]

The classical action between the times  and  is given by

Integrate[1/2 D[xcl[t,t1,t2,x1,x2] ,t]^2- 1/2 ω^2 xcl[t,t1,t2,x1,x2]^2,{t,t1,t2}]

Scl[t1_,t2_,x1_,x2_]:= 1/2 ω 1/Sin[ω (t2-t1)] ( (x1^2 + x2^2)Cos[ω(t2-t1)]-2 x1 x2)

For this very simple model the Path integral between time  and position  and the time  and position  is computable analytically (see Sakurai Eq. (2.5.18))

Kappa[t1_,t2_,x1_,x2_]:= Exp[I Scl[t1,t2,x1,x2]] Sqrt[ω/(2π I Sin[ω(t2-t1)])]

For simplicity set  and  and   (a quarter of period) and  where A is the amplitude of the classical oscillatory motion

{t1,t2,x1,x2}={0,π/(2ω),0,A}

xcl[t,t1,t2,x1,x2]

Kappa[t1,t2,x1,x2]

We can split the time interval in two equal part at a point x at time . We now ask ourself the following question. We know that the convolution of the path integral between ,  and ,  and the path integral between  ,  and ,  reproduce the path integral between ,  and , .

{t1,t2,x1,x2,tm}={0,π/(2ω),0,A,π/(4ω)}

$Assumptions={ω∈Reals,ω>0,A>0 ,A∈Reals};

FullSimplify[Integrate[Kappa[t1,tm,x1,x]Kappa[tm,t2,x,x2],{x,-∞,∞}]]

Is the main where is the main contribution to integral coming from? The integrand is non zero for all x.

integrand[x_]:=Kappa[t1,tm,x1,x]Kappa[tm,t2,x,x2];

FullSimplify[integrand[x]]

Plot[{Re[integrand[x]/.{A->1,ω->2}],Im[integrand[x]/.{A->1,ω->2}]},{x,-10,10},PlotStyle->ScientificForm,PlotTheme->"Scientific"]

Window[y_]:=Evaluate[Integrate[integrand[x],{x,y-1,y+1}]]

Plot[{Re[Window[y]/.{A->1,ω->2}],Im[Window[y]/.{A->1,ω->2}]},{y,-10,10},PlotRange->All,ImageSize->1200]

xclm = xcl[tm,t1,t2,x1,x2]/.{A->1,ω->2};

Plot[{Re[Window[y]/.{A->1,ω->2}],Im[Window[y]/.{A->1,ω->2}]},{y,-10,10},PlotRange->All,ImageSize->1200,Epilog->{Red,Line[{{xclm,-1},{xclm,1}}]}]

A 3 vertex computation in Ponzano Regge

The simplest triangulation with at least a bulk face.

{v1,v2,v3,v4,v5}={{0,0,0},{3,0,0},{(3/2),((3 (Sqrt[3]))/2),0},{(3/2),((Sqrt[3])/2),1},{(3/2),((Sqrt[3])/2),-(Sqrt[6])}};
DELTA={Tetrahedron[{v1,v2,v4,v5}],Tetrahedron[{v2,v3,v4,v5}],Tetrahedron[{v1,v3,v4,v5}]};

BulkGraphics=Graphics3D[{{LasagnaColor,Opacity[0.5],DELTA},{Darker[Green],Thickness[0.01],lineT/@Subsets[DELTA,{2}]},{Black,PointSize[0.02],center/@DELTA},{Red,Thickness[0.02],Line[{v4,v5}]}}]

The transition amplitude is

WD3=Sum[N[(-1)^x (2x+1)SixJSymbol[{j1,j5,j6},{x,j9,j8}]SixJSymbol[{j6,j2,j4},{j7,x,j9}]SixJSymbol[{j7,j8,j3},{j5,j4,x}],4],{x,Max[Abs[j6-j9],Abs[j5-j8],Abs[j7-j4]],Min[j6+j9,j5+j8,j4+j7]}];]

Exercise

What geometries are solution of the Regge classical equation of motion with this boundary data?

Experiment

Solution

Fixing the length

{j1,j2,j3,j4,j5,j6,j7,j8,j9}={3,3,3,2,2,2,3,3,3};

v1={0,0,0};
v2={j1,0,0};
v3= {(((j1^2)+(j2^2)-(j3^2))/(2j1)),(1/(2j1))(√(-(j1^4)+2 (j1^2) (j2^2)-(j2^4)+2(j1^2) (j3^2)+2 (j2^2)(j3^2)-(j3^4))),0};

v4top ={x,y,z};

We select the positive z solution to fix the orientation

v4=v4top/.First@Solve[{(v4top-v1).(v4top-v1)==j4^2,(v4top-v2).(v4top-v2)==j5^2,(v4top-v3).(v4top-v3)==j6^2,z>0},{x,y,z}];

v5top ={x,y,z};

We fixed the orientation therefore we need to consider both solutions

v5a=v5top/.First@Solve[{(v5top-v1).(v5top-v1)==j7^2,(v5top-v2).(v5top-v2)==j8^2,(v5top-v3).(v5top-v3)==j9^2,z<0},{x,y,z}]

v5b=v5top/.First@Solve[{(v5top-v1).(v5top-v1)==j7^2,(v5top-v2).(v5top-v2)==j8^2,(v5top-v3).(v5top-v3)==j9^2,z>0},{x,y,z}]

Grid[{{Graphics3D[{{Opacity[0.4],Blue,Tetrahedron[{v1,v2,v3,v4}],{Opacity[0.4],Red,Tetrahedron[{v1,v2,v3,v5a}]}}}],Graphics3D[{{Opacity[0.4],Blue,Tetrahedron[{v1,v2,v3,v4}],{Opacity[0.4],Red,Tetrahedron[{v1,v2,v3,v5b}]}}}]}}]

{x1,x2} = {Norm[v4-v5a],Norm[v4-v5b]}

Exercise

Classical geometries should dominate the path integral. How can we see it?

Experiment

Solution

We can apply the running sum technique we analyzed in the case of the 1D harmonic oscillator

WD3tab[j1_,j2_,j3_,j4_,j5_,j6_,j7_,j8_,j9_]:=Table[{x,N[(-1)^x (2x+1)SixJSymbol[{j1,j5,j6},{x,j9,j8}]SixJSymbol[{j6,j2,j4},{j7,x,j9}]SixJSymbol[{j7,j8,j3},{j5,j4,x}],4]},{x,Max[Abs[j6-j9],Abs[j5-j8],Abs[j7-j4]],Min[j6+j9,j5+j8,j4+j7]}];

Using the spins corresponding to the classical geometries we reconstructed in the previous exercise.

{j1,j2,j3,j4,j5,j6,j7,j8,j9}= {3,3,3,2,2,2,3,3,3}

{x1,x2}

Using a large scale factor

λ=500;

AbsoluteTiming[data=N@WD3tab[λ j1,λ j2,λ j3,λ j4,λ j5,λ j6,λ j7,λ j8,λ j9];]

ListPlot[data,PlotRange->All]

w=Round[(Sqrt[Length[data]]-1)/2]

min=Min[First/@data];
max=Max[First/@data];
tot=Last[Total[data]];

runningsum=Table[{data[[idx,1]],Total[Part[data,idx-w;;idx+w,2]]/tot},{idx,1+w,Length[data]-w}];
runningav=Table[{runningsum[[idx,1]],Total[Part[runningsum,idx-w;;idx+w,2]]/(2w+1)},{idx,1+w,Length[runningsum]-w}];

ListPlot[runningav,PlotRange->All,Epilog->{Red,Line[{{λ x1,-11},{λ x1,10}}],Line[{{λ x2,-11},{λ x2,10}}]}]