FusionAtlas`GraphPairs` package

A subpackage for FusionAtlas v0.
February 12, 2009, Noah Snyder and Scott Morrison

Introduction

---text goes here---

Implementation

Start of package

Specify package dependencies:

BeginPackage["FusionAtlas`GraphPairs`",{"Combinatorica`","FusionAtlas`","FusionAtlas`Bigraphs`","FusionAtlas`Debugging`","FusionAtlas`JavaOdometer`"}];

Usage messages

BigraphWithDuals::usage="A wrapper for things of the form BigraphWithDuals[GradedBigraph[blah],DualData[blah]]";

DualData::usage="DualData is a wrapper where each entry describes which vertices are meant to be dual to each other, for example DualData[{1},{2,1}] means that at the first even depth the only vertex is self-dual while at the second even depth the two vertices are dual to each other";

OcneanuDisplay::usage="OcneanuDisplay[gd1_BigraphWithDuals,gd2_BigraphWithDuals] shows the 4-partite graph corresponding to a pair of graphs with dual data."

HaagerupWithDuals;DualHaagerupWithDuals;HaagerupAsaedaWithDuals;DualHaagerupAsaedaWithDuals;

TwistBigraph;
FullOcneanuTest::usage="FullOcneanuTest[gd1_BigraphWithDuals,gd2_BigraphWithDuals] applies Ocneanu's Hom-space counting test to a pair of bigraphs with dual data.";
PartialOcneanuTest::usage="FullOcneanuTest[gd1_BigraphWithDuals,gd2_BigraphWithDuals] applies Ocneanu's Hom-space counting test to a pair of partial (i.e. they might be extended to greater depth later) bigraphs with dual data,";

DualDataList::usage="Takes the number of vertices at a given even level and returns ";
CompatibleDualDataList::usage="Takes a bigraph and returns all possible dual data which at all even levels";
CheckDualDimensions::usage="Takes a bigraph with dual data and checks whether dual objects have the same dimensions.  So don't run it on partial graphs.";

GraphPairsIsomorphicQ;
ClearGraphPairsCachedValues;

PermuteToReduceCrossings

Internals

Begin["`Private`"];

DisplayBigraph[list:{__BigraphWithDuals}]:=Grid[{Magnify[DisplayBigraph[#],0.7]&/@list}]

GraphRank[{g1_BigraphWithDuals,g2_BigraphWithDuals}]:=GraphRank[g1]+GraphRank[g2]

GraphFromString[S_]/;StringMatchQ[S,"(bwd"~~__~~", bwd"~~__~~")"]:=GraphFromString/@StringCases[S,"bwd"~~(DigitCharacter|"v"|"p"|"x")...~~"duals"~~(DigitCharacter|"v"|"x")...]

We don' t actually use GraphPair outside the package; it' s an obsolete representation of the data, but OcneanuDisplay is written in terms of it, so we need it internally.

GraphPairToBigraphs[pair_GraphPair]:={GradedBigraph@@(Riffle[List@@pair[[2]],List@@pair[[3]]]),GradedBigraph@@Riffle[List@@pair[[5]],List@@pair[[4]]]}

BigraphsToGraphPair[Principal_GradedBigraph,DualPrincipal_GradedBigraph,PDuals_DualData,DDuals_DualData]:=GraphPair[PDuals,EvenToOddEdges@@Table[Principal[[i]],{i,1,Length[Principal],2}],OddToEvenEdges@@Table[Principal[[i]],{i,2,Length[Principal],2}],OddToEvenEdges@@Table[DualPrincipal[[i]],{i,2,Length[DualPrincipal],2}],EvenToOddEdges@@Table[DualPrincipal[[i]],{i,1,Length[DualPrincipal],2}],DDuals]

OcneanuDisplay[pair_GraphPair]:=
(Flatten[Table[If[pair[[2,i,k,j]]≠0,
Line[{{2i-2+(2j-1-Length[pair[[2,i,1]]])/Length[pair[[2,i,1]]],0},{2i-1+(2k-1-Length[pair[[2,i]]])/Length[pair[[2,i]]],1}}]],{i,1,Length[pair[[2]]]},{j,1,Length[pair[[2,i,1]]]},{k,1,Length[pair[[2,i]]]}]]/.Null->Sequence[])~Join~(Flatten[Table[If[pair[[3,i,k,j]]≠0,
Line[{{2i-1+(2j-1-Length[pair[[3,i,1]]])/Length[pair[[3,i,1]]],1},{2i+(2k-1-Length[pair[[3,i]]])/Length[pair[[3,i]]],0}}]],{i,1,Length[pair[[3]]]},{j,1,Length[pair[[3,i,1]]]},{k,1,Length[pair[[3,i]]]}]]/.Null->Sequence[])~Join~(Flatten[Table[If[pair[[4,i,k,j]]≠0,
Line[{{2i-1+(2j-1-Length[pair[[4,i,1]]])/Length[pair[[4,i,1]]],1},{2i+(2k-1-Length[pair[[4,i]]])/Length[pair[[4,i]]],2}}]],{i,1,Length[pair[[4]]]},{j,1,Length[pair[[4,i,1]]]},{k,1,Length[pair[[4,i]]]}]]/.Null->Sequence[])~Join~(Flatten[Table[If[pair[[5,i,k,j]]≠0,
Line[{{2i-2+(2j-1-Length[pair[[5,i,1]]])/Length[pair[[5,i,1]]],2},{2i-1+(2k-1-Length[pair[[5,i]]])/Length[pair[[5,i]]],1}}]],{i,1,Length[pair[[5]]]},{j,1,Length[pair[[5,i,1]]]},{k,1,Length[pair[[5,i]]]}]]/.Null->Sequence[])~Join~(Flatten[Table[If[pair[[5,i]][[All,pair[[6,i]]]][[k,j]]≠0,
Line[{{2i-2+(2j-1-Length[pair[[5,i,1]]])/Length[pair[[5,i,1]]],2},{2i-1+(2k-1-Length[pair[[5,i]]])/Length[pair[[5,i]]],3}}]],{i,1,Length[pair[[5]]]},{j,1,Length[pair[[5,i,1]]]},{k,1,Length[pair[[5,i]]]}]]/.Null->Sequence[])~Join~(Flatten[Table[If[pair[[4,i]][[pair[[6,i+1]],All]][[k,j]]≠0,
Line[{{2i-1+(2j-1-Length[pair[[4,i,1]]])/Length[pair[[4,i,1]]],3},{2i+(2k-1-Length[pair[[4,i]]])/Length[pair[[4,i]]],2}}]],{i,1,Length[pair[[4]]]},{j,1,Length[pair[[4,i,1]]]},{k,1,Length[pair[[4,i]]]}]]/.Null->Sequence[])~Join~(Flatten[Table[If[pair[[3,i]][[pair[[1,i+1]],All]][[k,j]]≠0,
Line[{{2i-1+(2j-1-Length[pair[[3,i,1]]])/Length[pair[[3,i,1]]],3},{2i+(2k-1-Length[pair[[3,i]]])/Length[pair[[3,i]]],4}}]],{i,1,Length[pair[[3]]]},{j,1,Length[pair[[3,i,1]]]},{k,1,Length[pair[[3,i]]]}]]/.Null->Sequence[])~Join~(Flatten[Table[If[pair[[2,i]][[All,pair[[1,i]]]][[k,j]]≠0,
Line[{{2i-2+(2j-1-Length[pair[[2,i,1]]])/Length[pair[[2,i,1]]],4},{2i-1+(2k-1-Length[pair[[2,i]]])/Length[pair[[2,i]]],3}}]],{i,1,Length[pair[[2]]]},{j,1,Length[pair[[2,i,1]]]},{k,1,Length[pair[[2,i]]]}]]/.Null->Sequence[])//Graphics//Show

OcneanuDisplay[gd1_BigraphWithDuals,gd2_BigraphWithDuals]:=OcneanuDisplay[BigraphsToGraphPair[gd1[[1]],gd2[[1]],gd1[[2]],gd2[[2]]]]

OcneanuDisplay[g1_GradedBigraph,g2_GradedBigraph,d1_DualData,d2_DualData]:=OcneanuDisplay[BigraphWithDuals[g1,d1],BigraphWithDuals[g2,d2]]

DualWithinDepth[d_DualData,AtDepth_?EvenQ,WithinDepth_]:=
Module[{DualDataIndex=1+AtDepth/2},
d[[DualDataIndex,WithinDepth]]]

VertexLocation=FusionAtlas`Bigraphs`Private`VertexLocation;
DisplayBigraph[gd_BigraphWithDuals]:=Module[{g=gd[[1]],d=gd[[2]]},Show[DisplayBigraph[g],
Graphics[{Red,Table[
If[EvenQ[AtDepth],
If[DualWithinDepth[d,AtDepth,WithinDepth]==WithinDepth,
Line[{VertexLocation[g,AtDepth,WithinDepth],VertexLocation[g,AtDepth,WithinDepth]+{0,.5}}],
Line[{VertexLocation[g,AtDepth,WithinDepth],(VertexLocation[g,AtDepth,WithinDepth]+VertexLocation[g,AtDepth,DualWithinDepth[d,AtDepth,WithinDepth]])/2+{.2,0},VertexLocation[g,AtDepth,DualWithinDepth[d,AtDepth,WithinDepth]]}]],{}],{AtDepth,0,GraphDepth[g]},{WithinDepth,1,RankAtDepth[g,AtDepth]}]}]
]]

DimensionOfGenerator[BigraphWithDuals[g_GradedBigraph,_]]:=DimensionOfGenerator[g]
DimensionOfGenerator[{BigraphWithDuals[g_GradedBigraph,_],BigraphWithDuals[_GradedBigraph,_]}]:=DimensionOfGenerator[g]

GraphRank[BigraphWithDuals[g_GradedBigraph,_]]:=GraphRank[g]
GraphOddRank[BigraphWithDuals[g_GradedBigraph,_]]:=GraphOddRank[g]
GraphEvenRank[BigraphWithDuals[g_GradedBigraph,_]]:=GraphEvenRank[g]

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

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

RankAtDepth[BigraphWithDuals[g_GradedBigraph,_DualData],i_]:=RankAtDepth[g,i]

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

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

OddToEvenAdjacency[g_GradedBigraph]:=OddToEvenAdjacency[g]=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,2},{j,2,GraphDepth[g]+1,2}]]

EvenToOddAdjacency[g_GradedBigraph]:=EvenToOddAdjacency[g]=BlockMatrix[
Table[
Switch[i-j,
-1,Transpose[g[[i]]],
1,g[[j]],
_,ZeroMatrix[RankAtDepth[g,i-1],RankAtDepth[g,j-1]]],
{i,2,GraphDepth[g]+1,2},{j,1,GraphDepth[g]+1,2}]]

TwistBigraph[g_GradedBigraph,d_DualData]:=TwistBigraph[g,d]=GradedBigraph@@
Table[If[EvenQ[i],g[[i]][[d[[Ceiling[(i+1)/2]]]]],g[[i]][[All,d[[Ceiling[i/2]]]]]],{i,1,GraphDepth[g]}]

OcneanuAdjacencyMatrix[BigraphWithDuals[g1_GradedBigraph,d1_DualData],BigraphWithDuals[g2_GradedBigraph,d2_DualData]]:=With[{oe1=OddToEvenAdjacency[g1],eot2=EvenToOddAdjacency[TwistBigraph[g2,d2]],oe2=OddToEvenAdjacency[g2],oet1=OddToEvenAdjacency[TwistBigraph[g1,d1]]},
BlockMatrix[{{0,oe1,0,oet1},{Transpose[oe1],0,eot2,0},{0,Transpose[eot2],0,oe2},{Transpose[oet1],0,Transpose[oe2],0}}]
]

FlatDualData[d_DualData]:=Flatten[Most[FoldList[Plus,0,Length/@(List@@d)]]+(List@@d)]

OcneanuStrutsAdjacencyMatrix[BigraphWithDuals[g1_GradedBigraph,d1_DualData],BigraphWithDuals[g2_GradedBigraph,d2_DualData]]:=With[{oe1=OddToEvenAdjacency[g1],eot2=EvenToOddAdjacency[TwistBigraph[g2,d2]],oe2=OddToEvenAdjacency[g2],oet1=OddToEvenAdjacency[TwistBigraph[g1,d1]]},
BlockMatrix[{{0,oe1,0,oet1},{Transpose[oe1],0,eot2,IdentityMatrix[GraphOddRank[g1]]},{0,Transpose[eot2],0,oe2},{Transpose[oet1],IdentityMatrix[GraphOddRank[g1]],Transpose[oe2],0}}]
]

(*Oops, need struts for duals on the even vertices too!*)

OcneanuStrutsAdjacencyMatrix[BigraphWithDuals[g1_GradedBigraph,d1_DualData],BigraphWithDuals[g2_GradedBigraph,d2_DualData]]:=With[{oe1=OddToEvenAdjacency[g1],eot2=EvenToOddAdjacency[TwistBigraph[g2,d2]],oe2=OddToEvenAdjacency[g2],oet1=OddToEvenAdjacency[TwistBigraph[g1,d1]]},
BlockMatrix[{{IdentityMatrix[GraphEvenRank[g1]][[FlatDualData[d1]]],oe1,0,oet1},{Transpose[oe1],0,eot2,IdentityMatrix[GraphOddRank[g1]]},{0,Transpose[eot2],IdentityMatrix[GraphEvenRank[g2]][[FlatDualData[d2]]],oe2},{Transpose[oet1],IdentityMatrix[GraphOddRank[g1]],Transpose[oe2],0}}]
]

TripartiteAdjacencyMatrix[BigraphWithDuals[g1_GradedBigraph,d1_DualData],BigraphWithDuals[g2_GradedBigraph,d2_DualData]]:=With[{oe1=OddToEvenAdjacency[g1],eot2=EvenToOddAdjacency[TwistBigraph[g2,d2]],oe2=OddToEvenAdjacency[g2],oet1=OddToEvenAdjacency[TwistBigraph[g1,d1]]},
BlockMatrix[{{0,oe1+oet1,0},{Transpose[oe1+oet1],0,eot2+Transpose[oe2]},{0,Transpose[eot2]+oe2,0}}]
]

OcneanuGraph[BigraphWithDuals[g1_GradedBigraph,d1_DualData],BigraphWithDuals[g2_GradedBigraph,d2_DualData]]:=OcneanuGraph[BigraphWithDuals[g1,d1],BigraphWithDuals[g2,d2]]=FromAdjacencyMatrix[OcneanuAdjacencyMatrix[BigraphWithDuals[g1,d1],BigraphWithDuals[g2,d2]]]

OcneanuStrutsGraph[BigraphWithDuals[g1_GradedBigraph,d1_DualData],BigraphWithDuals[g2_GradedBigraph,d2_DualData]]:=OcneanuStrutsGraph[BigraphWithDuals[g1,d1],BigraphWithDuals[g2,d2]]=FromAdjacencyMatrix[OcneanuStrutsAdjacencyMatrix[BigraphWithDuals[g1,d1],BigraphWithDuals[g2,d2]]]

TripartiteGraph[BigraphWithDuals[g1_GradedBigraph,d1_DualData],BigraphWithDuals[g2_GradedBigraph,d2_DualData]]:=TripartiteGraph[BigraphWithDuals[g1,d1],BigraphWithDuals[g2,d2]]=FromAdjacencyMatrix[TripartiteAdjacencyMatrix[BigraphWithDuals[g1,d1],BigraphWithDuals[g2,d2]]]

GraphPairsIsomorphicQ[{g1_BigraphWithDuals,g2_BigraphWithDuals},{g3_BigraphWithDuals,g4_BigraphWithDuals}]:=
GraphPairsIsomorphicQInternal[{g1,g2},{g3,g4}]∨GraphPairsIsomorphicQInternal[{g1,g2},{g4,g3}]

GraphPairsIsomorphicQInternal[{BigraphWithDuals[g1_GradedBigraph,d1_DualData],BigraphWithDuals[g2_GradedBigraph,d2_DualData]},{BigraphWithDuals[g3_GradedBigraph,d3_DualData],BigraphWithDuals[g4_GradedBigraph,d4_DualData]}]:=
Module[{label,k},
label[_,1]="NN*";
label[_,1+GraphRank[g1]]="MM*";
Table[label[_,k]="NN",{k,2,GraphEvenRank[g1]}];
Table[label[_,k]="NM",{k,1+GraphEvenRank[g1],GraphRank[g1]}];
Table[label[_,k]="MM",{k,2+GraphRank[g1],GraphRank[g1]+GraphEvenRank[g2]}];
Table[label[_,k]="MN",{k,1+GraphRank[g1]+GraphEvenRank[g2],GraphRank[g1]+GraphRank[g2]}];
label[_,k_]:=(GraphPairsIsomorphicQProblem={{BigraphWithDuals[g1,d1],BigraphWithDuals[g2,d2]},{BigraphWithDuals[g3,d3],BigraphWithDuals[g4,d4]}};DebugPrint["... trouble labelling vertices in GraphPairsIsomorphicQ! ",k];DebugPrint[Stack[_]];Abort[]);

IsomorphicQ[OcneanuStrutsGraph[BigraphWithDuals[g1,d1],BigraphWithDuals[g2,d2]],OcneanuStrutsGraph[BigraphWithDuals[g3,d3],BigraphWithDuals[g4,d4]],Invariants->{label,DegreesOf2Neighborhood,NumberOf2Paths,Distances}]
]

DeleteDefiniteDownValues[f_Symbol]:=
(DownValues[f]=DeleteCases[DownValues[f],(x_:>y_)/;FreeQ[x,Blank|BlankSequence|BlankNullSequence|Repeated|RepeatedNull|Alternatives|Except]];)

ClearGraphPairsCachedValues[]:=
(DeleteDefiniteDownValues[EvenToOddAdjacency];DeleteDefiniteDownValues[OddToEvenAdjacency];DeleteDefiniteDownValues[TwistBigraph];DeleteDefiniteDownValues[OcneanuGraph];DeleteDefiniteDownValues[OcneanuStrutsGraph];DeleteDefiniteDownValues[TripartiteGraph];)

ClearGraphPairsCachedValues[]

FullOcneanuTest[g1_GradedBigraph,g2_GradedBigraph,d1_DualData,d2_DualData]:=
With[{oe2=OddToEvenAdjacency[g2],eo1=EvenToOddAdjacency[g1],eot2=EvenToOddAdjacency[TwistBigraph[g2,d2]],oe1=OddToEvenAdjacency[TwistBigraph[g1,d1]]},(oe2.eo1==Transpose[oe1.eot2])∧(eot2.oe2==Transpose[eo1.oe1])
]

FullOcneanuTest[dg1_BigraphWithDuals,dg2_BigraphWithDuals]:=FullOcneanuTest[dg1[[1]],dg2[[1]],dg1[[2]],dg2[[2]]]

OldSlowPartialOcneanuTest[g1_GradedBigraph,g2_GradedBigraph,d1_DualData,d2_DualData]/;GraphDepth[g1]==GraphDepth[g2]:=
With[{oe2=OddToEvenAdjacency[g2],eo1=EvenToOddAdjacency[g1],oet1=OddToEvenAdjacency[TwistBigraph[g1,d1]],eot2=EvenToOddAdjacency[TwistBigraph[g2,d2]]},
If[EvenQ[GraphDepth[g1]],
((oe2.eo1)[[1;;-1-RankAtDepth[g1,GraphDepth[g1]],1;;-1-RankAtDepth[g1,GraphDepth[g1]]]]==(Transpose[oet1.eot2])[[1;;-1-RankAtDepth[g1,GraphDepth[g1]],1;;-1-RankAtDepth[g1,GraphDepth[g1]]]])∧(eot2.oe2==Transpose[eo1.oet1]),
(oe2.eo1==Transpose[oet1.eot2])∧((eot2.oe2)[[1;;-1-RankAtDepth[g1,GraphDepth[g1]],1;;-1-RankAtDepth[g1,GraphDepth[g1]]]]==(Transpose[eo1.oet1])[[1;;-1-RankAtDepth[g1,GraphDepth[g1]],1;;-1-RankAtDepth[g1,GraphDepth[g1]]]])]
]

ZeroOutBottomRightCorner[matrix0_,n_]:=Module[{matrix=matrix0},
matrix[[-n;;-1,-n;;-1]]=Table[0,{n},{n}];
matrix
]

ZeroOutBottomRightCorner[matrix0_,n_,m_]:=Module[{matrix=matrix0},
matrix[[-n;;-1,-m;;-1]]=Table[0,{n},{m}];
matrix
]

SlowPartialOcneanuTest[g1_GradedBigraph,g2_GradedBigraph,d1_DualData,d2_DualData]/;GraphDepth[g1]==GraphDepth[g2]:=
With[{oe2=OddToEvenAdjacency[g2],eo1=EvenToOddAdjacency[g1],oet1=OddToEvenAdjacency[TwistBigraph[g1,d1]],eot2=EvenToOddAdjacency[TwistBigraph[g2,d2]]},
If[EvenQ[GraphDepth[g1]],
(ZeroOutBottomRightCorner[Transpose[eot2].eo1,RankAtDepth[g2,GraphDepth[g2]],RankAtDepth[g1,GraphDepth[g1]]]==ZeroOutBottomRightCorner[oe2.Transpose[oet1],RankAtDepth[g2,GraphDepth[g2]],RankAtDepth[g1,GraphDepth[g1]]])∧(eot2.oe2==Transpose[eo1.oet1]),
(Transpose[eot2].eo1==oe2.Transpose[oet1])∧(ZeroOutBottomRightCorner[eot2.oe2,RankAtDepth[g1,GraphDepth[g1]]]==ZeroOutBottomRightCorner[Transpose[eo1.oet1],RankAtDepth[g1,GraphDepth[g1]]])]
]

FastPartialOcneanuTest[g1_GradedBigraph,g2_GradedBigraph,d1_DualData,d2_DualData]/;GraphDepth[g1]==GraphDepth[g2]∧OddQ[GraphDepth[g1]]:=
Transpose[g2[[-1,All,d2[[-1]]]]].g1[[-1]]+g2[[-2,d2[[-1]]]].Transpose[g1[[-2]]]==Transpose[g2[[-1]]].g1[[-1,All,d1[[-1]]]]+g2[[-2]].Transpose[g1[[-2,d1[[-1]]]]]∧g1[[-1,All,d1[[-1]]]].g1[[-2]]==g2[[-1]].g2[[-2,d2[[-1]]]]

FastPartialOcneanuTest[g1_GradedBigraph,g2_GradedBigraph,d1_DualData,d2_DualData]/;GraphDepth[g1]==GraphDepth[g2]∧EvenQ[GraphDepth[g1]]:=
Transpose[g1[[-1]]].g1[[-1,d1[[-1]]]]+g1[[-2]].Transpose[g1[[-2,All,d1[[-2]]]]]==Transpose[g2[[-1,d2[[-1]]]]].g2[[-1]]+g2[[-2,All,d2[[-2]]]].Transpose[g2[[-2]]]∧g2[[-1,d2[[-1]]]].g1[[-2]]==g2[[-1]].g1[[-2,All,d1[[-2]]]]∧g1[[-1]].g2[[-2,All,d2[[-2]]]]==g1[[-1,d1[[-1]]]].g2[[-2]]

Global`FastPartialOcneanuTestTiming=0;
Global`SlowPartialOcneanuTestTiming=0;

SafePartialOcneanuTest[g1_GradedBigraph,g2_GradedBigraph,d1_DualData,d2_DualData]:=
Module[{fast,fastTime,slow,slowTime},
{fastTime,fast}=AbsoluteTiming[FastPartialOcneanuTest[g1,g2,d1,d2]];
{slowTime,slow}=AbsoluteTiming[SlowPartialOcneanuTest[g1,g2,d1,d2]];
Global`FastPartialOcneanuTestTiming+=fastTime;
Global`SlowPartialOcneanuTestTiming+=slowTime;
If[slow=!=fast,
DebugPrint["FastPartialOcneanuTest gave the wrong result: "];
DebugPrint[g1];
DebugPrint[g2];
DebugPrint[d1];
DebugPrint[d2];
];
slow
]

PartialOcneanuTest[dg1_BigraphWithDuals,dg2_BigraphWithDuals]:=FastPartialOcneanuTest[dg1[[1]],dg2[[1]],dg1[[2]],dg2[[2]]]

ReplaceEntry[list_,i_][j_]:=list[[1;;i-1]]~Join~{j}~Join~list[[i+1;;]]

PreDualDataList[1]:={{1}}

PreDualDataList[n_Integer]:=PreDualDataList[n]=
Union[(Append[#,n]&/@PreDualDataList[n-1])~Join~Flatten[Table[ReplaceEntry[ReplaceEntry[PreDualDataList[n-1][[j]],PreDualDataList[n-1][[j]][[i]]][PreDualDataList[n-1][[j]][[i]]],i][n]~Join~{i}
,{i,1,n-1},{j,1,Length[PreDualDataList[n-1]]}],1]]

DualDataList[n_]:=DualDataList[n]=DualData/@PreDualDataList[n]

CompatibleDualDataList[GradedBigraph[]]:={DualData[{1}]}

CompatibleDualDataList[g_GradedBigraph]/;OddQ[GraphDepth[g]]:=CompatibleDualDataList[Most[g]]

CompatibleDualDataList[g_GradedBigraph]/;EvenQ[GraphDepth[g]]:=
Flatten[Outer[Join,CompatibleDualDataList[Most[g]],DualDataList[Length[Last[g]]]],1]

FullOcneanuTest[g1_GradedBigraph,g2_GradedBigraph]:=FullOcneanuTest[g1,g2]=
Or@@Flatten[Table[FullOcneanuTest[g1,g2,CompatibleDualDataList[g1][[i]],CompatibleDualDataList[g2][[j]]],{i,1,Length[CompatibleDualDataList[g1]]},{j,1,Length[CompatibleDualDataList[g2]]}]]

CheckDualDimensions[gd_BigraphWithDuals]:=DimensionsByDepth[gd[[1]]]==DimensionsByDepth[TwistBigraph[gd[[1]],gd[[2]]]]

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

GraphToString[BigraphWithDuals[g_GradedBigraph,d_DualData]]:="bwd"<>StringDrop[GraphToString[g],3]<>"duals"<>stringInterleave[vectorToString/@(List@@d),"v"]

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

interpretNumber[S_String]/;StringMatchQ[S,NumberString]:=ToExpression[S]

(* The built-in StringSplit has a memory leak. *)
stringSplit[S_,V_]:=StringTake[S,#]&/@Partition[{1}~Join~Flatten[#+{-1,1}&/@StringPosition[S,V]]~Join~{-1},2]

GraphFromString[S_String]/;StringTake[S,3]=="bwd":=
Module[{g,d},
{g,d}=stringSplit[S,"duals"];
BigraphWithDuals[GraphFromString["gbg"<>StringDrop[g,3]],
DualData@@((interpretNumber/@stringSplit[#,"x"]&)/@stringSplit[d,"v"])]
]

Unprotect[Translate];
Translate[BigraphWithDuals[g_GradedBigraph,d_DualData],depth_Integer/;EvenQ[depth]]:=BigraphWithDuals[Translate[g,depth],(DualData@@Table[{1},{depth/2}])~Join~d]
Protect[Translate];

Truncate[d_DualData,depth_Integer]:=Take[d,Min[Length[d],Ceiling[(depth+1)/2]]]
Truncate[BigraphWithDuals[g_GradedBigraph,d_DualData],depth_Integer/;depth≥1]:=BigraphWithDuals[Truncate[g,depth],Truncate[d,depth]]
Truncate[BigraphWithDuals[g_GradedBigraph,d_DualData],depth_Integer/;depth≤0]:=BigraphWithDuals[Truncate[g,depth],Truncate[d,GraphDepth[g]+depth]]

NumberOfCrossings[m_?MatrixQ]:=Sum[m[[i,j]]m[[k,l]],{i,1,Length[m]},{j,1,Length[m[[i]]]},{k,1,i-1},{l,j+1,Length[m[[i]]]}]

PermuteToReduceCrossings[{BigraphWithDuals[g1:GradedBigraph[m1___],d1_],BigraphWithDuals[g2:GradedBigraph[m2___],d2_]},k_Integer?OddQ]:=SortBy[{BigraphWithDuals[GradedBigraph@@(Take[{m1},k-1]~Join~{{m1}[[k]][[#]]}~Join~If[k<GraphDepth[g1],{{m1}[[k+1]][[All,#]]},{}]~Join~If[k+1>Length[{m1}],{},Drop[{m1},k+1]]),d1],BigraphWithDuals[GradedBigraph@@(Take[{m2},k-1]~Join~{{m2}[[k]][[#]]}~Join~If[k<GraphDepth[g2],{{m2}[[k+1]][[All,#]]},{}]~Join~If[k+1>Length[{m2}],{},Drop[{m2},k+1]]),d2]}&/@Permutations[RankAtDepth[g1,k]],NumberOfCrossings[#[[1,1,k]]]+NumberOfCrossings[#[[2,1,k]]]&][[1]]

PermuteToReduceCrossings[{BigraphWithDuals[g1:GradedBigraph[m1___],d1:DualData[dd1___]],BigraphWithDuals[g2:GradedBigraph[m2___],d2:DualData[dd2__]]},k_Integer?EvenQ]:={If[k>GraphDepth[g1],BigraphWithDuals[g1,d1],SortBy[BigraphWithDuals[GradedBigraph@@(Take[{m1},k-1]~Join~{{m1}[[k]][[#]]}~Join~If[k<GraphDepth[g1],{{m1}[[k+1]][[All,#]]},{}]~Join~If[k+1>Length[{m1}],{},Drop[{m1},k+1]]),DualData@@(Take[{dd1},k/2]~Join~{InversePermutation[#][[{dd1}[[k/2+1]][[#]]]]}~Join~Drop[{dd1},k/2+1])]&/@Permutations[RankAtDepth[g1,k]],NumberOfCrossings[#[[1,k]]]&][[1]]],
If[k>GraphDepth[g2],BigraphWithDuals[g2,d2],SortBy[BigraphWithDuals[GradedBigraph@@(Take[{m2},k-1]~Join~{{m2}[[k]][[#]]}~Join~If[k<GraphDepth[g2],{{m2}[[k+1]][[All,#]]},{}]~Join~If[k+1>Length[{m2}],{},Drop[{m2},k+1]]),DualData@@(Take[{dd2},k/2]~Join~{InversePermutation[#][[{dd2}[[k/2+1]][[#]]]]}~Join~Drop[{dd2},k/2+1])]&/@Permutations[RankAtDepth[g2,k]],NumberOfCrossings[#[[1,k]]]&][[1]]]}

PermuteToReduceCrossings[g_]:=PermuteToReduceCrossings[g]=Fold[PermuteToReduceCrossings,g,Range[GraphDepth[g[[1]]]]]

Graphs with dual data

HaagerupWithDuals=BigraphWithDuals[HaagerupBigraph,DualData[{1},{1},{1,2},{2,1}]]

DualHaagerupWithDuals=BigraphWithDuals[DualHaagerupBigraph,DualData[{1},{1},{1,2}]]

HaagerupAsaedaWithDuals=BigraphWithDuals[HaagerupAsaedaBigraph,DualData[{1},{1},{1},{1,2},{2,1,3},{1}]]

DualHaagerupAsaedaWithDuals=BigraphWithDuals[DualHaagerupAsaedaBigraph,DualData[{1},{1},{1},{1,2},{1}]]

End

End[];

End of package

EndPackage[];