This notebook is intended as accompaniment for the article "Constructing the extended Haagerup planar algebra", Stephen Bigelow, Scott Morrison, Emily Peters, Noah Snyder, available from http://tqft.net/EH. Once the article is on the arXiv, you should also be able to obtain this notebook as part of the source download from the arXiv.

This notebook contains minimal explanation; you really should read the article first before diving in. This notebook is intended to allow you to verify our calculations, not explain the argument.

The code in this notebook is "standalone", although it follows the naming conventions and syntax of the FusionAtlas` mathematica package, which was indispensable in preparing what appears here.

Initialisation

If[$VersionNumber<7,
AlgebraicNumber;
Unprotect[Conjugate];
Conjugate[AlgebraicNumber[gen_,coeff_]]:=AlgebraicNumber[Conjugate[gen],coeff];
Protect[Conjugate];
]

g=GradedBigraph[{{1}},{{1}},{{1}},{{1}},{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{0,1}},{{1,0},{0,1}}];

First we define a few numeric parameters.

δ=DimensionOfGenerator[g]=RootReduce[(Sqrt[Root[-5+17 #1-8 ((#1)^2)+((#1)^3)&,3]])];

q=.;
q=RootReduce[q/.Solve[q+(q^(-1))==δ,q][[1]]];

Λ=RootReduce[Sqrt[2-(δ^2)]];
Λ=ToNumberField[Λ,Λ];

c=45255025+8115925 (Λ^2)-21516075 (Λ^4);

Clear[qi]
qi[n_]/;OddQ[n]:=qi[n]=ToNumberField[Sum[(q^k),{k,-n+1,n-1,2}],Λ]
qi[n_]/;EvenQ[n]:=qi[n]=δ ToNumberField[(δ^(-1))Sum[(q^k),{k,-n+1,n-1,2}],Λ]

The next 6 cells define the polynomials P, as described in the paper.

wordList={{0,0,0,0,0,0,0,1},{0,0,0,0,0,0,1,1},{0,0,0,0,0,1,0,1},{0,0,0,0,0,1,1,1},{0,0,0,0,1,0,0,1},{0,0,0,0,1,0,1,1},{0,0,0,1,0,0,0,1},{0,0,0,1,0,0,1,1},{0,0,0,1,0,1,0,1},{0,0,0,1,0,1,1,1},{0,0,0,1,1,0,1,1},{0,0,1,0,0,1,0,1},{0,0,1,0,0,1,1,1},{0,0,1,0,1,0,1,1},{0,0,1,0,1,1,0,1},{0,0,1,1,0,0,1,1},{0,0,1,1,0,1,1,1},{0,1,0,1,0,1,0,1},{0,1,0,1,0,1,1,1},{0,1,0,1,1,0,1,1},{0,1,1,1,0,1,1,1}};

polynomialList={9-(λ^2)-2 (λ^4),3 λ-(λ^3)-(λ^5),-9+(λ^2)+2 (λ^4),1,-3 λ-(λ^3)+(λ^5),-1+(λ^3),-9+(λ^2)+2 (λ^4),4-3 λ+(λ^2)-(λ^4)+(λ^5),1-2 (λ^2)+(λ^4),1-(λ^4),-3-(λ^2)+(λ^4),5-2 (λ^4),1+(λ^2),1+λ-(λ^3)-(λ^5),-λ+(λ^5),4 λ+5 (λ^3)+2 (λ^5),-5-λ-4 (λ^2)-2 (λ^3)-(λ^5),7+3 (λ^2)-4 (λ^4),(λ^2)+(λ^4),-4-2 (λ^2)+(λ^4),6+6 (λ^2)+(λ^4)};

Clear[P];Evaluate[(P@@@wordList)]=ToNumberField[#/.λ->Λ,Λ]&/@polynomialList;

P[_,_,_,_,1,1,1,1]=0;
P[0,0,0,0,0,0,0,0]=0;

P[x__Integer]/;FreeQ[{x},2]:=P[x]=Module[{rotations,rotoreflections,target,rotationNumber,conjugation},
rotations=Table[{RotateLeft[{x},k],{False,k}},{k,0,7}];
rotoreflections=Table[{RotateRight[Reverse[RotateLeft[{x},k]]],{True,k}},{k,0,7}];
{target,{conjugation,rotationNumber}}=SortBy[rotations~Join~rotoreflections,First][[1]];
(((-1))^rotationNumber)If[conjugation,ToNumberField[Conjugate[#],Λ]&,#&][(P@@target)]
]

P[x___Integer,2,y___Integer]:=P[x,2,y]=-P[x,0,y]-P[x,1,y]

P[{L___Integer}]:=P[L]

Verification

We now define several functions that verify several lemmas reported in the paper. Please refer to the paper for details

Verify2sVanish:=P[2,2,2,2,Sequence@@#]===0&/@Tuples[{0,1},4]

VerifyRotation:=
(P@@#+P@@RotateLeft[#])===0&/@Tuples[{0,1,2},8]

VerifyConjugation:=
P@@#-ToNumberField[Conjugate[P@@RotateRight[Reverse[#]]],Λ]==0&/@Tuples[{0,1,2},8]

VerifyTriplePointCondition:=
P[0,Sequence@@#]+P[1,Sequence@@#]+P[2,Sequence@@#]===0&/@Tuples[{0,1,2},7]

VerifyZλLattice:=IntegerQ/@Flatten[Last/@Solve[CoefficientList[#-Table[a[i],{i,1,6}].polynomialList[[{1,2,4,6,10,14}]],λ]==0,Table[a[i],{i,1,6}]][[1]]&/@polynomialList]

VerifyGraphSymmetry:=
(P@@#===ToNumberField[-Conjugate[(P@@(#/.{1->2,2->1}))],Λ])&/@Tuples[{0,1,2},8]

And@@VerifyGraphSymmetry//AbsoluteTiming

And@@VerifyZλLattice//AbsoluteTiming

And@@Verify2sVanish//AbsoluteTiming

And@@VerifyRotation//AbsoluteTiming

And@@VerifyTriplePointCondition//AbsoluteTiming

And@@VerifyConjugation//AbsoluteTiming

The extended Haagerup graph

The combinatorial structure.

evenVertices={v["v",0],v["x",0],v["z",0],v["b",0],v["b",1],v["b",2],v["z",1],v["z",2]};

oddVertices={v["w",0],v["y",0],v["a",0],v["a",1],v["a",2],v["c",0]};

nbhd[v["v",0]]:={v["w",0]}
nbhd[v["w",0]]:={v["v",0],v["x",0]}
nbhd[v["x",0]]:={v["w",0],v["y",0]}
nbhd[v["y",0]]:={v["x",0],v["z",0]}
nbhd[v["z",0]]:={v["y",0],v["a",0]}
nbhd[v["a",0]]:={v["z",0],v["b",0]}
nbhd[v["b",0]]:={v["a",0],v["c",0]}
nbhd[v["c",0]]:={v["b",0],v["b",1],v["b",2]}
nbhd[v["b",1]]:={v["c",0],v["a",1]}
nbhd[v["b",2]]:={v["c",0],v["a",2]}
nbhd[v["a",1]]:={v["b",1],v["z",1]}
nbhd[v["a",2]]:={v["b",2],v["z",2]}
nbhd[v["z",1]]:={v["a",1]}
nbhd[v["z",2]]:={v["a",2]}

We also need the dimensions of all the vertices of the extended Haagerup graph.

{dim[v["v",0]],dim[v["w",0]],dim[v["x",0]],dim[v["y",0]],dim[v["z",0]],dim[v["a",0]],dim[v["b",0]],dim[v["c",0]],dim[v["b",1]],dim[v["b",2]],dim[v["a",1]],dim[v["a",2]],dim[v["z",1]],dim[v["z",2]]}=(*Flatten[ReducedDimensionsByDepth[g]]=*){1,Root[-5+17 ((#1)^2)-8 ((#1)^4)+((#1)^6)&,6],Root[5+4 #1-5 ((#1)^2)+((#1)^3)&,3],Root[-125+160 ((#1)^2)-31 ((#1)^4)+((#1)^6)&,6],Root[-1+14 #1-9 ((#1)^2)+((#1)^3)&,3],Root[-125+220 ((#1)^2)-97 ((#1)^4)+((#1)^6)&,6],Root[-1+9 #1-14 ((#1)^2)+((#1)^3)&,3],Root[-125+415 ((#1)^2)-331 ((#1)^4)+((#1)^6)&,6],Root[-5-16 #1-11 ((#1)^2)+((#1)^3)&,3],Root[-5-16 #1-11 ((#1)^2)+((#1)^3)&,3],Root[-5+38 ((#1)^2)-59 ((#1)^4)+((#1)^6)&,6],Root[-5+38 ((#1)^2)-59 ((#1)^4)+((#1)^6)&,6],Root[1+#1-4 ((#1)^2)+((#1)^3)&,3],Root[1+#1-4 ((#1)^2)+((#1)^3)&,3]};

For convenience, we' ll push these into Q[Λ] or δ Q[Λ], as well.

(dim[#]=ToNumberField[dim[#],Λ])&/@evenVertices

(dim[#]=δ ToNumberField[dim[#]/δ,Λ])&/@oddVertices

Paths and loops

pathsFrom[from_,0]:={{from}}
pathsFrom[from_,k_]:=pathsFrom[from,k]=Flatten[(Function[{end},#~Join~{end}]/@nbhd[#[[-1]]])&/@pathsFrom[from,k-1],1]

pathsBetween[from_,to_,k_]:=pathsBetween[from,to,k]=Cases[pathsFrom[from,k],γ_/;γ[[-1]]==to]

Beware of a subtle danger here:  pathsBetween[b, a, k] doesn' t just return the paths in pathsBetween[a, b, k], reversed, it returns them reversed and in a different order.

loopsBetween[from_,to_,k_]:=loopsBetween[from,to,k]=Flatten[Outer[Most[#1]~Join~Most[#2]&,pathsBetween[from,to,k],pathsBetween[from,to,k],1],1]

Generator

We now use the rule described in the paper to define the value of S on any loop of length 16.

First the various fudge factors.

σ[v["v"|"w"|"z"|"a",_]]:=-1
σ[v["x"|"y"|"b"|"c",_]]:=1
σ[γ_List]:=Times@@(σ/@γ)

hat[γ_List]:=γ[[1;;16;;2,2]]

dimensionFactor[γ_List]:=(1/(Sqrt[dim[γ[[1]]] dim[γ[[9]]]]))(1/(Sqrt[Product[dim[γ[[i]]],{i,1,16}]]))

And give the full definition of S, and of Srect.

S[γ_]:=c σ[γ]P[hat[γ]]dimensionFactor[γ]

Clear[Smatrix]
Smatrix[from_,to_]:=Smatrix[from,to]=Outer[S[Most[#1]~Join~Most[Reverse[#2]]]&,pathsBetween[from,to,8],pathsBetween[from,to,8],1]

Example

pathsBetween[v["v",0],v["b",1],8]

path={v["v",0],v["w",0],v["x",0],v["y",0],v["z",0],v["a",0],v["b",0],v["c",0],v["b",1],v["c",0],v["b",0],v["a",0],v["z",0],v["y",0],v["x",0],v["w",0]};

hat[path]

S[path]

S[path]

RootReduce[%]

Smatrix[v["v",0],v["v",0]]

Smatrix[v["v",0],v["b",1]]

The conjugated matrices

cachedToNumberField[x_,λ_]:=cachedToNumberField[x,λ]=ToNumberField[x,λ]

fastToNumberField[x_,λ_]:=ToNumberField[x/.((r_Root)^(k_.)):>cachedToNumberField[(r^k),λ],λ]

Clear[ASAi];
ASAi[from_,to_]:=ASAi[from,to]=Outer[
With[
{loop=Most[#1]~Join~Most[Reverse[#2]]},
c σ[loop]P[hat[loop]] fastToNumberField[(((Times@@(dim/@#2)))^(-1)),Λ]
]&,pathsBetween[from,to,8],pathsBetween[from,to,8],1]

ASAi[v["v",0],v["b",1]]

Clear[twistedASAi];
twistedASAi[from_,to_]:=twistedASAi[from,to]=Outer[
With[
{loop=Most[#1]~Join~Most[Reverse[#2]]},
c σ[loop]P[hat[RotateRight[loop]]] fastToNumberField[(δ^(-1))(((Times@@(dim/@#2)))^(-1)),Λ]
]&,pathsBetween[from,to,8],pathsBetween[from,to,8],1]

oddVertices

twistedASAi[v["w",0],v["a",1]]

Computing moments

traceWeight[from_,to_]:=fastToNumberField[((dim[to])/(dim[from])),Λ]

Moment[m_]:=Moment[m]=Table[Sum[
progress={i,j};
traceWeight[evenVertices[[i]],evenVertices[[j]]]*
 With[{M=ASAi[evenVertices[[i]],evenVertices[[j]]]},
If[Length[M]>0,
If[m==0,
Length[M],
Tr[Dot@@Table[M,{m}]]
],
0
]
],{j,1,Length[evenVertices]}],
{i,1,Length[evenVertices]}]

TwistedMoment[m_]:=TwistedMoment[m]=Table[(δ^m)ToNumberField[Sum[
progress={i,j};
traceWeight[oddVertices[[i]],oddVertices[[j]]]*
 With[{M=twistedASAi[oddVertices[[i]],oddVertices[[j]]]},
If[Length[M]>0,
If[m==0,
Length[M],
Tr[Dot@@Table[M,{m}]]
],
0
]
],{j,1,Length[oddVertices]}],Λ],
{i,1,Length[oddVertices]}]

Dynamic[progress]

Warm up the engines, by computing the 0th moment. This prepares all the conjugated matrices, so takes a while.   For reference, none of the other calculations take significantly longer than this one.

Moment[0]-ToNumberField[((qi[2])^8),Λ]//AbsoluteTiming

The first moment better be zero, because even the first partial trace is zero.

Moment[1]//AbsoluteTiming

Now compute the four moments we' re after.

Moment[2]-qi[9]//AbsoluteTiming

Moment[3]//AbsoluteTiming

Moment[4]-qi[9]//AbsoluteTiming

TwistedMoment[0]-ToNumberField[((qi[2])^8),Λ]//AbsoluteTiming

TwistedMoment[1]//AbsoluteTiming

RootReduce[TwistedMoment[2]+qi[9]]//AbsoluteTiming

RootReduce[TwistedMoment[2]+qi[9]]

TwistedMoment[3]//AbsoluteTiming

RootReduce[(TwistedMoment[3]-I ((qi[18])/(Sqrt[qi[8]qi[10]])))]

TwistedMoment[4]//AbsoluteTiming

RootReduce[TwistedMoment[4]-ToNumberField[qi[9](((qi[8])/(qi[10]))-1+((qi[10])/(qi[8]))),Λ]]

{0,0,0,0,0,0}