FusionAtlasPaths={"~/projects/fusionatlas/package/"};
$Path=$Path~Join~FusionAtlasPaths;
<<FusionAtlas`

PermuteVerticesAtDepth[g_GradedBigraph,k_,p_]:=Module[{l=List@@g},
If[k>GraphDepth[g],
g,
GradedBigraph@@(If[k>0,Take[l,k-1],{}]~Join~If[k>0,{l[[k,p]]},{}]~Join~If[k<GraphDepth[g],{l[[k+1,All,p]]},{}]~Join~If[k<GraphDepth[g],Drop[l,k+1],{}])
]
]

PermuteVerticesAtDepth[d_DualData,k_,p_]:=If[
EvenQ[k],
Module[{l=List@@d,length},
length=Length[l];
If[k/2+1>length,
d,
DualData@@(If[k>0,Take[l,k/2],{}]~Join~If[k>0,{Permute[Permute[InversePermutation[p],l[[k/2+1]]],p]},{}]~Join~If[k/2+1<length,Drop[l,k/2+1],{}])]
],
d
]

PermuteVerticesAtDepth[g_BigraphWithDuals,k_,p_]:=
BigraphWithDuals[PermuteVerticesAtDepth[g[[1]],k,p],PermuteVerticesAtDepth[g[[2]],k,p]]

AllPermutationsAtDepth[g_GradedBigraph,k_]:=Union[PermuteVerticesAtDepth[g,k,#]&/@Permutations[Range[RankAtDepth[g,k]]]]
AllPermutationsAtDepth[l:{___GradedBigraph},k_]:=Union[Flatten[AllPermutationsAtDepth[#,k]&/@l,1]]

AllPermutationsAtDepth[g_BigraphWithDuals,k_]:=PermuteVerticesAtDepth[g,k,#]&/@Permutations[Range[RankAtDepth[g[[1]],k]]]
AllPermutationsAtDepth[{g1_BigraphWithDuals,g2_BigraphWithDuals},k_]:=
If[EvenQ[k],
Flatten[Outer[List,AllPermutationsAtDepth[g1,k],AllPermutationsAtDepth[g2,k]],1],
Thread[List[AllPermutationsAtDepth[g1,k],AllPermutationsAtDepth[g2,k]]]
]

AllPermutationsOfFirstGraphAtDepth[{g1_BigraphWithDuals,g2_BigraphWithDuals},k_]:=
If[EvenQ[k],
Flatten[Outer[List,AllPermutationsAtDepth[g1,k],{g2}],1],
Thread[List[AllPermutationsAtDepth[g1,k],AllPermutationsAtDepth[g2,k]]]
]

NewFindGraphPartners[g_GradedBigraph]:=
Module[
{norm=(Sqrt[GraphIndex[g]]),candidatePairs,lastCandidates},
candidatePairs[1]={{BigraphWithDuals[GradedBigraph[{{1}}],DualData[{1}]],BigraphWithDuals[GradedBigraph[{{1}}],DualData[{1}]]}};
(* candidatePairs[j_]:=Select[Select[
Flatten[FindBigraphPairExtensionsUpToDepth[norm][#[[1]],#[[2]],1,"ChooseRepresentatives"->False][[2]]&/@ candidatePairs[j-1],1],
( #[[1,1]][[1;;j]]==g[[1;;j]]∨#[[2,1]][[1;;j]]==g[[1;;j]])&],TriplePointObstruction]; *)

(*First, get rid of things that have the wrong number of vertices at the current depth.
(Possibly switching the order of the principal and dual in the process.).
Take all permutations of the vertices of the remaining pairs of bigraphs.
Then get rid of the ones that aren't equal to g up to the current depth.*)
candidatePairs[j_]:=Select[Select[ 
Union[Flatten[
 AllPermutationsOfFirstGraphAtDepth[#,j]&/@
Select[
Flatten[FindBigraphPairExtensionsUpToDepth[norm][#[[1]],#[[2]],1,"ChooseRepresentatives"->False][[2]]&/@ candidatePairs[j-1],1],
(RankAtDepth[#[[1,1]],j]==RankAtDepth[g,j])&]
~Join~
Select[
Flatten[Reverse/@(FindBigraphPairExtensionsUpToDepth[norm][#[[1]],#[[2]],1,"ChooseRepresentatives"->False][[2]]&/@ candidatePairs[j-1]),1],
(RankAtDepth[#[[1,1]],j]==RankAtDepth[g,j])&] ,
1] ],
#[[1,1]][[1;;j]]==g[[1;;j]] &],TriplePointObstruction];


Do[
Print[{DisplayBigraph/@candidatePairs[j],candidatePairs[j]}],{j,1,GraphDepth[g]}];

(* Deciding what goes here is subtle! *)
(* If g has odd depth, GraphDepth[g']-GraphDepth[g] == 0 or 1 *)
(* If g has even depth, GraphDepth[g']-GraphDepth[g] == 0 or -1 *)
(* I'm pretty sure this catches everything: the vines from a pair of graphs will either be that same pair of graphs (if they pass the full Ocneanu test) or a pair of graphs of unequal depths. *)
lastCandidates=
candidatePairs[GraphDepth[g]-1]~Join~candidatePairs[GraphDepth[g]];

(* ChooseIsomorphismRepresentatives[Select[
Flatten[FindBigraphPairExtensionsUpToDepth[norm][#[[1]],#[[2]],1][[1]]&/@lastCandidates,1],
( #[[1,1]]==g∨#[[2,1]]==g)&] ] *)
ChooseIsomorphismRepresentatives[Select[
Flatten[FindBigraphPairExtensionsUpToDepth[norm][#[[1]],#[[2]],1][[1]]&/@lastCandidates,1],
Or@@( Thread[#[[1,1]]==AllPermutationsAtDepth[g,GraphDepth[g]]]~Join~Thread[#[[2,1]]==AllPermutationsAtDepth[g,GraphDepth[g]]])&] ]
]

DisplayBigraph[g=GraphFromString["gbg1v1p1v1x0p0x1v1x0p1x0p1x0p0x1v0x0x1x1v1"]]

DimensionOfGenerator[g]

SetDebugMode[True]

partners=NewFindGraphPartners[g]

DisplayBigraph/@partners

SetDebugMode[False]

Length[FindFusionRules@@#]&/@partners

FormalCodegrees@@partners[[1]]

FormalCodegrees@@partners[[2]]

ReducedDimensionsByDepth[partners[[1,1,1]]][[1;;-1;;2]]

ReducedDimensionsByDepth[partners[[2,1,1]]][[1;;-1;;2]]

NewFindGraphPartners[HaagerupBigraph]

DisplayBigraph/@%

NewFindGraphPartners[DualHaagerupBigraph]
DisplayBigraph/@%

Testing on Asaeda-Haagerup also produces too many partners

NewFindGraphPartners[HaagerupAsaedaBigraph]

DisplayBigraph/@%

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

NewFindGraphPartners[g]
DisplayBigraph/@%

NewFindGraphPartners[S4S5Bigraph]
DisplayBigraph/@%