FusionAtlasPaths={"~/projects/fusionatlas/code/package/","~/Documents/math papers/fusionatlas/code/package/","~/Documents/Math/fusionatlas/code/package/","~/Documents/fusionatlas/code/package"};
$Path=$Path~Join~FusionAtlasPaths;
<<FusionAtlas`

(am=GraphAdjacencyMatrix[g=haagerupFamilyBigraph[7]])//MatrixForm

am[[9;;-1,9;;-1]]//MatrixForm

Eigensystem[am[[9;;-1,9;;-1]]]

p[x_]:=Evaluate[CharacteristicPolynomial[am,x]]

Factor[p[x]]

ReducedDimensionOfGenerator[haagerupFamilyBigraph[7]][[1]]

Clear[qIntegerδ]

qIntegerδ[k_Integer]:=qIntegerδ[k]=Function[{δ},Evaluate[Collect[δ qIntegerδ[k-1][δ]-qIntegerδ[k-2][δ],δ]]]
qIntegerδ[2]=#&;
qIntegerδ[1]=1&;
qIntegerδ[0]=0&;

qIntegerδ[8][δ]-(qIntegerδ[2][δ]+qIntegerδ[4][δ]+qIntegerδ[6][δ])

qIntegerδ[8][δ]-(qIntegerδ[2][δ]+qIntegerδ[4][δ]+qIntegerδ[6][δ])/.δ->Sqrt[2]

RootReduce[qIntegerδ[8][δ]-(qIntegerδ[2][δ]+qIntegerδ[4][δ]+qIntegerδ[6][δ])/.δ->DimensionOfGenerator[HaagerupBigraph]]

With[{k=7},qIntegerδ[k+5][δ]-(qIntegerδ[k-1][δ]+qIntegerδ[k+1][δ]+qIntegerδ[k+3][δ])/.δ->Sqrt[2]]

With[{k=7},qIntegerδ[k+5][δ]-(qIntegerδ[k-1][δ]+qIntegerδ[k+1][δ]+qIntegerδ[k+3][δ])/.δ->Sqrt[2]]

relation={0,-1,0,-1,0,-2,0,-1,0,-1,0,1};

p=Expand[relation.Table[qIntegerδ[k][δ],{k,1,Length[relation]}]]

%/.δ->DimensionOfGenerator[HaagerupAsaedaBigraph]

RootReduce[%]

DepthOfBranchPoint[HaagerupAsaedaBigraph]

Eigensystem[GraphAdjacencyMatrix[HaagerupAsaedaBigraph][[7;;-1,7;;-1]]]

p/.δ->Sqrt[3]

f[g_GradedBigraph,(1|2),-1]:=0
f[g_GradedBigraph,n:(1|2),0]:=V[n,0,1]

f[g_GradedBigraph,n:(1|2),k_Integer]/;k>0:=(f[g,n,k-1]/.V[n,d_,l_]:>If[d>0,(Transpose[g[[d]]].UnitVector[RankAtDepth[g,d],l]).Table[V[n,d-1,j],{j,1,RankAtDepth[g,d-1]}],0]+If[d<GraphDepth[g],(g[[d+1]].UnitVector[RankAtDepth[g,d],l]).Table[V[n,d+1,j],{j,1,RankAtDepth[g,d+1]}],0])-f[g,n,k-2]

fc[g_GradedBigraph,k_]:=f[g,1,k]/.V[1,d_,n_]:>UnitVector[GraphRank[g],Sum[RankAtDepth[g,l],{l,0,d-1}]+n]

relation[g_GradedBigraph]:=Module[{nullspace,j=0},
While[(nullspace=NullSpace[Transpose[Table[fc[g,k],{k,0,j}]]])=={},j++];
nullspace[[1]]
]

relation[HaagerupAsaedaBigraph]

p[g_GradedBigraph]:=Expand[relation[g].Table[qIntegerδ[k][δ],{k,1,Length[relation[g]]}]]

pm[g_GradedBigraph]:=Expand[relation[g].Table[qIntegerδ[k-1][δ],{k,1,Length[relation[g]]}]]

HaagerupSupertransitivityCondition[g_GradedBigraph]:=Function[{k},Evaluate[
Reduce[{Simplify[With[{λ=Max[Eigenvalues[GraphAdjacencyMatrix[g][[DepthOfBranchPoint[g]+2;;-1,DepthOfBranchPoint[g]+2;;-1]]]]},
qIntegerδ[k+1][λ](p[g]/.δ->λ)-qIntegerδ[k][λ](pm[g]/.δ->λ)
]/.qIntegerδ[m_][d_]:>With[{q=(q/.Solve[q+(q^(-1))==d,q][[1]])},(((q^m)-(q^(-m)))/(q-(q^(-1))))]]==0,k∈Integers},k]
]
]

HaagerupSupertransitivityCondition[HaagerupBigraph][k]

HaagerupSupertransitivityCondition[HaagerupAsaedaBigraph][k]