FindAllBigraphs package

Introduction

---text goes here---

Implementation

Start of package

Specify package dependencies:

BeginPackage["FusionAtlas`FindAllBigraphs`",{"FusionAtlas`","FusionAtlas`Bigraphs`","FusionAtlas`CyclotomicTest`","FusionAtlas`KnapsackTest`","FusionAtlas`QuadraticTanglesTest`","FusionAtlas`dTest`","FusionAtlas`Debugging`","FusionAtlas`JavaOdometer`","FusionAtlas`RemoteInterface`","FusionAtlas`PackageData`"}~Join~If[$VersionNumber<6.0,{"NumberTheory`AlgebraicNumberFields`"},{}]];

Usage messages

AlgebraicIntegerTest::usage="AlgebraicIntegerTest[b] returns True if all the Perron-Frobenius dimensions of the graph b are algebraic integers";

PositivityTest::usage="PositivityTest[b] returns True if all the Perron-Frobenius dimensions of the graph b are more than or equal to 1";

GHJTest::usage="GHJTest[b] returns True if all the Perron-Frobenius dimensions of the graph b are more than two or of the form 2 Cos[Pi/n]";

BigraphConditions::usage="BigraphConditions is a set of triples:  an English name for a test, the Mathematica name for the test, and a description of the test";

KnownObstructions;FindAllObstructions;

AllBigraphs;
FindAllBigraphs::usage="FindAllBigraphs[{mdim,Mdim},r] produces a list of all bigraphs with rank less than or equal to r and dimension between mdim and Mdim. FindAllBigraphs[dim,r] produces a list of all bigraphs with rank less than or equal to r and dimension between 0 and dim (if dim is less than or equal to 2) or 2 and dim (if dim is more than 2).";

RequestAllBigraphs;

RequestMoreBigraphs;

Internals

Begin["`Private`"];

fastAlgebraicIntegerQ[μ_]:=fastAlgebraicIntegerQ[μ]=Module[{p,x,c,d},
p=MinimalPolynomial[μ,x];
c=LCM@@(Denominator[CoefficientList[p,x]]);
d=GCD@@CoefficientList[c p,x];
Abs[Coefficient[(c/d) p,x,Exponent[p,x]]]==1
]

productAlgebraicIntegerQ[x_Times]:=(AlgebraicIntegerQ/@(And@@x))∨AlgebraicIntegerQ[x]
productAlgebraicIntegerQ[x_]:=AlgebraicIntegerQ[x]

safeAlgebraicIntegerQ[x_]:=Module[{r1,t1,r2,t2},
{t1,r1}=fastAlgebraicIntegerQ[x]//AbsoluteTiming;
{t2,r2}=productAlgebraicIntegerQ[x]//AbsoluteTiming;
If[t1>t2,Print["Not so fast... ",t1," ",t2," ",t1/t2],Print["Fast!"]];
If[r1≠r2,Print["Argh! AlgebraicIntegerQ failure: ",x],r1]
]

AlgebraicIntegerTest[b_GradedBigraph] :=AlgebraicIntegerTest[b]=fastAlgebraicIntegerQ /@(And@@Flatten[DimensionsByDepth[b]])

PositivityTest[b_GradedBigraph]:=
#>1.-(10.^(-6))&/@(And@@Flatten[NumericDimensionsByDepth[b]])

GHJQ[δ_]:=δ≥2∨Abs[((π/(N[ArcCos[N[δ]/2]]))-Round[N[(π/(ArcCos[N[δ]/2]))]])]<(10^(-3))

GHJTest[g_GradedBigraph]:=
GHJQ/@(And@@Flatten[NumericDimensionsByDepth[g]])

BigraphConditions={
{"Positivity",PositivityTest,"All bimodule dimensions must be at least 1."},
{"GHJ", GHJTest, "Bimodule dimensions less than 2 must satisfy the GHJ condition."},
{"Annular Tangles",AnnularTanglesTest,"Dimensions of low weight spaces must be non-negative. See p.33 of Annular Structure of Subfactors."},
{"Parity",ParityTest,"If you start like Haagerup or dual Haagerup, the branch point must be at odd depth."},
{"HaagerupTypeBranch",HaagerupTypeBranchTest,"If you start like Haagerup for two steps past the branch, you must satisfy the identities on p.33 of Quadratic Tangles pre-preprint"},
{"Algebraic Integer",AlgebraicIntegerTest,"All bimodule dimensions must be algebraic integers."},{"Cyclotomic Integer",(CyclotomicTest[#,200])&,"The index must be a cyclotomic integer."},
{"d-Number",(DTest[#])&,"The global dimension of the even part must be an Ostrik d-number."}(*,
{"Knapsack",KnapsackTest,"It must be possible to write all products of dimensions as N-linear combinations of dimensions."}*)
};

KnownObstructions[g_GradedBigraph]:=KnownObstructions[g]=Module[{result={}},
Do[DebugPrint["Looking for obstructions: ",g," ",BigraphConditions[[k,1]]];If[!BigraphConditions[[k,2]][g],AppendTo[result,BigraphConditions[[k,3]]];Break[]],{k,1,Length[BigraphConditions]}];
result
]

KnownObstructions[S_String]:=KnownObstructions[GraphFromString[S]]

FindAllObstructions[g_GradedBigraph]:=FindAllObstructions[g]=KnownObstructions[g]=Module[{result={}},
Do[If[!BigraphConditions[[k,2]][g],AppendTo[result,BigraphConditions[[k,3]]]],{k,1,Length[BigraphConditions]}];
result
]

Options[FindAllBigraphs]:={"Package"->False};

FindAllBigraphs[{minDimension_,dimension_},maximumRank_Integer]:=FindAllBigraphs[{minDimension,dimension},maximumRank,GradedBigraph[{{1}}]]
FindAllBigraphs[{minDimension_,dimension_},maximumRank_Integer,seed_GradedBigraph]:=FindAllBigraphs[{minDimension,dimension},maximumRank,seed]=
With[
{package="Package"/.Options[FindAllBigraphs]},
Module[{seeds,candidates,allowed,unknowns,canonicalForms,insideRange,batch,disallowed,lookup},
seeds={seed};
(*candidates=
Join@@(DeleteCases[FindBigraphExtensionsUpToRankAndDepthJava[dimension][#,maximumRank,maximumRank-1],x_/;DimensionAtMostQ[minDimension][x]]&/@seeds);*)
candidates=Join@@(FindBigraphExtensionsUpToRankAndDepthJava[dimension][#,maximumRank,maximumRank-1]&/@seeds);
disallowed={};
allowed={};
unknowns={};
While[Length[candidates]>0,
batch=Take[candidates,Min[1000,Length[candidates]]];
candidates=Drop[candidates,Min[1000,Length[candidates]]];
(*lookup canonical forms *)
canonicalForms=LookupCanonicalForms[batch];
If[canonicalForms=!=$Failed,
DebugPrint["Found ",Length[canonicalForms],"-->", Length[Union[Last/@canonicalForms]]," canonical forms."];
batch=Union[Complement[batch,First/@canonicalForms]~Join~(Last/@canonicalForms)];,
DebugPrint["Looking up canonical forms failed, probably due to a network error."];
];
lookup=LookupGraphs[batch];
If[lookup=!=$Failed,
DebugPrint["Found information about ",Length[lookup]," graphs in the database."];
insideRange=Cases[lookup,{graph_,_,_,dim_,_}/;(dim>minDimension-0.00001∧dim<dimension+0.00001∧!DimensionAtMostQ[minDimension][graph]∧DimensionAtMostQ[dimension][graph])];
DebugPrint["Of those, ",Length[insideRange]," are in the desired range."];
disallowed=disallowed~Join~Cases[insideRange,{g_,_,_,_,obstruction:Except[Null]}:>{g,{obstruction}}];
allowed=allowed~Join~Cases[insideRange,{g_,_,_,_,Null}:>g];
batch=Complement[batch,First/@lookup];
RequestObstructions[batch];
If[Length[batch]>0,DebugPrint["finished putting obstructions requests on the queue."];];,
DebugPrint["Graph lookup failed, probably due to a network error."];
];
unknowns=unknowns~Join~batch;
];
While[Length[unknowns]>0,
batch=Take[unknowns,Min[100,Length[unknowns]]];
unknowns=Drop[unknowns,Min[100,Length[unknowns]]];
DebugPrint["Processing ",Length[batch], " graphs locally."];
RecordObstructions[batch];
batch=Union[CanonicalizeBigraph/@batch];
DebugPrint["After canonicalizing, there are ",Length[batch]," graphs"];
batch=Cases[batch,g_/;DimensionAtMostQ[dimension][g]∧!DimensionAtMostQ[minDimension][g]];
DebugPrint["Of those, ",Length[batch]," are in the desired range."];
allowed=allowed~Join~Cases[batch,x_/;Length[KnownObstructions[x]]==0];
disallowed=disallowed~Join~Cases[batch,(x_/;Length[KnownObstructions[x]]>0):>{x,KnownObstructions[x]}];
DebugPrint["Finished working on local batch; looking for new data on the server."];
canonicalForms=LookupCanonicalForms[Take[unknowns,Min[1000,Length[unknowns]]]];
If[canonicalForms=!=$Failed,
DebugPrint["Found ",Length[canonicalForms]," new canonical forms."];
unknowns=Union[Complement[unknowns,First/@canonicalForms]~Join~(Last/@canonicalForms)];,
DebugPrint["Looking up canonical forms failed, probably due to a network error."];
];
lookup=LookupGraphs[Take[unknowns,Min[1000,Length[unknowns]]]];
If[lookup=!=$Failed,
DebugPrint["Found new information about ",Length[lookup]," graphs"];
insideRange=Cases[lookup,{graph_,_,_,dim_,_}/;(dim>minDimension-0.00001∧dim<dimension+0.00001∧!DimensionAtMostQ[minDimension][graph]∧DimensionAtMostQ[dimension][graph])];
disallowed=disallowed~Join~Cases[insideRange,{g_,_,_,_,obstruction:Except[Null]}:>{g,{obstruction}}];
allowed=allowed~Join~Cases[insideRange,{g_,_,_,_,Null}:>g];
unknowns=Complement[unknowns,First/@lookup];,
DebugPrint["Graph lookup failed, probably due to a network error."];
];
];
allowed=Union[GraphFromString/@allowed];
disallowed=Union[{GraphFromString[#[[1]]],#[[2]]}&/@disallowed];
If[package,
DebugPrint["Packaging data ..."];
PackageEverything[dimension];
DebugPrint["... finished packaging data."];
];
{"Allowed bigraphs"->allowed,"Disallowed bigraphs"->disallowed}
]]

FindAllBigraphs[dimension_?NumericQ,totalRank_Integer]:=FindAllBigraphs[{If[dimension>2,2,0],dimension},totalRank,GradedBigraph[{{1}}]]
FindAllBigraphs[dimension_?NumericQ,totalRank_Integer,seed_GradedBigraph]:=FindAllBigraphs[{If[dimension>2,2,0],dimension},totalRank,seed]

RequestAllBigraphs[{minDimension_,dimension_},maximumRank_Integer,k_Integer:1]:=RequestAllBigraphs[{minDimension,dimension},maximumRank,GradedBigraph[{{1}}],k];
RequestAllBigraphs[{minDimension_,dimension_},maximumRank_Integer,seed_GradedBigraph,k_Integer:1]:=
Module[{seeds,iterator,allowed={},disallowed=0,unknowns=0,count,canonicalForms,insideRange,batch,lookup},
seeds={seed};
(*candidates=
Join@@(DeleteCases[FindBigraphExtensionsUpToRankAndDepthJava[dimension][#,maximumRank,maximumRank-1],x_/;DimensionAtMostQ[minDimension][x]]&/@seeds);*)
iterator=FindBigraphExtensionsUpToRankAndDepthJavaIterator[dimension][seed,maximumRank,maximumRank-1];
While[iterator@hasNext[],
batch=iterator@next[];
canonicalForms=LookupCanonicalForms[batch];
If[canonicalForms=!=$Failed,
DebugPrint["Found ",Length[canonicalForms],"-->", Length[Union[Last/@canonicalForms]]," canonical forms."];
batch=Union[Complement[batch,First/@canonicalForms]~Join~(Last/@canonicalForms)];,
DebugPrint["Looking up canonical forms failed, probably due to a network error."];
];
lookup=LookupGraphs[batch];
If[lookup=!=$Failed,
DebugPrint["Found information about ",Length[lookup]," graphs in the database."];
count=Count[lookup,{__,Null}];
allowed=Union[allowed~Join~Cases[lookup,{g_,___,Null}:>g]];
disallowed+=Length[lookup]-count;
batch=Complement[batch,First/@lookup];,
DebugPrint["Graph lookup failed, probably due to a network error."];
];
unknowns+=Length[batch];
RequestObstructions[batch,k];
If[Length[batch]>0,DebugPrint["finished putting obstructions requests on the queue."];];
];
RecordRequestAllBigraphs[dimension,maximumRank,seed,Length[allowed],disallowed,unknowns];
If[unknowns>0,QueueExpression[RequestAllBigraphs[{minDimension,dimension},maximumRank,seed,2],2]];
{allowed,disallowed,unknowns}
]

RequestAllBigraphs[dimension_?NumericQ,totalRank_Integer,k_Integer:1]:=RequestAllBigraphs[{If[dimension>2,2,0],dimension},totalRank,GradedBigraph[{{1}}],k]
RequestAllBigraphs[dimension_?NumericQ,totalRank_Integer,seed_GradedBigraph,k_Integer:1]:=RequestAllBigraphs[{If[dimension>2,2,0],dimension},totalRank,seed,k]

AllBigraphs[arguments__]:="Allowed bigraphs"/.FindAllBigraphs[arguments]

MaximaOfPartialOrdering[list_List,f_]:=MaximaOfPartialOrdering[{},list,f]
MaximaOfPartialOrdering[maxima_List,{},f_]:=maxima
MaximaOfPartialOrdering[maxima_List,{first_,rest___},f_]:=Module[{},
If[Or@@(f[first,#]&/@maxima),
MaximaOfPartialOrdering[maxima,{rest},f],
MaximaOfPartialOrdering[{first}~Join~DeleteCases[maxima,c_/;f[c,first]],{rest},f]
]
]

RequestMoreBigraphs[k_Integer:1]:=Module[{requests,norm,rank,seed},
DebugPrint[DisplayBigraphRequests[]];
requests=MaximalIncompleteBigraphRequests[];
(*requests=Cases[requests,{___,0}];*)
{norm,rank,seed}=Take[First[SortBy[requests,#[[5]]+#[[6]]&]],3];
DebugPrint["About to run RequestAllBigraphs[",norm,", ",rank+1,", ",DisplayBigraph[seed],"]"];
RequestAllBigraphs[norm,rank+1,seed,k]
]

End

End[];

End of package

EndPackage[];