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`

G[k_]:=GradedBigraph[{{1}},{{1},{1},{1}},{{0,1,0}}]~Join~AnBigraph[k]~Join~GradedBigraph[{{1},{1},{1}}]

Table[DisplayBigraph[G[k]],{k,1,3}]

ListPlot[Table[N[DimensionOfGenerator[G[k]]],{k,1,30}],"PlotJoined"->True,PlotRange->All]

Table[N@DimensionsByDepth[G[k]],{k,1,10}]//TableForm

Clear[RelativeDimensions]

RelativeDimensions[g_GradedBigraph,δ_,st_:False]:=RelativeDimensions[g,δ]=Module[{dimensions,dimensionsAtDepth,k},
dimensions=Flatten[Table[d[depth,k],{depth,0,GraphDepth[g]},{k,1,RankAtDepth[g,depth]}]];
dimensionsAtDepth=Table[d[GraphDepth[g],k],{k,1,RankAtDepth[g,GraphDepth[g]]}];
dimensions=Simplify[dimensions/.Solve[{d[0,1]-1}~Join~Drop[Drop[GraphAdjacencyMatrix[g].dimensions-δ dimensions,-RankAtDepth[g,GraphDepth[g]]],If[st,1,0]]==0,dimensions,Complement[dimensions,dimensionsAtDepth]][[1]]]
]

RelativeDimensions[HaagerupBigraph,δ,True]

RelativeDimensions[BigraphWithDuals[g_GradedBigraph,dd_DualData],δ_,st_:False]:=Module[
{dimensions=RelativeDimensions[g,δ,st],dimensionsByDepth,R=0,equations,solutions,k},
dimensionsByDepth=Table[Take[dimensions,{R+1,R+=RankAtDepth[g,k]}],{k,0,GraphDepth[g]}];
equations=Flatten[Table[Collect[dimensionsByDepth[[2i-1]]-dimensionsByDepth[[2i-1]][[dd[[i]]]],_d,Together],{i,1,Length[dd]}]];
solutions=DeleteCases[Solve[{equations==0},Cases[dimensions,_d,∞]],({___,δ->δ0_,___}/;RootReduce[δ0]≤2)|({___,_->x_?NumericQ,___}/;RootReduce[x]<1)];
{Simplify[dimensions/.If[Length[solutions]==1,solutions[[1]],{}]],solutions}
]

RelativeDimensionsByDepth[badSeeds[[4,1]],δ,True][[1]]

d=.

{g,dd}=List@@badSeeds[[4,1]];

dd

dimensions=RelativeDimensions[g,δ,True];R=0;
dimensionsByDepth=Table[Take[dimensions,{R+1,R+=RankAtDepth[g,k]}],{k,0,GraphDepth[g]}];
equations=Flatten[Table[Collect[dimensionsByDepth[[2i-1]]-dimensionsByDepth[[2i-1]][[dd[[i]]]],_d,Together],{i,1,Length[dd]}]]

solutions=DeleteCases[Solve[{equations==0},Cases[dimensions,_d,∞]],({___,δ->δ0_,___}/;RootReduce[δ0]≤2)|({___,_->x_?NumericQ,___}/;RootReduce[x]<1)]

RelativeDimensions[badSeeds[[4,1,1]],δ,True]

ChopList[l_,k:{__Integer}]:=Module[{r=0},l[[(r+1);;(r+=#)]]&/@k]

RelativeDimensionsByDepth[g_GradedBigraph,a__]:=ChopList[RelativeDimensions[g,a],Length/@DimensionsByDepth[g]]
RelativeDimensionsByDepth[g_BigraphWithDuals,a__]:=With[{reld=RelativeDimensions[g,a]},{ChopList[reld[[1]],Length/@DimensionsByDepth[g[[1]]]],reld[[2]]}]

RelativeDimensionsByDepth[HaagerupWithDuals,δ,True]

RelativeDimensions[HaagerupAsaedaBigraph,δ]

DisplayBigraph[HaagerupAsaedaBigraph]

Clear[qIntegerδ];
qIntegerδ[0]=0;
qIntegerδ[1]=1;
qIntegerδ[2]=δ;
qIntegerδ[k_Integer]/;k≥3:=qIntegerδ[k]=Expand[δ qIntegerδ[k-1]-qIntegerδ[k-2]]

qIntegerδ[5]

DepthOfBranchPoint[BigraphWithDuals[g_GradedBigraph,_DualData]]:=DepthOfBranchPoint[g]

DepthOfBranchPoint[HaagerupAsaedaWithDuals]

g=HaagerupAsaedaWithDuals;

Clear[cλ]

cλ[g_BigraphWithDuals,extension_]:=Module[{branch,r,depth,dimensions,solutions},
depth=DepthOfBranchPoint[g];
dimensions=qIntegerδ[extension+1]RelativeDimensionsByDepth[g,δ,True][[1]];
solutions=DeleteCases[Solve[dimensions[[2,1]]==qIntegerδ[extension+2],Cases[dimensions[[2]],_d]],{___,δ->δ0_/;δ0≤2,___}];
Print[solutions];
If[Length[solutions]==1,dimensions=dimensions/.solutions[[1]]];
branch=dimensions[[depth+2]];
r=branch[[2]]/branch[[1]];
Print[r];
Simplify[(r+(r^(-1))-2)qIntegerδ[depth+1+extension]qIntegerδ[depth+3+extension]-2]
]

cλ[HaagerupAsaedaWithDuals,k]

f=Simplify[%]

f=Together[f-2/.qIntegerδ[x_]:>(((q^x)-(q^(-x)))/(q-(q^(-1))))/.δ->q+(q^(-1))]

Plot[(1-4 (q^(4+2 k))-4 (q^(8+2 k))+4 (q^(10+2 k))-(q^(12+2 k))+8 (q^(14+2 k))-(q^(16+2 k))+4 (q^(18+2 k))-4 (q^(20+2 k))-4 (q^(24+2 k))+(q^(28+4 k)))/.k->1,{q,1,1.3}]

N@Solve[q+(q^(-1))==Sqrt[(5+Sqrt[17])/2],q]

Expand[(1-4 (q^(4+2 k))-4 (q^(8+2 k))+4 (q^(10+2 k))-(q^(12+2 k))+8 (q^(14+2 k))-(q^(16+2 k))+4 (q^(18+2 k))-4 (q^(20+2 k))-4 (q^(24+2 k))+(q^(28+4 k)))/(q^(14+2k))]

D[%,q]

N[%]

cλ[badSeeds[[4,1]],k]

-2+(((((-2+8 (δ^2)-6 (δ^4)+(δ^6)))^2) ((d[7,3])^2) qIntegerδ[4+k] qIntegerδ[6+k])/((2 δ-3 (δ^3)+(δ^5)+d[7,3]-4 (δ^2) d[7,3]+8 (δ^4) d[7,3]-5 (δ^6) d[7,3]+(δ^8) d[7,3]) (2 δ-3 (δ^3)+(δ^5)-d[7,3]+4 (δ^2) d[7,3]+2 (δ^4) d[7,3]-4 (δ^6) d[7,3]+(δ^8) d[7,3])))/.d[7,3]->(1/4) (9 δ-2 (δ^3)-((32 qIntegerδ[1+k])/(5 δ qIntegerδ[1+k]-2 (δ^3) qIntegerδ[1+k]))+((11 (δ^2) qIntegerδ[1+k])/(5 δ qIntegerδ[1+k]-2 (δ^3) qIntegerδ[1+k]))-((80 qIntegerδ[1+k] qIntegerδ[2+k])/(((5 δ qIntegerδ[1+k]-2 (δ^3) qIntegerδ[1+k]))^2))+((32 (δ^2) qIntegerδ[1+k] qIntegerδ[2+k])/(((5 δ qIntegerδ[1+k]-2 (δ^3) qIntegerδ[1+k]))^2))+((72 δ qIntegerδ[2+k])/(5 δ qIntegerδ[1+k]-2 (δ^3) qIntegerδ[1+k]))-((80 (δ^3) qIntegerδ[2+k])/(5 δ qIntegerδ[1+k]-2 (δ^3) qIntegerδ[1+k]))+((32 (δ^5) qIntegerδ[2+k])/(5 δ qIntegerδ[1+k]-2 (δ^3) qIntegerδ[1+k]))-((4 (δ^7) qIntegerδ[2+k])/(5 δ qIntegerδ[1+k]-2 (δ^3) qIntegerδ[1+k])))

f=Simplify[%]

f=Together[f-2/.qIntegerδ[x_]:>(((q^x)-(q^(-x)))/(q-(q^(-1))))/.δ->q+(q^(-1))]

Denominator[f]

Expand[(-1-3 (q^2)-2 (q^4)-2 (q^6)-2 (q^8)-(q^10)+(q^(10+2 k))+2 (q^(12+2 k))+2 (q^(14+2 k))+2 (q^(16+2 k))+3 (q^(18+2 k))+(q^(20+2 k)))/(q^(10+k))]

Expand[ (-(q^(4+2 k))+(q^(10+2 k))+2 (q^(14+2 k))-(q^(16+2 k))-(q^(18+2 k))+(q^(14+4 k))+(q^(16+4 k))-2 (q^(18+4 k))-(q^(22+4 k))+(q^(28+4 k)))/(q^(16+3k))]

Expand[Numerator[f]/(q^(26+4k))]

Plot[Numerator[f]/.k->6,{q,1,1.5}]

f/.k->6

1.4425737404460597`+((1.4425737404460597`)^(-1))

Plot[%,{q,1,Sqrt[5]}]

Limit[%,q->∞]

cλ[badSeeds[[1,1]],0]

cλ[g,0]

Reduce[-2≤cλ[g,0]≤2∧δ≥2]

Reduce[-2≤cλ[g,3]≤2∧δ≥2]

RelativeDimensions[badSeeds[[2,1]],δ,True]

Reduce[-2≤cλ[badSeeds[[1,1]],0]≤2(*∧DimensionOfGenerator[badSeeds[[1,1,1]]]≤δ*)]

N[%]

Reduce[-2≤cλ[badSeeds[[2,1]],0]≤2(*∧DimensionOfGenerator[badSeeds[[2,1,1]]]≤δ*)]

cλ[badSeeds[[3,1]],0]

Reduce[-2≤cλ[badSeeds[[4,1]],0]≤2(*∧DimensionOfGenerator[badSeeds[[4,1,1]]]≤δ*)]

N[%]

Reduce[-2≤cλ[badSeeds[[4,1]],2]≤2]

N[%]

N@DimensionOfGenerator[Join[AnBigraph[3],badSeeds[[4,1,1]]]]

Reduce[cλ[badSeeds[[4,1]],2]==2∧δ≥2,δ]

N[%]

Reduce[cλ[badSeeds[[4,1]],2]==2Cos[2π I/3]∧δ≥2,δ]

N[%]

Reduce[cλ[badSeeds[[4,1]],2]==-2Cos[2π I/3]∧δ≥2,δ]

Reduce[cλ[badSeeds[[4,1]],2]==-2∧δ≥2,δ]

N[%]

Reduce[-2≤cλ[badSeeds[[4,1]],4]≤2]

N[%]

N@DimensionOfGenerator[badSeeds[[4,1,1]]]

Reduce[cλ[badSeeds[[4,1]],4]==2∧δ≥2,δ]

N[%]

Reduce[cλ[badSeeds[[4,1]],4]==2Cos[2π I/4]∧δ≥2,δ]

N[%]

Reduce[cλ[badSeeds[[4,1]],4]==0∧δ≥2,δ]

N[%]

Reduce[cλ[badSeeds[[4,1]],4]==-2Cos[2π I/4]∧δ≥2,δ]

Reduce[cλ[badSeeds[[4,1]],4]==-2∧δ≥2,δ]

N[%]

foo=cλ[badSeeds[[4,1]],10]

DimensionOfGenerator[badSeeds[[4,1,1]]]

Simplify[Expand[foo/.δ->x+DimensionOfGenerator[badSeeds[[4,1,1]]]]]

cλ[badSeeds[[4,1]],k]

RootReduce[Reduce[-2<=cλ[badSeeds[[4,1]],6]≤2∧2≤δ,δ]]

RootReduce[Reduce[-2<=cλ[badSeeds[[4,1]],8]≤2∧2≤δ,δ]]

RootReduce[Reduce[-2<=cλ[badSeeds[[4,1]],10]≤2∧2≤δ,δ]]

RootReduce[Reduce[-2<=cλ[badSeeds[[4,1]],12]≤2∧2≤δ,δ]]

RootReduce[Reduce[-2<=cλ[badSeeds[[4,1]],14]≤2∧2≤δ,δ]]

N@RootReduce[Reduce[-2<=cλ[badSeeds[[4,1]],34]≤2∧2≤δ,δ]]

Simplify[cλ[badSeeds[[4,1]],34]]

N[%]

N[%]

RootReduce[%]

N@DimensionOfGenerator[badSeeds[[1,1,1]]]

N[%]

N[%]

Plot[cλ,{δ,2,Sqrt[5]},PlotRange->All]

RelativeDimensionsByDepth[HaagerupAsaedaWithDuals,δ,False]

Plot[(1/(-3+24 (δ^2)-47 (δ^4)+34 (δ^6)-10 (δ^8)+(δ^10))),{δ,2.1,2.2},PlotRange->All]

Reduce[1<(1/(-3+24 (δ^2)-47 (δ^4)+34 (δ^6)-10 (δ^8)+(δ^10))),δ]

N[%]

RelativeDimensions[DualHaagerupAsaedaWithDuals,δ,True]

DisplayBigraph[G[2]]

RelativeDimensions[G[2],δ]

Clear[LeastBimoduleCompatibleExtensionDimension]

LeastBimoduleCompatibleExtensionDimension[g_GradedBigraph]:=LeastBimoduleCompatibleExtensionDimension[g,3]

LeastBimoduleCompatibleExtensionDimension[g_GradedBigraph,k_]/;k≥3:=LeastBimoduleCompatibleExtensionDimension[g,k]=Module[{δ,constraints},
constraints=BimoduleCompatibleExtensionDimensions[g,k][δ];
If[constraints===False,∞,
Block[{$MaxPrecision=200},
δ/.Minimize[{δ,constraints},{δ}][[2]]
]
]
]

Clear[BimoduleCompatibleExtensionDimensions]

BimoduleCompatibleExtensionDimensions[g_GradedBigraph,k_]/;k≥3:=BimoduleCompatibleExtensionDimensions[g,k]=
Function[{δ},Evaluate[
Module[{reld,result,positivity},
DebugPrint["beginning BimoduleCompatibleExtensionDimensions[",g,",",k,"] ..."];
Block[{$MaxPrecision=200},
reld=Cases[RelativeDimensions[g,δ],dim_/;FreeQ[dim,d]];
positivity=Fold[Reduce[#1∧#2]&,True,{δ≥ReducedDimensionOfGenerator[g]}~Join~(#≥1&/@reld)];
reld=Cases[reld,dim_/;Minimize[{dim,δ≥ReducedDimensionOfGenerator[g]∧positivity},{δ}][[1]]≤2];
result=Fold[Reduce[#1∧#2,{δ},Reals]&,True,{δ≥ReducedDimensionOfGenerator[g],positivity}~Join~((Or@@Table[#==RootReduce[2Cos[(π/l)]],{l,3,k-1}]∨2≥#≥RootReduce[2Cos[(π/k)]]∨#==Root[3-5 ((#1)^2)+((#1)^4)&,4]∨#==Root[2-5 ((#1)^2)+((#1)^4)&,4]∨#==Root[-5+17 ((#1)^2)-8 ((#1)^4)+((#1)^6)&,6]∨#≥Sqrt[3+Sqrt[3]])&/@reld)];
];
DebugPrint["... finished BimoduleCompatibleExtensionDimensions[",g,",",k,"]"];
result
]
]
]

Clear[BimoduleCompatibleExtensionDimensions2]

BimoduleCompatibleExtensionDimensions2[g_GradedBigraph,max_,k_]/;k≥3:=BimoduleCompatibleExtensionDimensions2[g,max,k]=
Function[{δ},Evaluate[
Module[{reld,result,positivity,vars},
DebugPrint["beginning BimoduleCompatibleExtensionDimensions[",g,",",k,"] ..."];
Block[{$MaxPrecision=200},
reld=RelativeDimensions[g,δ];
vars={δ}~Join~Union[Cases[reld,_d,∞]];
positivity=Fold[Reduce[#1∧#2]&,True,{δ≤max,δ≥ReducedDimensionOfGenerator[g]}~Join~(#≥1&/@reld)];
reld=Cases[reld,dim_/;Minimize[{dim,δ≥ReducedDimensionOfGenerator[g]∧positivity},vars][[1]]≤2];
result=Fold[Reduce[#1∧#2,vars,Reals]&,True,{δ≥ReducedDimensionOfGenerator[g],positivity}~Join~((Or@@Table[#==RootReduce[2Cos[(π/l)]],{l,3,k-1}]∨2≥#≥RootReduce[2Cos[(π/k)]]∨#==Root[3-5 ((#1)^2)+((#1)^4)&,4]∨#==Root[2-5 ((#1)^2)+((#1)^4)&,4]∨#==Root[-5+17 ((#1)^2)-8 ((#1)^4)+((#1)^6)&,6]∨#≥Sqrt[3+Sqrt[3]])&/@reld)];
];
DebugPrint["... finished BimoduleCompatibleExtensionDimensions[",g,",",k,"]"];
result
]
]
]

LeastBimoduleCompatibleExtensionDimension2[g_GradedBigraph,max_,k_]/;k≥3:=LeastBimoduleCompatibleExtensionDimension2[g,max,k]=Module[{δ,constraints},
constraints=BimoduleCompatibleExtensionDimensions2[g,max,k][δ];
If[constraints===False,∞,
Block[{$MaxPrecision=200},
δ/.Minimize[{δ,constraints},{δ}~Join~Union[Cases[constraints,_d,∞]]][[2]]
]
]
]

graph=GraphFromString["gbg1v1p1v0x1p1x0p0x1v0x1x0p0x1x0p0x0x1v0x1x0p0x1x0p1x0x0p0x0x1p0x0x1"]

DisplayBigraph[Take[graph,4]]

g=Take[graph,3];

reld=RelativeDimensions[g,δ]

vars={δ}~Join~Union[Cases[reld,_d,∞]]

positivity=Fold[Reduce[#1∧#2]&,True,{δ≤Sqrt[5],δ≥ReducedDimensionOfGenerator[g]}~Join~(#≥1&/@reld)]

reld=Cases[reld,dim_/;Minimize[{dim,δ≥ReducedDimensionOfGenerator[g]∧positivity},vars][[1]]≤2]

N@Table[DimensionsByDepth[AnBigraph[2k]][[k,1]],{k,1,5}]

N[Sqrt[5]]

N[Sqrt[6]]

result=Fold[Reduce[#1∧#2,vars,Reals]&,True,{δ≥ReducedDimensionOfGenerator[g],positivity}~Join~((Or@@Table[#==RootReduce[2Cos[(π/l)]],{l,3,k-1}]∨2≥#≥RootReduce[2Cos[(π/k)]]∨#==Root[3-5 ((#1)^2)+((#1)^4)&,4]∨#==Root[2-5 ((#1)^2)+((#1)^4)&,4]∨#==Root[-5+17 ((#1)^2)-8 ((#1)^4)+((#1)^6)&,6]∨#≥Sqrt[3+Sqrt[3]])&/@reld)]

BimoduleCompatibleExtensionDimensions2[g,Sqrt[5],3][δ]

BimoduleCompatibleExtensionDimensions2[g,Sqrt[5],4][δ]

BimoduleCompatibleExtensionDimensions2[g,Sqrt[5],5][δ]

BimoduleCompatibleExtensionDimensions2[g,Sqrt[5],6][δ]

Minimize[{δ,%169},vars]

N[%]

N[Sqrt[5]]

N[Sqrt[3+Sqrt[3]]]

BimoduleCompatibleExtensionDimensions2[g,Sqrt[5],6][δ]

LeastBimoduleCompatibleExtensionDimension2[g,Sqrt[5],6]

N[%]

DimensionOfGenerator[HaagerupBigraph]

ReducedDimensionOfGenerator[HaagerupAsaedaBigraph]

ReducedDimensionOfGenerator[haagerupFamilyBigraph[7]]

Clear[GenericBimoduleExtensionDimensions];

GenericBimoduleExtensionDimensions[g_GradedBigraph]:=GenericBimoduleExtensionDimensions[g]=
Function[{δ},Evaluate[
Module[{reld,result,positivity},
DebugPrint["beginning GenericBimoduleExtensionDimensions[",g,"] ..."];
Block[{$MaxPrecision=200},
reld=Cases[RelativeDimensions[g,δ],dim_/;FreeQ[dim,d]];
positivity=Fold[Reduce[#1∧#2]&,True,{δ≥ReducedDimensionOfGenerator[g]}~Join~(#≥1&/@reld)];
reld=Cases[reld,dim_/;Minimize[{dim,δ≥ReducedDimensionOfGenerator[g]∧positivity},{δ}][[1]]≤2];
result=Fold[Reduce[#1∧#2,{δ},Reals]&,True,{δ≥ReducedDimensionOfGenerator[g],positivity}~Join~((#==1∨#≥2)&/@reld)];
];
DebugPrint["... finished GenericBimoduleExtensionDimensions[",g,"]"];
result
]
]
]

Clear[LeastGenericBimoduleExtensionDimension]

LeastGenericBimoduleExtensionDimension[g_GradedBigraph]:=LeastGenericBimoduleExtensionDimension[g]=Module[{δ,constraints},
constraints=GenericBimoduleExtensionDimensions[g][δ];
If[constraints===False,∞,
Block[{$MaxPrecision=200},
δ/.Minimize[{δ,constraints},{δ}][[2]]
]
]
]

Clear[GenericBimoduleExtensionDimensions2];

GenericBimoduleExtensionDimensions2[g_GradedBigraph,max_]:=GenericBimoduleExtensionDimensions2[g,max]=
Function[{δ},Evaluate[
Module[{reld,result,positivity,vars},
DebugPrint["beginning GenericBimoduleExtensionDimensions2[",g,",",max,"] ..."];
Block[{$MaxPrecision=200},
reld=RelativeDimensions[g,δ];
(*reld=Cases[RelativeDimensions[g,δ],dim_/;FreeQ[dim,d]];*)
vars={δ}~Join~Union[Cases[reld,_d,∞]];
positivity=Fold[Reduce[#1∧#2,vars,Reals]&,True,{δ≥ReducedDimensionOfGenerator[g]∧δ≤max}~Join~(#≥1&/@reld)];
reld=Cases[reld,dim_/;Minimize[{dim,positivity},vars][[1]]≤2];
result=Fold[Reduce[#1∧#2,vars,Reals]&,True,{positivity}~Join~((#==1∨#==2∨#==Root[3-5 ((#1)^2)+((#1)^4)&,4]∨#==Root[2-5 ((#1)^2)+((#1)^4)&,4]∨#==Root[-5+17 ((#1)^2)-8 ((#1)^4)+((#1)^6)&,6]∨#≥Sqrt[3+Sqrt[3]])&/@reld)];
];
DebugPrint["... finished GenericBimoduleExtensionDimensions2[",g,",",max,"]"];
result
]
]
]

Clear[LeastGenericBimoduleExtensionDimension2]

LeastGenericBimoduleExtensionDimension2[g_GradedBigraph,max_]:=LeastGenericBimoduleExtensionDimension2[g,max]=Module[{δ,constraints},
constraints=GenericBimoduleExtensionDimensions2[g,max][δ];
If[constraints===False,∞,
Block[{$MaxPrecision=200},
δ/.Minimize[{δ,constraints},{δ}][[2]]
]
]
]

DisplayBigraph[g=genericSeeds[[46]]]

LeastGenericBimoduleExtensionDimension[g]

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

DisplayBigraph[g]

N@LeastBimoduleCompatibleExtensionDimension[g,6]

N[Sqrt[5]]

RelativeDimensions[Most[HaagerupBigraph],δ]

GenericBimoduleExtensionDimensions[Most[HaagerupBigraph]][δ]

LeastGenericBimoduleExtensionDimension[Most[HaagerupBigraph]]

BimoduleCompatibleExtensionDimensions[G[3],6][δ]

BimoduleCompatibleExtensionDimensions[Most[G[3]],10][δ]

ListPlot[Table[LBCED[Most[G[3]],k],{k,3,11}],"PlotRange"->All,"PlotJoined"->True]

T=GradedBigraph[{{1}},{{1},{1},{1}}];

Clear[FindBimoduleCompatibleExtensionsUpToDepth]

FindBimoduleCompatibleExtensionsUpToDepth[d_,k_][g_GradedBigraph,0]:=If[LeastBimoduleCompatibleExtensionDimension[g,k]>d,{},{g}]

FindBimoduleCompatibleExtensionsUpToDepth[d_,k_][g_GradedBigraph,depth_Integer]:=FindBimoduleCompatibleExtensionsUpToDepth[d,k][g,depth]=Module[{set},
set=FindBimoduleCompatibleExtensionsUpToDepth[d,k][g,depth-1];
set=GraphFromString/@Flatten[FindBigraphExtensionsUpToRank[d][set,∞]];
set=DeleteCases[set,graph_/;LeastBimoduleCompatibleExtensionDimension[graph,k]>d];
set
]

FindBimoduleCompatibleExtensionsUpToDepth[d_,k_][g_GradedBigraph,∞]:=Module[{l=0},FixedPoint[FindBimoduleCompatibleExtensionsUpToDepth[d,k][g,l++]&,0]]

Length[FindBimoduleCompatibleExtensionsUpToDepth[Sqrt[5]-(10.^(-3)),5][DnBigraph[4],2]]

GraphToString/@FindBimoduleCompatibleExtensionsUpToDepth[Sqrt[5]-(10.^(-3)),4][DnBigraph[4],3]

DisplayBigraph/@FindBimoduleCompatibleExtensionsUpToDepth[Sqrt[5]-(10.^(-3)),4][DnBigraph[4],3]

Clear[FindGenericExtensionsUpToDepth]

FindGenericExtensionsUpToDepth[d_][g_GradedBigraph,0]:=If[LeastGenericBimoduleExtensionDimension[g]>d,{{g},{}},{{},{g}}]

FindGenericExtensionsUpToDepth[d_][g_GradedBigraph,depth_Integer]:=FindGenericExtensionsUpToDepth[d][g,depth]=Module[{specials,set},
{specials,set}=FindGenericExtensionsUpToDepth[d][g,depth-1];
set=GraphFromString/@Flatten[FindBigraphExtensionsUpToRank[d][set,∞]];
specials=specials~Join~Cases[set,graph_/;LeastGenericBimoduleExtensionDimension[graph]>d];
set=DeleteCases[set,graph_/;LeastGenericBimoduleExtensionDimension[graph]>d];
{specials,set}
]

FindGenericExtensionsUpToDepth[d_][g_GradedBigraph,∞]:=Module[{k=0},FixedPoint[FindGenericExtensionsUpToDepth[d][g,k++]&,0]]

FindGenericExtensionsUpToDepth[Sqrt[5]-(10.^(-3))][T,∞]

graphs=%[[1]]

DisplayBigraph/@graphs

N[DimensionOfGenerator/@graphs]

DisplayBigraph[graphs[[1]]]

N@DimensionsByDepth[graphs[[1]]]

N@Sqrt[5]

N@LeastBimoduleCompatibleExtensionDimension[graphs[[1]],3]

N@LeastBimoduleCompatibleExtensionDimension[graphs[[1]],4]

N@LeastBimoduleCompatibleExtensionDimension[graphs[[1]],5]

N@LeastBimoduleCompatibleExtensionDimension[graphs[[1]],50]

reld=RelativeDimensions[graphs[[1]],δ]

With[{k=7},Reduce[And@@(Reduce[Or@@Table[#==2Cos[π/l],{l,3,k}]∨#≥2Cos[π/(k+1)]∧δ<Sqrt[5]]&/@reld)]]

reld=RelativeDimensions[graphs[[2]],δ]

FindGenericExtensionsUpToDepth[Sqrt[5]-(10.^(-3))][AnBigraph[2]~Join~T,∞]

graphs=%[[1]]

DisplayBigraph/@graphs

N[DimensionOfGenerator/@graphs]

DisplayBigraph[graphs[[1]]]

N@DimensionsByDepth[graphs[[1]]]

BimoduleCompatibleExtensionDimensions[graphs[[1]],3][δ]

reld=RelativeDimensions[graphs[[1]],δ]

N[Minimize[{#,BimoduleCompatibleExtensionDimensions[graphs[[1]],3][δ]},{δ}][[1]]]&/@reld

N[Minimize[{#,BimoduleCompatibleExtensionDimensions[graphs[[1]],6][δ]},{δ}][[1]]]&/@reld

Reduce[1≤reld[[4]]≤2∧2≤δ<Sqrt[5],δ,Reals]

Reduce[2Cos[π/3]≤reld[[4]]≤2∧2≤δ<Sqrt[5]]

Reduce[2Cos[π/4]≤reld[[4]]≤2∧2≤δ<Sqrt[5]]

Reduce[2Cos[π/5]≤reld[[4]]≤2∧2≤δ<Sqrt[5]]

Reduce[2Cos[π/6]≤reld[[4]]≤2∧2≤δ<Sqrt[5]]

Reduce[2Cos[π/7]≤reld[[4]]≤2∧2≤δ<Sqrt[5]]

Reduce[(1==reld[[4]]∨2Cos[π/3]==reld[[4]]∨2Cos[π/4]==reld[[4]]∨2Cos[π/5]==reld[[4]]∨2Cos[π/6]==reld[[4]])∧2≤δ≤Sqrt[5]]

N[%]

FindGenericExtensionsUpToDepth[Sqrt[5]-(10.^(-3))][AnBigraph[3]~Join~T,4]

graphs=%355[[1]]

N[DimensionOfGenerator/@graphs]

DisplayBigraph[graphs[[-3]]]

N@DimensionsByDepth[graphs[[-3]]]

BimoduleCompatibleExtensionDimensions[graphs[[-3]],3][δ]

reld=RelativeDimensions[graphs[[-3]],δ]

N[Minimize[{#,BimoduleCompatibleExtensionDimensions[graphs[[-3]],3][δ]},{δ}][[1]]]&/@reld

Reduce[1≤reld[[-4]]≤2∧2≤δ≤Sqrt[5]]

Reduce[2Cos[π/3]≤reld[[-4]]≤2∧2≤δ≤Sqrt[5]]

Reduce[2Cos[π/4]≤reld[[-4]]≤2∧2≤δ≤Sqrt[5]]

Reduce[2Cos[π/3]==reld[[-4]]∧2≤δ≤Sqrt[5]]

DisplayBigraph[graphs[[-5]]]

N@DimensionsByDepth[graphs[[-5]]]

BimoduleCompatibleExtensionDimensions[graphs[[-5]],3][δ]

reld=RelativeDimensions[graphs[[-5]],δ]

N[Minimize[{#,BimoduleCompatibleExtensionDimensions[graphs[[-5]],3][δ]},{δ}][[1]]]&/@reld

N[Minimize[{#,BimoduleCompatibleExtensionDimensions[graphs[[-5]],4][δ]},{δ}][[1]]]&/@reld

Reduce[1≤reld[[-3]]≤2∧1≤reld[[-2]]≤2∧1≤reld[[-1]]≤2∧2≤δ≤Sqrt[5]]

Reduce[2Cos[π/4]≤reld[[-3]]≤2∧1≤reld[[-2]]≤2∧1≤reld[[-1]]≤2∧2≤δ≤Sqrt[5]]

Reduce[(1==reld[[-3]]∨2Cos[π/3]==reld[[-3]])∧1≤reld[[-2]]≤2∧1≤reld[[-1]]≤2∧2≤δ≤Sqrt[5]]

Map[DisplayBigraph,%,{2}]

FindGenericExtensionsUpToDepth[Sqrt[5]][AnBigraph[4]~Join~T,2]