(* ::Package:: *)

(************************************************************************)
(* This file was generated automatically by the Mathematica front end.  *)
(* It contains Initialization cells from a Notebook file, which         *)
(* typically will have the same name as this file except ending in      *)
(* ".nb" instead of ".m".                                               *)
(*                                                                      *)
(* This file is intended to be loaded into the Mathematica kernel using *)
(* the package loading commands Get or Needs.  Doing so is equivalent   *)
(* to using the Evaluate Initialization Cells menu command in the front *)
(* end.                                                                 *)
(*                                                                      *)
(* DO NOT EDIT THIS FILE.  This entire file is regenerated              *)
(* automatically each time the parent Notebook file is saved in the     *)
(* Mathematica front end.  Any changes you make to this file will be    *)
(* overwritten.                                                         *)
(************************************************************************)



(*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`"},{}]];


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;


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


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]}]]]


RankAtDepth[GradedBigraph[],0]=1;


RankAtDepth[g_GradedBigraph, n_Integer]/;(n>= 0 \[And] n<=Length[g]) :=
	If[n<=Length[g]-1,Length[g[[n+1,1]]] ,Length[g[[-1]]]]


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


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


RankAtDepth[g_GradedGraph,n_Integer]/;(n<0 \[Or] 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]


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,\[Infinity]]];
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[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)\[Or](!(MatchQ[g,GradedBigraph[{{1}}..,{{1},{1}},{{1,0}|{0,1}},__]])\[And](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]]


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\[And]!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\[And]i!=i0\[And]i!=j0,i==j0\[And]j==i0\[Or]i==i0\[And]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]\[And]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]


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


trivalentBigraph[i_,j_,0]/;i>=0\[And]j>=0:=AnBigraph[i+j+1]
trivalentBigraph[i_,0,j_]/;i>=0\[And]j>=0:=AnBigraph[i+j+1]


trivalentBigraph[i_,j_,j_]/;i>=0\[And]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\[And]j>=0\[And]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[];


EndPackage[];
