(* ::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`PairOdometer`",{"FusionAtlas`","FusionAtlas`Bigraphs`","FusionAtlas`Debugging`","FusionAtlas`GraphPairs`","FusionAtlas`JavaOdometer`","JLink`","FusionAtlas`PackageData`"}];


FindBigraphPairExtensionsUpToDepth::usage="";


FamiliesOfBigraphPairs;DisplayFamiliesOfBigraphPairs;


Begin["`Private`"];


FindBigraphExtensionsUpToRankJavaNoCanonicalize[norm_][g_GradedBigraph,totalRank_,maximalLoops_:(-1)]:=FindBigraphExtensionsUpToRankJavaNoCanonicalize[norm][g,totalRank,maximalLoops]=Module[{timing,expressionStrings,expression,union,result},
If[totalRank-GraphRank[g]<=0,Return[{}]];
DebugPrint["Entering java ... ",g,".findExtensionsUpToRank(",norm,",",If[totalRank==\[Infinity],-1,totalRank-GraphRank[g]],",",maximalLoops,")"];
{timing,expressionStrings}=AbsoluteTiming[Proxy`findExtensionsUpToRank[GraphToString[g],N[norm]+10.^-6,If[totalRank==\[Infinity],-1,totalRank-FusionAtlas`Bigraphs`GraphRank[g]],maximalLoops]];
DebugPrint["... expression returned from java in ",timing," seconds, with ",Length[expressionStrings], " strings."];
If[expressionStrings===$Failed,
Print["It appears an error occurred in Java during FindBigraphExtensionsUpToRankJavaNoCanonicalize. Restarting Java and trying again ."];
ReinstallJava[];
Return[FindBigraphExtensionsUpToRankJavaNoCanonicalize[norm][g,totalRank,maximalLoops]];
];
expression=GraphFromString/@expressionStrings;
DebugPrint["Finished interpreting, ",Length[expression], " GradedBigraphs returned."];
union=Union[expression];
result=Cases[union,c_/;DimensionAtMostQ[norm][c]];
DebugPrint["... of which ",Length[result], " actually have small enough norm."];
result
]


CompareMagicNumbers[g_BigraphWithDuals,list:{___BigraphWithDuals}]:=CompareMagicNumbers[g,list,GraphDepth[g],GraphDepth[g]+3]


CompareMagicNumbers[g_BigraphWithDuals,list:{___BigraphWithDuals},start_,finish_]:=
Module[{w,m2,a,ag},
(*m2[h_]:=m2[h]=MatrixPower[GraphAdjacencyMatrix[h],2];
w[h_][0]:=w[h][0]=IdentityMatrix[GraphRank[h]];
w[h_][n_]:=w[h][n-1].m2[h];
a[h_][r_]:=Sum[(-1)^(r-n) (2r)/(r+n) Binomial[r+n,r-n]w[h][n][[1,1]],{n,0,r}];
ag[r_]:=ag[r]=a[g][r];
Cases[list,
h_/;((a[h][#]==ag[#])&/@(And@@Range[start,finish]))
];*)
DebugPrint["actually, totally ignoring magic numbers!"];
list
]


Options[FindBigraphPairExtensions]={"ChooseRepresentatives"->True};


FindBigraphPairExtensions[norm_][{gd1_BigraphWithDuals,gd2_BigraphWithDuals},options___]:=FindBigraphPairExtensions[norm][gd1,gd2,options]


FindBigraphPairExtensions[norm_][gd1_BigraphWithDuals,gd2_BigraphWithDuals,options___]/;(GraphDepth[gd1[[1]]]==GraphDepth[gd2[[1]]]):=FindBigraphPairExtensions[norm][gd1,gd2,options]=
Module[{g1=gd1[[1]],g2=gd2[[1]],
g1extensions,gd1extensions,g2extensions,gd2extensions,magicNumbers,compatibleLopsidedExtensions1,compatibleLopsidedExtensions2,lopsidedPairs,matchingExtensions,extendedPairs,
ChooseRepresentatives},
g1extensions=FindBigraphExtensionsUpToRankJavaNoCanonicalize[norm][g1,\[Infinity]];
gd1extensions=If[EvenQ[GraphDepth[g1]],
(* adding an odd layer, no new dual data *)
BigraphWithDuals[#,gd1[[2]]]&/@g1extensions,
(* adding an even layer, so add all possible dual data *)
Flatten[Function[{g},BigraphWithDuals[g,gd1[[2]]~Join~#]&/@DualDataList[RankAtDepth[g,GraphDepth[g]]]]/@g1extensions]
];
g2extensions=FindBigraphExtensionsUpToRankJavaNoCanonicalize[norm][g2,\[Infinity]];
gd2extensions=If[EvenQ[GraphDepth[g2]],
(* adding an odd layer, no new dual data *)
BigraphWithDuals[#,gd2[[2]]]&/@g2extensions,
(* adding an even layer, so add all possible dual data *)
Flatten[Function[{g},BigraphWithDuals[g,gd2[[2]]~Join~#]&/@DualDataList[RankAtDepth[g,GraphDepth[g]]]]/@g2extensions]
];
ChooseRepresentatives="ChooseRepresentatives"/.{options}/.Options[FindBigraphPairExtensions];

(* Now start building lopsided pairs. These are "leaves" not "branches", so we can apply more tests. *)
If[OddQ[GraphDepth[g1]],
(* Pick out extensions with low weight space dimensions that still matched the unextended second graph *)
DebugPrint["... comparing DimensionOfLowWeightSpace"];
(* This could be optimised a bit. Maybe we don't need to compute so many magic numbers. Also, we can stop once two disagree, rather than precomputing the lists. *)
(*DebugPrint["slow ", AbsoluteTiming[
magicNumbers[g_GradedBigraph]:=magicNumbers[g]=Table[DimensionOfLowWeightSpace[g][k],{k,GraphDepth[g1],GraphDepth[g1]+3}];
compatibleLopsidedExtensions1=Cases[gd1extensions,BigraphWithDuals[g_GradedBigraph,_DualData]/;magicNumbers[g]==magicNumbers[g2]];compatibleLopsidedExtensions2=Cases[gd2extensions,BigraphWithDuals[g_GradedBigraph,_DualData]/;magicNumbers[g]==magicNumbers[g1]];]];*)
DebugPrint["fast ",AbsoluteTiming[
compatibleLopsidedExtensions1=CompareMagicNumbers[gd2,gd1extensions];
compatibleLopsidedExtensions2=CompareMagicNumbers[gd1,gd2extensions];
]];
DebugPrint["... finished comparing (",Length[compatibleLopsidedExtensions1]+Length[compatibleLopsidedExtensions2],"/",Length[gd1extensions]+Length[gd2extensions],")"];

(* now build the pairs and appply an Ocneanu test: *)
lopsidedPairs=
Function[x,If[ChooseRepresentatives,ChooseIsomorphismRepresentatives[x],x]][Select[
({#,gd2}&/@compatibleLopsidedExtensions1)~Join~({#,gd1}&/@compatibleLopsidedExtensions2),
FullOcneanuTest@@#&]];,
(* No lopsided pairs when adding an odd depth *)
lopsidedPairs={}];
If[Length[gd1extensions]==0,
{lopsidedPairs,{}},
(* finally, work out the new branches *)
(* Should we just reuse the data from gd2extensions instead of running the odometer again? *)
matchingExtensions=FindBigraphExtensionsMatching[norm][gd2,gd1extensions];
extendedPairs=Reverse/@(Sort/@(Flatten[Function[{pair},{pair[[1]],#}&/@pair[[2]]]/@Transpose[{gd1extensions,matchingExtensions}],1]));If[ChooseRepresentatives,extendedPairs=ChooseIsomorphismRepresentatives[extendedPairs]];
{lopsidedPairs,extendedPairs}
]
];


Bin[{a_,A___},f_]:=With[{same=f[a,#]&/@{A}},{{a}~Join~Pick[{A},same]}~Join~Bin[Pick[{A},Not/@same],f]]
Bin[{},f_]:={}


ChooseIsomorphismRepresentatives[pairs:{{_BigraphWithDuals,_BigraphWithDuals}...}]:=With[{f={StableLowWeightSpaceDimensions[#[[1,1]]],Table[Sort[{RankAtDepth[#[[1,1]],k],RankAtDepth[#[[2,1]],k]}],{k,0,GraphDepth[#[[1,1]]]}]}&},
Module[{chunks,result},
DebugPrint["Splitting ",Length[pairs]," graph pairs by dimension and ranks..."];
chunks=SplitBy[SortBy[pairs,f],f];
DebugPrint["Choosing isomorphism class representatives..."];
result=Join@@(Last/@Bin[#,GraphPairsIsomorphicQ]&/@chunks);
DebugPrint["... finished choosing isomorphism class representatives: ",Length[result]];
result
]
]


ExtendDualDataAsWell[short_BigraphWithDuals,shortExtension_GradedBigraph,long_BigraphWithDuals]:=Module[{extensionsWithDuals},
extensionsWithDuals=If[OddQ[GraphDepth[shortExtension]],
(* adding an odd layer *)
{BigraphWithDuals[shortExtension,short[[2]]]},
(* adding an even layer *)
BigraphWithDuals[shortExtension,short[[2]]~Join~#]&/@DualDataList[RankAtDepth[shortExtension,GraphDepth[shortExtension]]]
];

Cases[extensionsWithDuals,gd_/;PartialOcneanuTest[gd,long]]
]


FindBigraphExtensionsMatching[norm_][short_BigraphWithDuals,longs:{}]:={}


FindBigraphExtensionsMatching[norm_][short_BigraphWithDuals,longs:{__BigraphWithDuals}]:=
Module[{extensionsList,result},
extensionsList=FindBigraphExtensionsMatching[norm][First[short],First/@longs];
DebugPrint["... extending dual data as well."];
result=(Function[{pair},Flatten[ExtendDualDataAsWell[short,#,pair[[1]]]&/@pair[[2]]]]/@Transpose[{longs,extensionsList}]);
DebugPrint["... finished extending dual data."];
result
]


FindBigraphExtensionsMatching[norm_][short_BigraphWithDuals,long_BigraphWithDuals]:=FindBigraphExtensionsMatching[norm][short,{long}][[1]]


FindBigraphPairExtensionsList[norm_][{LeafList_,BranchList_,weeds_:{}},options___]:=Module[{k=0,BranchList0,NewLeafList,NewBranchList,tr},
(* weed out any bad seeds *)
BranchList0=Complement[BranchList,weeds];
tr[{}]={{},{}};
tr[L_]:=Transpose[L];
{NewLeafList,NewBranchList}=Flatten[#,1]&/@tr[(DebugPrint["Starting FindBigraphPairExtensions on branch ",++k," of ",Length[BranchList]];FindBigraphPairExtensions[norm][#,options])&/@BranchList0];
{LeafList~Join~NewLeafList~Join~Select[BranchList,(FullOcneanuTest@@#)&],NewBranchList,weeds}]


(* this returns a pair of lists of pairs; the first list is all the leaves, that is, graphs at intermediate depths, that also pass the complete-graph Ocneanu test, and the second list is the list of branches, that is, graphs which could potentially be extended to greater depths.*)
FindBigraphPairExtensionsUpToDepth[norm_][gd1_BigraphWithDuals,gd2_BigraphWithDuals,extraDepth_Integer,options___]/;(extraDepth>0)\[And](GraphDepth[gd1[[1]]]==GraphDepth[gd2[[1]]]):=
 If[PairExtensionsPackaging\[And]LoadPairExtensions[gd1[[1]]],FindBigraphPairExtensionsUpToDepth[norm][gd1,gd2,extraDepth,options], 
Module[{result},
result=
FindBigraphPairExtensionsList[norm][FindBigraphPairExtensionsUpToDepth[norm][gd1,gd2,extraDepth-1,options],options];
FindBigraphPairExtensionsUpToDepth[norm][gd1,gd2,extraDepth,options]=result; 
 If[PairExtensionsPackaging,PackagePairExtensions[gd1[[1]]]]; 
result
] 
]


PairExtensionsPackaging=True;


FindBigraphPairExtensionsUpToDepth[norm_][gd1_BigraphWithDuals,gd2_BigraphWithDuals,0,options___]/;(GraphDepth[gd1[[1]]]==GraphDepth[gd2[[1]]]):=
{{},{{gd1,gd2}},"Weeds"/.{options}/.{"Weeds"->{}}}


FindBigraphPairExtensionsUpToDepth[norm_][gd1_BigraphWithDuals,gd2_BigraphWithDuals,\[Infinity],options___]/;(GraphDepth[gd1[[1]]]==GraphDepth[gd2[[1]]]):=
Module[{result,k=0},
While[
DebugPrint["Calculating FindBigraphPairExtensionsUpToDepth[",norm,"][",DisplayBigraph[gd1],", ",DisplayBigraph[gd2],", ",k,", ",options,"]"];
Length[(result=FindBigraphPairExtensionsUpToDepth[norm][gd1,gd2,k,options])[[2]]]>0,
++k;
];
result
]


LoadPairExtensions[g_GradedBigraph]:=Module[{},
Off[Get::noopen,Needs::nocont];
Needs["FusionAtlas`Data`"<>GraphToString[g]<>"`PairExtensions`"];
On[Get::noopen,Needs::nocont];
LoadPairExtensions[g]=False;
True
]


FamiliesOfBigraphPairs[list:{{_BigraphWithDuals,_BigraphWithDuals}...}]:=With[{f=DimensionOfGenerator[#[[1,1]]]&},
SplitBy[SortBy[list,f],f]
]


DisplayFamiliesOfBigraphPairs[list:{{_BigraphWithDuals,_BigraphWithDuals}...}]:=With[{f=DimensionOfGenerator[#[[1,1]]]&},
Map[DisplayBigraph,FamiliesOfBigraphPairs[list],{3}]//TableForm
]


End[];


EndPackage[];
