PairOdometer package

A subpackage for FusionAtlas v0.
March 29, 2009, Scott Morrison

Introduction

---text goes here---

Implementation

Start of package

Specify package dependencies:

BeginPackage["FusionAtlas`PairOdometer`",{"FusionAtlas`","FusionAtlas`Bigraphs`","FusionAtlas`Debugging`","FusionAtlas`GraphPairs`","FusionAtlas`JavaOdometer`","JLink`","FusionAtlas`PackageData`"}];

Usage messages

FindBigraphPairExtensionsUpToDepth::usage="";

FamiliesOfBigraphPairs;DisplayFamiliesOfBigraphPairs;

Internals

Begin["`Private`"];

Sadly, because of a bug in CanonicalizeBigraph (it's not stable under extensions), we can't use FindBigraphExtensionsUpToRankJava here. This function is just a copy that doesn't call CanonicalizeBigraph at all.

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==∞,-1,totalRank-GraphRank[g]],",",maximalLoops,")"];
{timing,expressionStrings}=AbsoluteTiming[Proxy`findExtensionsUpToRank[GraphToString[g],N[norm]+(10.^(-6)),If[totalRank==∞,-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,∞];
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,∞];
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)∧(GraphDepth[gd1[[1]]]==GraphDepth[gd2[[1]]]):=
 If[PairExtensionsPackaging∧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,∞,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

End[];

End of package

EndPackage[];