(* ::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.                                                         *)
(************************************************************************)



BeginPackage["FusionAtlas`FindGraphPartners`",{"FusionAtlas`","FusionAtlas`Bigraphs`","FusionAtlas`Debugging`","FusionAtlas`JavaOdometer`","FusionAtlas`PackageData`","FusionAtlas`FindAllBigraphs`","FusionAtlas`RemoteInterface`"}];


FindGraphPartners::usage="";


FindUnobstructedGraphPartners;


LazyFindGraphPartners;FindAllGraphPartners;


FindGraphPartnersTimeConstraint;


Begin["`Private`"];


GraphPartnerSeed[g_GradedBigraph]:=Module[{pos,branchDepth},
pos=Position[g,Except[{{1}}],{1},1,Heads->False];
If[pos=={},g,
branchDepth=pos[[1,1]]-1;
If[DimensionOfGenerator[g]>2\[And]g[[branchDepth+1]]=={{1},{1}}\[And]GraphDepth[g]>branchDepth+1,
Switch[g[[branchDepth+2]],
{{1,0},{0,1}},dualHaagerupFamilyBigraph[branchDepth],
{{0,1},{1,0}},dualHaagerupFamilyBigraph[branchDepth],
{{1,0},{1,0}},Most[haagerupFamilyBigraph[branchDepth]],
{{0,1},{0,1}},Most[haagerupFamilyBigraph[branchDepth]],
_,AnBigraph[branchDepth+1]
],
AnBigraph[branchDepth+1]
]
]
]


nextLowWeightSpaceDimensionBound[g_,rank_]:=Module[{w,r=GraphDepth[g]+1},
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}]+rank Min[Take[MatrixPower[GraphAdjacencyMatrix[g],r-1][[1]],-RankAtDepth[g,GraphDepth[g]]]^2]
]


MaximumExtensionRank[g0_,g1_]:=If[
DimensionOfGenerator[g0]<=2,\[Infinity],
Module[{rank},
Floor[rank/.Solve[DimensionOfLowWeightSpace[g0][GraphDepth[g1]+1]==nextLowWeightSpaceDimensionBound[g1,rank],rank][[1]]]
]
]


numberOfLongLoops[G_,g_]:=If[DimensionOfGenerator[G]<=2,
\[Infinity],
Module[
{w,r},
r=GraphDepth[g]+1;
w[n_]:=MatrixPower[GraphAdjacencyMatrix[g],2n][[1,1]];
DimensionOfLowWeightSpace[G][r]-Sum[(-1)^(r-n) (2r)/(r+n) Binomial[r+n,r-n]w[n],{n,0,r}]
]
]


FindGraphPartners[g_GradedBigraph]:=FindGraphPartners[g]=Module[{norm=DimensionOfGenerator[g],seed=GraphPartnerSeed[g],candidates,depth,stable},
stable=StableLowWeightSpaceDimensions[g];
(*We look for increasing deep graphs, up to GraphDepth[g]+1, checking as we go that the odd ranks match up, and that the stable dimensions match up.*)
depth=GraphDepth[seed];
DebugPrint["Using seed, ",seed];
candidates={seed};
candidates=Flatten[Reap[
If[depth>=GraphDepth[g]-1,Sow[candidates]];
While[depth<GraphDepth[g]+1,
depth++;
DebugPrint["Extending to depth ",depth];
candidates=Join@@(FindBigraphExtensionsUpToRank[norm][#,GraphRank[#]+Min[If[OddQ[depth],RankAtDepth[g,depth],\[Infinity]],MaximumExtensionRank[g,#]],numberOfLongLoops[g,#]/.\[Infinity]->-1]&/@candidates);
candidates=Union[candidates];
RequestObstructions[candidates];
DebugPrint["Found ",Length[candidates], " candidates."];
If[depth==GraphDepth[g]+1,
candidates=Cases[candidates,c_/;Abs[NumericDimensionOfGenerator[c]-norm]<10.^-6\[And]RootReduce[DimensionOfGenerator[c]-norm]==0];
DebugPrint["Reduce to ",Length[candidates], " candidates after checking norms."];
];
candidates=Cases[candidates,c_/;(EvenQ[depth]\[Or](RankAtDepth[c,depth]==RankAtDepth[g,depth]))\[And](norm<=2\[Or](ShorterPrefixOfLongerQ[StableLowWeightSpaceDimensions[c],stable]))];
DebugPrint["Reduced to ",Length[candidates], " candidates after checking low weight spaces."];
If[depth>=GraphDepth[g]-1,Sow[candidates]];
]
][[2,1]]];
candidates=Union[candidates];
DebugPrint[Length[candidates], " candidates before checking odd dimensions match."];
Cases[candidates,c_/;OddDimensionsMatchQ[c,g]]
];


OddDimensionsMatchQ[g1_,g2_]:=Module[{result=True},
result=(Floor[GraphDepth[g1]+1,2]==Floor[GraphDepth[g2]+1,2]);
If[result,
Do[If[!(result=DimensionSetsMatchQ[DimensionsByDepth[g1][[k]],DimensionsByDepth[g2][[k]]]),Break[]],{k,2,GraphDepth[g1]+1,2}]];
If[!result,DebugPrint["Odd dimensions for ",g1," and ",g2, " don't match."]];
result
]


DimensionSetsMatchQ[dimensions1_,dimensions2_]:=Module[{d1=Sort[dimensions1],d2=Sort[dimensions2],nd1=Sort[N[dimensions1]],nd2=Sort[N[dimensions2]],result=True},
result=(Length[dimensions1]==Length[dimensions2]);
If[result,Do[If[!(result=(Abs[nd1[[k]]-nd2[[k]]]<10.^-6)),Break[]],{k,1,Length[nd1]}]];
If[result,Do[If[!(result=(RootReduce[d1[[k]]-d2[[k]]]==0)),Break[]],{k,1,Length[nd1]}]];
result
]


ShorterPrefixOfLongerQ[x_,y_]:=Module[{shorter,longer},
If[Length[x]<Length[y],shorter=x;longer=y,shorter=y;longer=x];
(shorter==Take[longer,Length[shorter]])
]


FindUnobstructedGraphPartners[g_GradedBigraph]:=Cases[FindGraphPartners[g],c_/;Length[KnownObstructions[c]]==0]


LazyFindGraphPartners[g_]:=Module[{values,partners},
values=With[{gg=g},
MatchingValues[FindGraphPartners,HoldPattern[FindGraphPartners[gg]]]
];
If[Length[values]==0,$Failed,values[[1,2]]]
]


FindGraphPartnersTimeConstraint[g_GradedBigraph]:=0


TimeConstrainedFindGraphPartners[g_GradedBigraph,t_]:=
If[FindGraphPartnersTimeConstraint[g]>=t,
$Failed,
Module[{result},
result=TimeConstrained[FindGraphPartners[g],t];
If[result===$Aborted,
FindGraphPartnersTimeConstraint[g]=t;
$Failed,
FindGraphPartnersTimeConstraint[g]=0;
result
]
]
]


FindAllGraphPartners[t_,graphs:{__String}]:=FindAllGraphPartners[t,GraphFromString/@graphs]


FindAllGraphPartners[t_,graphs:{__GradedBigraph}]:=Module[{r},
PackageFindGraphPartners[];
(If[LazyFindGraphPartners[#]===$Failed\[And]t>FindGraphPartnersTimeConstraint[#],DebugPrint["Spending ", t," seconds looking for partners for ",DisplayBigraph[#]];r=TimeConstrainedFindGraphPartners[#,t];
RecordFindGraphPartners[{#}];
If[r=!=$Failed,PackageFindGraphPartners[]]])&/@graphs
]


FindAllGraphPartners[graphs_:(GraphsNeedingPartners[])]:=Module[{t=100},
While[Count[LazyFindGraphPartners/@graphs,$Failed]>0,FindAllGraphPartners[t*=10,graphs]]
]


End[];


EndPackage[];
