FindGraphPartners package

A subpackage for FusionAtlas v0.
October 13, 2008, Scott Morrison

Introduction

---text goes here---

Implementation

Start of package

Specify package dependencies:

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

Usage messages

FindGraphPartners::usage="";

FindUnobstructedGraphPartners;

LazyFindGraphPartners;FindAllGraphPartners;

FindGraphPartnersTimeConstraint;

Internals

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∧g[[branchDepth+1]]=={{1},{1}}∧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,∞,
Module[{rank},
Floor[rank/.Solve[DimensionOfLowWeightSpace[g0][GraphDepth[g1]+1]==nextLowWeightSpaceDimensionBound[g1,rank],rank][[1]]]
]
]

numberOfLongLoops[G_,g_]:=If[DimensionOfGenerator[G]≤2,
∞,
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],∞],MaximumExtensionRank[g,#]],numberOfLongLoops[g,#]/.∞->-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))∧RootReduce[DimensionOfGenerator[c]-norm]==0];
DebugPrint["Reduce to ",Length[candidates], " candidates after checking norms."];
];
candidates=Cases[candidates,c_/;(EvenQ[depth]∨(RankAtDepth[c,depth]==RankAtDepth[g,depth]))∧(norm≤2∨(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∧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

End[];

End of package

EndPackage[];