QuantumGroupsPath = "~/projects/QuantumGroups/trunk/package/";
AppendTo[$Path, QuantumGroupsPath];
<<QuantumGroups`

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

AlcoveDimensions[Γ_,level_]:=
RootReduce[ExpToTrig[(qDimension[Γ][Irrep[Γ][#]]/.q->Exp[2π I/RootFromLevel[Γ,level]])]]&/@AlcoveWeights[Γ,RootFromLevel[Γ,level]]

ToRadicals[((DimensionOfGenerator[haagerupFamilyBigraph[7]])^2)]

ToRadicals[ReducedDimensionsByDepth[haagerupFamilyBigraph[7]]]

EHdims=Flatten[%];

RootReduce[ToRadicals[ReducedDimensionsByDepth[haagerupFamilyBigraph[7]]]/((8/3)+((2 (13^(2/3)))/(3 ((((1/2) (5+3 I (Sqrt[3]))))^(1/3))))+(1/3) (2^(2/3)) (((13 (5+3 I (Sqrt[3]))))^(1/3)))]

RootReduce[(1/2)((8/3)+((2 (13^(2/3)))/(3 ((((1/2) (5+3 I (Sqrt[3]))))^(1/3))))+(1/3) (2^(2/3)) (((13 (5+3 I (Sqrt[3]))))^(1/3)))-ToRadicals[ReducedDimensionsByDepth[haagerupFamilyBigraph[7]]]]

RootFromLevel[F4,4]

Table[Length[AlcoveWeights[F4,k]],{k,1,52}]

{{#},SteinbergDecomposeRepresentation[F4,52][Irrep[F4][#]⊗Irrep[F4][{0,0,0,1}]]}&/@AlcoveWeights[F4,52]//TableForm

GradedBigraphFromQuantumGroup[Γ_,l_,V_]:=
With[{t=SteinbergDecomposeRepresentation[Γ,l][#⊗V]&},
Module[{irrepsAtDepth,depth},
irrepsAtDepth[0]={Irrep[Γ][ZeroVector[Rank[Γ]]]};
irrepsAtDepth[1]={V};
irrepsAtDepth[k_]:=irrepsAtDepth[k]=Complement[Union[Cases[t/@irrepsAtDepth[k-1],Irrep[Γ][_],∞]],irrepsAtDepth[k-2]];
irrepsAtDepth[All]=TakeWhile[Table[irrepsAtDepth[k],{k,0,2Length[AlcoveWeights[Γ,l]]+1}],Length[#]>0&];
depth=Length[irrepsAtDepth[All]]-1;
GradedBigraph@@((Outer[Function[{Z,W},Count[t[Z],W,{0,∞}]],#[[2]],#[[1]]]&/@Partition[irrepsAtDepth[All],2,1]))
]
]

GradedBigraphFromQuantumGroup[A1,14,Irrep[A1][{1}]]

DisplayBigraph[GradedBigraphFromQuantumGroup[A1,14,Irrep[A1][{1}]]]

g=GradedBigraphFromQuantumGroup[F4,52,Irrep[(Subscript[F, 4])][{0,0,0,1}]]

CheckDimension[Γ_,l_,V_,z_:1]:=RootReduce[DimensionOfGenerator[GradedBigraphFromQuantumGroup[Γ,l,V]]-(qDimension[Γ][V]/.q->RootReduce[ExpToTrig[Exp[2π I z/l]]])]==0

CheckDimension[G2,26,Irrep[G2][{1,0}],23]

LevelFromRoot[G2,26]

DisplayBigraph[GradedBigraphFromQuantumGroup[G2,26,Irrep[G2][{1,0}]]]

DisplayBigraph[F4subfactor=GradedBigraphFromQuantumGroup[F4,52,Irrep[F4][{0,0,0,1}]]]

DisplayBigraph[GradedBigraphFromQuantumGroup[F4,52,Irrep[F4][#]]]&/@AlcoveWeights[F4,52][[{2,3,8,-1}]]

F4dims=ToRadicals[AlcoveDimensions[F4,4]]

Sort[Chop[N[F4dims]]]

Sort[Chop[N[Sqrt[#+1]&/@F4dims]]]

Sort[Chop[N[F4dims/2]]]

Sort[Chop[N[EHdims]]]

N@GlobalEvenDimension[F4subfactor]

N@GlobalEvenDimension[haagerupFamilyBigraph[7]]