Bigraphs package

A subpackage for FusionAtlas v0.
May 20, 2008, Noah Snyder, Scott Morrison, Emily Peters

Introduction

---text goes here---

Implementation

Start of package

Specify package dependencies:

(*We need AlgebraicIntegerQ, which in version 6 was moved into the core libraries. *)

BeginPackage["FusionAtlas`Bigraphs`",{"FusionAtlas`","FusionAtlas`Debugging`","FusionAtlas`JavaOdometer`"}~Join~If[$VersionNumber<6,{"LinearAlgebra`MatrixManipulation`"},{}]];

Usage messages

GradedBigraph::usage="A GradedBigraph is a list of matrices which represents a bipartite graph whose vertices are graded by distance from a chosen first vertex ('depth').  The nth matrix in the list is the adjacency matrix for the depth n vertices (which label columns) and the depth n+1 vertices (which label rows).";
GradedGraph::usage="A GradedGraph is a list of pairs of matrices which represents a graph whose vertices are graded by distance from a chosen first vertex ('depth').  The (n,1)-th matrix in the list is the adjacency matrix among the depth n vertices.  The (n,2)-th matrix in the list is the adjacency matrix for the depth n vertices (which label columns) and the depth n+1 vertices (which label rows).";

DisplayBigraph::usage="DisplayBigraph[g] produces a Graphics object representing the GradedBigraph g.";

RankAtDepth::usage="RankAtDepth[g,n] gives the number of vertices at depth n of the bipartite graph g";

GraphDepth::usage="GraphDepth[g] gives the maximum depth of the bipartite graph g";
GraphRank::usage="GraphRank[g] gives the rank (ie the number of vertices) of the bipartite graph g";
GraphEvenRank::usage="GraphRank[g] gives the even rank (ie the number of even vertices) of the bipartite graph g";
GraphOddRank::usage="GraphRank[g] gives the odd rank (ie the number of odd vertices) of the bipartite graph g";

GraphAdjacencyMatrix::usage="GraphAdjacencyMatrix[g] gives the adjacency matrix of the graph g";

EvenPart;

DimensionOfGenerator::usage="DimensionOfGenerator[g] gives the Perron-Frobenius dimension of the unique vertex at depth 1 of the bipartite graph g (assuming there is such a vertex)";
NumericDimensionOfGenerator::usage="NumericDimensionOfGenerator[g] gives the numeric value of the Perron-Frobenius dimension of the unique vertex at depth 1 of the bipartite graph g (assuming there is such a vertex)";
ReducedDimensionOfGenerator::usage="";
GraphIndex::usage="GraphIndex[g] gives the square of the Perron-Frobenius eigenvalue of the adjacency matrix ofthe bipartite graph g";
DimensionAtMostQ::usage="DimensionAtMostQ[x][g] returns True if the dimension (of the generator) of the bipartite graph g is less than x.  DimensionAtMostQ[g1][g2] returns True if the dimension (of the generator) of the bipartite graph g1 is more than the dimension (of the generator) of the bipartite graph g2. ";

DimensionsByDepth::usage="DimensionsByDepth[g] gives a list of the Perron-Frobenius dimensions of the vertices of the bipartite graph g, sorted by depth.";
NumericDimensionsByDepth::usage="NumericDimensionsByDepth[g] gives a list of the numeric values of the Perron-Frobenius dimensions of the vertices of the bipartite graph g, sorted by depth";
ReducedDimensionsByDepth::usage="";

GlobalEvenDimension;

DimensionOfLowWeightSpace::usage="DimensionOfLowWeightSpace[g,r] gives the dimension of the subspace of P_r which is orthogonal to the lift (ie, annular consequences) of the elements of P_{r-1}, where P is a planar algebra with principal graph g.  This is the same as the number of irreducible modules of lowest weight r in the decomposition of P into annular Temperley-Lieb modules.";
StableLowWeightSpaceDimensions;
AnnularTanglesSubgraphTest::usage="AnnularTanglesSubgraphTest[g] applies the annular tangles test (described on p.33 of Vaughan Jones' 'Annular Structure of Subfactors') up to the depth of the graph g, and can rule out g from being the initial segment of any principal graph";
AnnularTanglesTest::usage="AnnularTanglesTest[g_] checks for the graph g the condition on a principal graph described on p.33 of Vaughan Jones' 'Annular Structure of Subfactors'.";

FindBigraphExtensions::usage="FindBigraphExtensions[c][b,r] gives all bipartite graphs which look like b up to the depth of b, have r new vertices at one plus the depth, and have index less than or equal to c.  Currently, FindBigraphExtensions only returns graphs g for which AnnularTanglesSubgraphTest[g] returns True.";

FindBigraphExtensionsUpToRank::usage="FindBigraphExtensionsUpToRank[c][b,r] gives all bipartite graphs which look like b up to the depth of b, have at most r new vertices at one plus the depth, and have index less than or equal to c.  It can also be run on a list of bipartite graphs. Currently, FindBigraphExtensions only returns graphs g for which AnnularTanglesSubgraphTest[g] returns True.";

FindBigraphExtensionsUpToRankAndDepth::usage="FindBigraphExtensionsUpToRankAndDepth[c][b,r,d] gives all bipartite graphs which look like b up to the depth of b, have at most r new vertices between the depth of b and depth d, and have index less than or equal to c. Currently, FindBigraphExtensions only returns graphs g for which AnnularTanglesSubgraphTest[g] returns True.";

CanonicalizeBigraph::usage=""

AnBigraph::usage="AnBigraph[n] returns the bigraph form of the Dynkin diagram A_n";
DnBigraph::usage="DnBigraph[n] returns the bigraph form of the Dynkin diagram D_n";
EnBigraph::usage="EnBigraph[n] returns the bigraph form of the Dynkin diagram E_n";
trivalentBigraph::usage="trivalentBigraph[i,j,k] returns a bigraph with one trivalent vertex and three legs, the legs having i, j, and k vertices";
haagerupFamilyBigraph::usage="haagerupFamilyBigraph[n] returns trivalentBigraph[n,3,3], ie the bigraph form of a graph with one trivalent vertex and three legs, the legs having n, 3, and 3 vertices, ie o-o-...-o<8=8=8 .";
dualHaagerupFamilyBigraph::usage="dualHaagerupFamilyBigraph[n] returns the bigraph form of the graph which has two adjacent trivalent vertices and four legs, the legs having n, 1, 1, and 1 vertices, ie __...__!_!_";
HaagerupBigraph::usage="HaagerupBigraph is the bigraph form of the graph o-o-o-o<8=8=8, the principal graph of the Haagerup subfactor constructed by Asaeda and Haagerup in 'Exotic Subfactors of Finite Depth ....'";
DualHaagerupBigraph::usage="HaagerupBigraph is the bigraph form of the graph ___!_!_, the dual principal graph of the Haagerup subfactor constructed by Asaeda and Haagerup in 'Exotic Subfactors of Finite Depth ....'";

IzumiStarBigraph;ExtendedDnBigraph;HexagonBigraph;DualHexagonBigraph;HaagerupAsaedaBigraph;DualHaagerupAsaedaBigraph;ExtendedEnBigraph;S4S5Bigraph;A4A5Bigraph;A5A6Bigraph

GraphToString::usage="GraphToString[g_] returns a string suitable for use both as a filename and as a Mathematica symbol name, encoding the graph g.";

GraphFromString;

ClearCachedGraphFromString;CachedGraphFromString;

DepthOfBranchPoint;HasSimpleBranchQ;

BranchFactor::usage="Given a principal graph, computes r, the ratio of the dimensions of the objects one past the branch point";

Truncate;

Internals

Begin["`Private`"];

stringInterleave[list:{___String},t_String]:=StringJoin@@(Most[Flatten[Transpose[{list,Table[t,{Length[list]}]}]]])

GraphToString[g_GradedBigraph]:="gbg"<>stringInterleave[matrixToString/@(List@@g),"v"]

GraphToString[S_String]:=S

matrixToString[m_?MatrixQ]:=stringInterleave[vectorToString/@m,"p"]
vectorToString[v_?VectorQ]:=stringInterleave[ToString/@v,"x"]

interpretNumber["0"]=0;
interpretNumber["1"]=1;
interpretNumber["2"]=2;
interpretNumber["3"]=3;
interpretNumber["4"]=4;
interpretNumber["5"]=5;
interpretNumber[S_String]/;StringMatchQ[S,NumberString]:=ToExpression[S]

stringSplit[S_,V_]:=StringTake[S,#]&/@Partition[{1}~Join~Flatten[#+{-1,1}&/@StringPosition[S,V]]~Join~{-1},2]

ClearCachedGraphFromString[]:=(CachedGraphFromString[S_String]:=CachedGraphFromString[S]=GraphFromString[S])

ClearCachedGraphFromString[]

GraphFromString[S_String]/;StringTake[S,3]=="gbg":=
GradedBigraph@@Map[interpretNumber/@stringSplit[#,"x"]&,stringSplit[#,"p"]&/@stringSplit[StringDrop[S,3],"v"],{2}]

GraphFromString[G_GradedBigraph]:=G

Display

DisplayBigraph[S_String]:=DisplayBigraph[GraphFromString[S]]

VertexLocation[g_GradedBigraph,AtDepth_Integer, WithinDepth_Integer]/;1≤WithinDepth≤RankAtDepth[g,AtDepth]:=
{AtDepth+1,2WithinDepth-RankAtDepth[g,AtDepth]}

DisplayBigraph[g_GradedBigraph]:=DisplayBigraph[g]=Show[Graphics[Table[Point[VertexLocation[g,AtDepth,WithinDepth]],{AtDepth,0,GraphDepth[g]},{WithinDepth,1,RankAtDepth[g,AtDepth]}]],Graphics[Table[If[g[[AtDepth+1]][[WithinEnd,WithinStart]]≠0,Line[{VertexLocation[g,AtDepth,WithinStart],VertexLocation[g,AtDepth+1,WithinEnd]}],{}],{AtDepth,0,GraphDepth[g]-1},{WithinStart,1,RankAtDepth[g,AtDepth]},{WithinEnd,1,RankAtDepth[g,AtDepth+1]}]],
Graphics[Table[If[g[[AtDepth+1]][[WithinEnd,WithinStart]]>1, Text[g[[AtDepth+1]][[WithinEnd,WithinStart]]],{}], {AtDepth,0,GraphDepth[g]-1},{WithinStart,1,RankAtDepth[g,AtDepth]},{WithinEnd,1,RankAtDepth[g,AtDepth+1]}]]]

Combinatorics

RankAtDepth[GradedBigraph[],0]=1;

RankAtDepth[g_GradedBigraph, n_Integer]/;(n≥ 0 ∧ n≤Length[g]) :=
	If[n≤Length[g]-1,Length[g[[n+1,1]]] ,Length[g[[-1]]]]

RankAtDepth[g_GradedBigraph,n_Integer]/;(n<0 ∨ n>Length[g]):=0

RankAtDepth[g_GradedGraph, n_Integer]/;(n≥0∧ n≤Length[g[[1]]]-1) :=
	Length[g[[1,n+1]]]

RankAtDepth[g_GradedGraph,n_Integer]/;(n<0 ∨ n>Length[g]-1):=0

GraphDepth[g_GradedBigraph]:=Length[g]

GraphDepth[g_GradedGraph]:=Length[g[[2]]]

GraphAdjacencyMatrix[g_GradedBigraph]:=(*GraphAdjacencyMatrix[g]=*)Module[{},
BlockMatrix[Table[Switch[i-j,-1,Transpose[g[[i]]],1,g[[j]],_,ZeroMatrix[RankAtDepth[g,i-1],RankAtDepth[g,j-1]]],{i,1,GraphDepth[g]+1},{j,1,GraphDepth[g]+1}]]]

GraphAdjacencyMatrix[g_GradedGraph]:=GraphAdjacencyMatrix[g]=Module[{},
BlockMatrix[Table[Switch[i-j,-1,Transpose[g[[2,i]]],1,g[[2,j]],0,g[[1,i]],_,ZeroMatrix[RankAtDepth[g,i-1],RankAtDepth[g,j-1]]],{i,1,GraphDepth[g]+1},{j,1,GraphDepth[g]+1}]]]

GraphRank[b_]:= Sum[RankAtDepth[b,k],{k,0,GraphDepth[b]}]

GraphEvenRank[b_GradedBigraph]:=Sum[RankAtDepth[b,k],{k,0,GraphDepth[b],2}]

GraphOddRank[b_GradedBigraph]:=Sum[RankAtDepth[b,k],{k,1,GraphDepth[b],2}]

EvenPart[g_GradedBigraph]:=GradedGraph[Table[If[k>1,g[[k-1]].Transpose[g[[k-1]]],0]+If[k<Length[g]+1,Transpose[g[[k]]].g[[k]],0]-IdentityMatrix[If[k>1,Length[g[[k-1]]],Length[g[[1,1]]]]],{k,1,Length[g]+1,2}],Table[g[[k+1]].g[[k]],{k,1,Length[g]-1,2}]
]

DepthOfBranchPoint[b_GradedBigraph]:=
 Position[(List @@ b),x_/;(x≠{{1}})][[1,1]]-1

BranchFactor[g_GradedBigraph] := With[{d=DimensionsByDepth[g]},d[[DepthOfBranchPoint[g]+2,1]]/d[[DepthOfBranchPoint[g]+2,2]]]

HasSimpleBranchQ[b_GradedBigraph]:=
(List@@b)[[DepthOfBranchPoint[b]+1]]=={{1},{1}}

Unprotect[Translate];
Translate[g_GradedBigraph,k_Integer]:=AnBigraph[k+1]~Join~g
Translate[list_List,k_Integer]:=Translate[#,k]&/@list
Protect[Translate];

Truncate[g_GradedBigraph,depth_Integer]:=Take[g,Min[Length[g],depth]]
Truncate[list_List,depth_Integer]:=Truncate[#,depth]&/@list
Truncate[g_GradedBigraph,depth_Integer/;depth≤0]:=Truncate[g,GraphDepth[g]+depth]

Dimensions

Beware!  Sometimes making changes here causes things to go horribly awry.  To check that this hasn't happened, run the line at the beginning of bigraphs3.

SimplifyRationalRootExpression[f_]/;FreeQ[f,Root]=f;
SimplifyRationalRootExpression[r_Root]:=r
SimplifyRationalRootExpression[f_]:=Module[{roots,root,p,q,r,z,gcdData,qInverse},
roots=Union[Cases[f,_Root,∞]];
If[Length[roots]≠1,Print[f, " is not a rational expression in a single Root expression."];f,
root=roots[[1]];
p=Numerator[f]/.root->z;
q=Denominator[f]/.root->z;
r=root[[1]][z];
gcdData=PolynomialExtendedGCD[q,r,z];
If[gcdData[[1]]≠1,Print["Warning, gcd should have been 1."]];
qInverse=gcdData[[2,1]];
Factor[Simplify[PolynomialMod[p qInverse,r]/.z->root]]
]
]

ReducedDimensionOfGenerator[S_String]:=RootReduce[DimensionOfGenerator[GraphFromString[S]]]

ReducedDimensionOfGenerator[g_GradedBigraph|g_GradedGraph]/;(RankAtDepth[g,1]==1):=ReducedDimensionOfGenerator[g]=DimensionOfGenerator[g]=cachedRootReduce[DimensionOfGenerator[g]]

ReducedDimensionOfGenerator[g_GradedBigraph|g_GradedGraph]/;(RankAtDepth[g,1]≠ 1):=Module[{},Print["this graph does not have a unique generator"]; Return[$Failed]]

DimensionOfGenerator[S_String]:=RealMax[Eigenvalues[GraphAdjacencyMatrix[GraphFromString[S]]]]

DimensionOfGenerator[g_GradedBigraph|g_GradedGraph]/;(RankAtDepth[g,1]==1):=DimensionOfGenerator[g]=RealMax[Eigenvalues[GraphAdjacencyMatrix[g]]]

DimensionOfGenerator[g_GradedBigraph|g_GradedGraph]/;(RankAtDepth[g,1]≠ 1):=Module[{},Print["this graph does not have a unique generator"]; Return[$Failed]]

(*This takes about 1ms to compute, so it might not be worth saving...*)

NumericDimensionOfGenerator[S_String]:=NumericDimensionOfGenerator[GraphFromString[S]]

NumericDimensionOfGenerator[g_GradedBigraph|g_GradedGraph]/;(RankAtDepth[g,1]==1):=RealMax[Eigenvalues[N[GraphAdjacencyMatrix[g]]]]

NumericDimensionOfGenerator[g_GradedBigraph|g_GradedGraph]/;(RankAtDepth[g,1]≠ 1):=Module[{},Print["this graph does not have a unique generator"]; Return[$Failed]]

GraphIndex[g_GradedBigraph]:=cachedRootReduce[((ReducedDimensionOfGenerator[g])^2)]

NonnormalizedDimensions[g_GradedBigraph|g_GradedGraph]:=(*NonnormalizedDimensions[g]=*)Module[{e},
e=Eigensystem[GraphAdjacencyMatrix[g]];
e[[2,RealMaxPosition[e[[1]]]]]
]

NumericNonnormalizedDimensions[g_GradedBigraph|g_GradedGraph]:=(*NonnormalizedDimensions[g]=*)Module[{e},
e=Eigensystem[N [GraphAdjacencyMatrix[g]]];
e[[2,RealMaxPosition[e[[1]]]]]
]

ReducedFPDimensions[g_GradedBigraph|g_GradedGraph]:= cachedRootReduce/@FPDimensions[g]

FPDimensions[g_]:= With[{nnd=NonnormalizedDimensions[g]},SimplifyRationalRootExpression/@(nnd/nnd[[1]])]

NumericFPDimensions[g_GradedBigraph|g_GradedGraph]:= With[{nnd=NonnormalizedDimensions[g]},N/@(nnd/nnd[[1]])]

ReducedDimensionsByDepth[g_GradedBigraph|g_GradedGraph]:=ReducedDimensionsByDepth[g]=DimensionsByDepth[g]=
With[{fpd=ReducedFPDimensions[g]},Module[{i,j},Table[Take[fpd,{Sum[RankAtDepth[g,j],{j,0,i-1}]+1,Sum[RankAtDepth[g,j],{j,0,i}]}],{i,0,GraphDepth[g]}]
]]

DimensionsByDepth[g_GradedBigraph|g_GradedGraph]:=DimensionsByDepth[g]=
With[{fpd=FPDimensions[g]},Module[{i,j},Table[Take[fpd,{Sum[RankAtDepth[g,j],{j,0,i-1}]+1,Sum[RankAtDepth[g,j],{j,0,i}]}],{i,0,GraphDepth[g]}]
]]

NumericDimensionsByDepth[g_GradedBigraph|g_GradedGraph]:=NumericDimensionsByDepth[g]=With[{fpd=NumericFPDimensions[g]},Module[{i,j},Table[Take[fpd,{Sum[RankAtDepth[g,j],{j,0,i-1}]+1,Sum[RankAtDepth[g,j],{j,0,i}]}],{i,0,GraphDepth[g]}]
]]

EvenDimensions[g_GradedBigraph]:=Flatten[Table[ReducedDimensionsByDepth[g][[2i+1]],{i,0,GraphDepth[g]/2}]]

GlobalEvenDimension[g_GradedBigraph]:=Sum[EvenDimensions[g][[i]]^2,{i,1,Length[EvenDimensions[g]]}]

DimensionAtMostQ takes two argument:  a number and a graph, or two graphs.  When you give it two graphs, it computes the dimension of the generator of the first, and then runs DimensionAtMostQ on that number and the second graph (the first line of code below tells it to do this if the first argument in a graph; the second line of code below defined DimensionAtMostQ on a number and a graph).

DimensionAtMostQ[x_GradedBigraph|x_GradedGraph]:=
DimensionAtMostQ[DimensionOfGenerator[x]]

DimensionAtMostQ[dx_][y_]:=
Or[NumericDimensionOfGenerator[y]<N[dx]-(10.^(-6)),And[NumericDimensionOfGenerator[y]<N[dx]+(10.^(-6)) ,(*cached*)RootReduce[ReducedDimensionOfGenerator[y]-dx]≤0]]

DimensionOfLowWeightSpace[g_GradedBigraph][0]:=RankAtDepth[g,0]
DimensionOfLowWeightSpace[g_GradedBigraph][1]:=RankAtDepth[g,1]-1

DimensionOfLowWeightSpace[g_GradedBigraph][r_Integer]/;(r>1):=DimensionOfLowWeightSpace[g][r]=Module[{w},
w[n_]:=MatrixPower[GraphAdjacencyMatrix[g],2n][[1,1]];
Sum[(((-1))^(r-n))((2r)/(r+n))Binomial[r+n,r-n]w[n],{n,0,r}]
]

StableLowWeightSpaceDimensions[g_GradedBigraph]/;DimensionOfGenerator[g]>2:=Table[DimensionOfLowWeightSpace[g][k],{k,0,GraphDepth[g]}]

StableLowWeightSpaceDimensions[g_GradedBigraph]/;DimensionOfGenerator[g]≤2:=Table[DimensionOfLowWeightSpace[g][k],{k,0,1}]

AnnularTanglesSubgraphTest[g_GradedBigraph]:=Module[{r},
r=And@@Table[AnnularTanglesTest[g,r],{r,1,GraphDepth[g]}];
If[!r,DebugPrint["Graph ",g," fails the annular tangles subgraph test."]];
r
]

AnnularTanglesTest[g_GradedBigraph]:=(DimensionOfGenerator[g]≤2)∨(!(MatchQ[g,GradedBigraph[{{1}}..,{{1},{1}},{{1,0}|{0,1}},__]])∧(Module[{am2=GraphAdjacencyMatrix[g].GraphAdjacencyMatrix[g],p},
p[0]=IdentityMatrix[Length[am2]];
p[n_]:=p[n]=am2.p[n-1];
Function[{r},Sum[(((-1))^(r-n))((2r)/(r+n))Binomial[r+n,r-n]p[n][[1,1]],{n,0,r}]≥0]/@(And@@Range[2,GraphDepth[g]+5])
]))

AnnularTanglesTest[g_GradedBigraph,r_Integer]/;r≥1:=NonNegative[DimensionOfLowWeightSpace[g][r]]

Find extensions

IncrementMatrix[m_] := 
	Module[{e=Flatten[m], n=Length[m[[1]]],p},
	p=FindFirst[e,x_/;x≠0];
	If[p==Length[e], Return[$Failed]];
	Partition[e-e[[p]] UnitVector[Length[e],p]+UnitVector[Length[e],p+1],n]]

NextMatrix[c_][b_GradedBigraph,m_] := 
	Module[{m1=m},
	m1[[1,1]]++;
	NestWhile[IncrementMatrix,m1,(#=!=$Failed∧!c[Append[b,#]])&]
]

partialSums[l_List]:={0}~Join~Module[{k=0},k+=#&/@l]

CanonicalPermutations[g_GradedBigraph]:=Module[{mp,ranks},
(*mp=MatrixPower[GraphAdjacencyMatrix[g],2GraphDepth[g]];*)
mp=Sum[MatrixPower[GraphAdjacencyMatrix[g],k],{k,1,4}];
ranks=RankAtDepth[g,#]&/@Range[0,GraphDepth[g]];
mp=Transpose[Join@@(Transpose/@Map[Sort,Transpose/@(Take[mp,#]&/@({1,0}+#&/@Partition[partialSums[ranks],2,1])),{2}])];
(Ordering/@(Take[mp,#]&/@({1,0}+#&/@Partition[partialSums[ranks],2,1])))
]

CanonicalPermutations1[g_GradedBigraph]:=Module[{p={1}},
{p}~Join~Table[p=Ordering[Reverse/@g[[k]][[All,p]]],{k,1,Length[g]}]
]

CanonicalizeBigraph[S_String]:=GraphToString[CanonicalizeBigraph[GraphFromString[S]]]

CanonicalizeBigraph[g_GradedBigraph]:=Most[CanonicalizeBigraph0[CanonicalizeBigraph1[Append[g,DiagonalMatrix[Range[Length[g[[-1]]]]]]]]]

CanonicalizeBigraph0[g_GradedBigraph]:=GradedBigraph@@(#[[1]][[#[[2,2]],#[[2,1]]]]&/@Transpose[{List@@g,Partition[CanonicalPermutations[g],2,1]}])

CanonicalizeBigraph1[g_GradedBigraph]:=GradedBigraph@@(#[[1]][[#[[2,2]],#[[2,1]]]]&/@Transpose[{List@@g,Partition[CanonicalPermutations1[g],2,1]}])

MatrixPermutations[n_]:=MatrixPermutations[n]=IdentityMatrix[n][[#]]&/@Permutations[Range[n]]

MatrixTranspositions[n_]:=MatrixTranspositions[n]={IdentityMatrix[n]}~Join~(IdentityMatrix[n][[#]]&/@Flatten[Table[Table[Switch[k,i,j,j,i,_,k],{k,1,n}],{i,1,n},{j,1,i-1}],1])

partitions[0]={{}};
partitions[n_Integer]/;n>0:=Union[Sort/@Flatten[Table[{k}~Join~#&/@partitions[n-k],{k,1,n}],1]]

BlockTranspositions[n_Integer]:=BlockTranspositions[n]={IdentityMatrix[n]}~Join~Union[Flatten[BlockTranspositions/@Flatten[Permutations/@partitions[n],1],1]]

BlockTranspositions[blocks_List]:=DeleteCases[Flatten[Table[
If[blocks[[i0]]==blocks[[j0]],
ArrayFlatten[
Table[
Switch[
{i==j∧i≠i0∧i≠j0,i==j0∧j==i0∨i==i0∧j==j0},
{True,False},IdentityMatrix[blocks[[i]]],
{False,True},IdentityMatrix[blocks[[i]]],
{False,False},ConstantArray[0,{blocks[[i]],blocks[[j]]}]
],
{i,1,Length[blocks]},{j,1,Length[blocks]}]
],
Null],
{i0,1,Length[blocks]},{j0,1,i0-1}],1],Null]

MaximalDepthSymmetries[GradedBigraph[{{1}}]]:={{{1}}}

MaximalDepthSymmetries[g_GradedBigraph]:=(*MaximalDepthSymmetries[g]=*)First/@Cases[Flatten[Outer[List,MatrixTranspositions[RankAtDepth[g,GraphDepth[g]]],MaximalDepthSymmetries[Most[g]],1],1],
{new_?MatrixQ,old_?MatrixQ}/;new.g[[-1]].old==g[[-1]]]

(*CanonicalizeBigraph[S_String]:=GraphToString[CanonicalizeBigraph[GraphFromString[S]]]
CanonicalizeBigraph[GradedBigraph[]]:=GradedBigraph[]
CanonicalizeBigraph[GradedBigraph[{{1}}]]:=GradedBigraph[{{1}}]
CanonicalizeBigraph[g_GradedBigraph]:=(*CanonicalizeBigraph[g]=*)
Module[{},
Append[Most[g],
CanonicalizeMatrix[Last[g],{Range[RankAtDepth[g,GraphDepth[g]]]},MaximalDepthSymmetryGroup[Most[g]]]]
]*)

OrbitsFromPermutationList[permutations_]:=
With[{n=Length[permutations[[1,1]]]},Sort[Sort/@(Union[Union/@Outer[#2.#1&,IdentityMatrix[n],permutations,1]]/.v_?VectorQ:>Position[IdentityMatrix[n],v,{1},1][[1,1]])]
]

MaximalDepthSymmetryGroup[g_GradedBigraph]:=(*MaximalDepthSymmetryGroup[g]=*)OrbitsFromPermutationList[MaximalDepthSymmetries[g]]

StabilizerGroup[list_List]:=Position[list,#,{1},Heads->False][[All,1]]&/@Union[list]

IntersectSymmetryGroups[group1_,group2_]:=Sort[DeleteCases[Flatten[Outer[Intersection,group1,group2,1],1],{}]]

LeastElementInOrbit[v_,symmetries_]:=
Module[{w=v},
(w[[#]]=Sort[v[[#]]])&/@symmetries;
w
]

GreatestElementInOrbit[v_,symmetries_]:=
Module[{w=v},
(w[[#]]=Reverse[Sort[v[[#]]]])&/@symmetries;
w
]

CanonicalizeMatrix[m:{{}...},_,_]:=m

CanonicalizeMatrix[matrix_,rowSymmetries_,columnSymmetries_]:=
Module[{columnBlockContaining1,targetColumn,column,newMatrix,newRowSymmetries,newColumnSymmetries,array},
columnBlockContaining1=Position[columnSymmetries,l_/;MemberQ[l,1],{1},1][[1,1]];
targetColumn=
columnSymmetries[[columnBlockContaining1]][[Ordering[GreatestElementInOrbit[#,rowSymmetries]&/@Transpose[matrix[[All,columnSymmetries[[columnBlockContaining1]]]]]][[-1]]]];
column=matrix[[All,targetColumn]];
newMatrix=Drop[#,{targetColumn}]&/@matrix;
newRowSymmetries=IntersectSymmetryGroups[rowSymmetries,StabilizerGroup[column]];
newColumnSymmetries=DeleteCases[DeleteCases[#,1]-1&/@columnSymmetries,{}];
array=ArrayFlatten[{{Transpose[{column}],CanonicalizeMatrix[newMatrix,newRowSymmetries,newColumnSymmetries]}}];
GreatestElementInOrbit[array,rowSymmetries]
]

MatchingValues[s_Symbol,p_]:=Cases[DownValues[s]~Join~SubValues[s],rule:(pattern_/;MatchQ[pattern/.HoldPattern->Hold,Hold[p]]:>_):>rule]

FindBigraphExtensions[c_?NumericQ][b_GradedBigraph,r_]:=FindBigraphExtensions[c][b,r]=
Module[{values},
(* First, check to see if we already have data for a higher value of c. *)
values=MatchingValues[FindBigraphExtensions,HoldPattern[FindBigraphExtensions[d_/;d>c][b,r]]];
If[Length[values]>0,
DebugPrint["Using extensions found at a higher index."];
Return[Cases[values[[1,2]],g_GradedBigraph/;DimensionAtMostQ[c][g]]]];
(* If not, actually do the work. *)
Module[{condition=DimensionAtMostQ[c]},
DebugPrint["Finding extensions for ",b, " with additional rank ", r];
Cases[
Union[CanonicalizeBigraph/@(Append[b,#]&/@
 DeleteCases[
Most[NestWhileList[NextMatrix[condition][b,#]&,ZeroMatrix[r,RankAtDepth[b,GraphDepth[b]]],#=!=$Failed&]], m_/;MemberQ[m,ZeroVector[Length[m[[1]]]]]])],
g_/;AnnularTanglesSubgraphTest[g]]
]
]

(*FindBigraphExtensionsUpToRank[c_][b_GradedBigraph,totalRank_]:= 
Module[{r=1},
Flatten[Reap[While[r≤totalRank-GraphRank[b]∧Sow[FindBigraphExtensions[c][b,r++]]≠{}]][[2]]]
]*)
FindBigraphExtensionsUpToRank[c_][b_GradedBigraph,totalRank_,maximalLoops_:(-1)]:=FindBigraphExtensionsUpToRank[c][b,totalRank,maximalLoops]=FindBigraphExtensionsUpToRankJava[c][b,totalRank,maximalLoops]

FindBigraphExtensionsUpToRank[c_][b_GradedBigraph,totalRank_,maximalLoops_:(-1)]/;totalRank≤GraphRank[b]:={}

FindBigraphExtensionsUpToRank[c_][bs:{___GradedBigraph},totalRank_]:= Join@@(FindBigraphExtensionsUpToRank[c][#,totalRank]&/@bs)

(*FindBigraphExtensionsUpToRankAndDepth[c_][b_GradedBigraph,totalRank_,depth_]:=Join@@NestList[FindBigraphExtensionsUpToRank[c][#,totalRank]&,{b},depth-GraphDepth[b]]*)

FindBigraphExtensionsUpToRankAndDepth[c_][b_GradedBigraph,totalRank_,depth_]:=
FindBigraphExtensionsUpToRankAndDepthJava[c][b,totalRank,depth]

Families of bigraphs

AnBigraph[n_]/;n≥1:=GradedBigraph@@Table[{{1}}, {n-1}]

trivalentBigraph[i_,j_,0]/;i≥0∧j≥0:=AnBigraph[i+j+1]
trivalentBigraph[i_,0,j_]/;i≥0∧j≥0:=AnBigraph[i+j+1]

trivalentBigraph[i_,j_,j_]/;i≥0∧j≥0:=GradedBigraph@@Join[
	Table[
	{{1}}
	, {i}]
	,{{{1},{1}}},Table[{{1,0},{0,1}},{j-1}]]

DnBigraph[n_] /;n≥3:= 
trivalentBigraph[n-3,1,1]

trivalentBigraph[i_,j_,k_]/;i≥0∧j≥0∧k≥0:=GradedBigraph@@Join[
	Table[
	{{1}}
	, {i}]
	,{{{1},{1}}},
	Table[{{1,0},{0,1}}
	, {Min[j,k]-1}],{{{1,0}}},Table[{{1}},{Abs[j-k]-1}]
	]

haagerupFamilyBigraph[n_] /;n≥0:=trivalentBigraph[n,3,3]
HaagerupBigraph=haagerupFamilyBigraph[3];
dualHaagerupFamilyBigraph[n_]/;n≥0:=GradedBigraph@@Join[Table[{{1}},{n}],{{{1},{1}},{{1,0},{1,0}}}];
DualHaagerupBigraph=dualHaagerupFamilyBigraph[3];

EnBigraph[n_Integer]/;n≥4:=trivalentBigraph[n-4,2,1]

IzumiStarBigraph[p_]/;p≥2:=GradedBigraph@@(Table[{{1}},{3}]~Join~{Table[{1},{p-1}]}~Join~Table[IdentityMatrix[p-1],{2}])

ExtendedDnBigraph[4]=GradedBigraph[{{1}},{{1},{1},{1}}];

ExtendedDnBigraph[n_]/;n>4:=GradedBigraph@@({{{1}},{{1},{1}},{{1,0}}}~Join~Table[{{1}},{n-6}]~Join~{{{1},{1}}})

HexagonBigraph[n_]/;n≥7:=AnBigraph[n-5]~Join~GradedBigraph[{{1},{1}},IdentityMatrix[2],{{1,1}}]

DualHexagonBigraph[n_]/;n≥7:=AnBigraph[n-5]~Join~GradedBigraph[{{1},{1}},{{1,0},{1,0}},IdentityMatrix[2]]

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

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

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

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

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

End

End[];

End of package

EndPackage[];