FusionAtlas`RelativeDimensions` package

A subpackage for FusionAtlas v0.
December 9, 2009, Scott Morrison and David Penneys

Introduction

---text goes here---

Implementation

Start of package

Specify package dependencies:

BeginPackage["FusionAtlas`RelativeDimensions`",{"FusionAtlas`","FusionAtlas`Bigraphs`","FusionAtlas`Debugging`","FusionAtlas`GraphPairs`"}];

Usage messages

RelativeDimensionsByDepthEquations::usage="given a seed and its dual seed with dual data, compiles differences created by EigenvalueEquations, EvenDualData, OddDualData, and SupertransitivityEquations. t is the truncation.";

SolveRelativeDimensionsByDepthEquations::usage="given a seed and its dual seed with dual data, equates the compiled differences to zero and tries to solve for as many bimodule dimensions as possible. Note n is even. t is the truncation";

RelativeBranchFactor::usage=="given a seed and its dual seed with dual data, computes possible values of r, the ratio of the dimensions of the objects one past the branch point. Note n is even. t is truncation.";

RelativeDimensionsByDepth::usage == "computes the dimensions of all bimodules as functions of d, a dummy variable for unknown dimensions; n, the additional supertransitivity; and q"

RelativeDimensionsConditions::usage == "computes extra identities between n and q that must be satisfied. it's nearly always the empty list"

PositiveOmegaInequality::usage == "computes omega plus omega inverse minus two, a quantity which, when positive, rules out a principal graph"

Internals

Begin["`Private`"];

EigenvalueEquations[g_GradedBigraph,d_,q_,t:(0|1)] := Module[{dimensionvariables},
dimensionvariables=Flatten[Table[d[i,j],{i,0,GraphDepth[g]},{j,1,RankAtDepth[g,i]}]];
Take[GraphAdjacencyMatrix[g].dimensionvariables-(q+q^(-1))dimensionvariables,{2,-RankAtDepth[g,GraphDepth[g]]-t}]]

EigenvalueEquations::usage="Given a seed for a potential principal graph, computes differences which, when set equal to zero, are the eigenvalue equations for all vertices which are not at the beginning or end of the seed, i.e., those vertices for which we know all the local data. t is the truncation.";

EvenDualEquations[dd_DualData,d_] := Flatten[Table[d[2i-2,j]-d[2i-2,dd[[i,j]]],{i,1,Length[dd]},{j,1,Length[dd[[i]]]}]]

EvenDualEquations::usage="Given a seed for a potential principal graph with dual data, computes differences which, when set equal to zero, equate the dimensions of bimodules which are dual to each other corresponding to the even vertices.";

OddDualEquations[g1_GradedBigraph,g2_GradedBigraph, d1_,d2_]:= Flatten[Table[d1[i,j]-d2[i,j],{i,1,GraphDepth[g1],2},{j,1,RankAtDepth[g1,i]}]]

OddDualEquations::usage="Given a seed and a dual seed with dual data, computes differences which, when set equal to zero, equate the dimensions of bimodules which are dual to each other corresponding to the odd vertices on the seed and dual seed.";

SupertransitivityEquation[g_GradedBigraph,n_,d_,q_] := {d[0,1]-qI[n+1],Sum[d[1,i],{i,1,RankAtDepth[g,1]}]-qI[n+2]}

qi[n_,q_]:=(q^(n)-q^(-n))/(q-q^(-1))

SupertransitivityEquation::usage="Given a seed for a principal graph with arbitrary supertransitivity, produces a difference which, when set equal to zero, equates the dimension of the first vertex in the seed to [n+1].";

RelativeDimensionsByDepthEquations[BigraphWithDuals[g1_GradedBigraph,dd1_DualData],BigraphWithDuals[g2_GradedBigraph,dd2_DualData],n_,d_,q_,t:(0|1)] := DeleteCases[EigenvalueEquations[g1,d[1],q,t]~Join~EigenvalueEquations[g2,d[2],q,t]~Join~EvenDualEquations[dd1,d[1]]~Join~EvenDualEquations[dd2,d[2]]~Join~OddDualEquations[g1,g2,d[1],d[2]],0]~Join~SupertransitivityEquation[g1,n,d[1],q]~Join~SupertransitivityEquation[g2,n,d[2],q]

UnwrapLengthOneList[{x_}]:=x
UnwrapLengthOneList[y_]:=$Failed

SolveRelativeDimensionsByDepthEquations[g1_BigraphWithDuals,g2_BigraphWithDuals,t:(0|1)]:=
SolveRelativeDimensionsByDepthEquations[g1,g2,t]=
Function[{d,n,q},
Evaluate[
Module[{vars,firstRound,extras,secondRound,thirdRound,fourthRound},
vars=DeleteCases[Flatten[Table[d[1][i,j],{i,0,GraphDepth[g1]},{j,1,RankAtDepth[g1,i]}]~Join~Table[d[2][i,j],{i,0,GraphDepth[g2]},{j,1,RankAtDepth[g2,i]}](*~Join ~{q,qI[n+1],qI[n+2]}*)],_?NumericQ];
firstRound=
DeleteCases[Sort/@Together[Solve[RelativeDimensionsByDepthEquations[g1,g2,n,d,q,t]==0,vars]/.qI[m_]:>qi[m,q]/.(x_->y_):>(x->RootReduce[y])],
{___,q->x_/;Im[x]≠0∨!(x>1),___}];
If[firstRound=={},
firstRound=
DeleteCases[Sort/@Together[Solve[RelativeDimensionsByDepthEquations[g1,g2,n,d,q,t]==0,vars~Join ~{q,qI[n+1],qI[n+2]}]/.qI[m_]:>qi[m,q]/.(x_->y_):>(x->RootReduce[y])],
{___,q->x_/;Im[x]≠0∨!(x>1),___}];
];
extras=Cases[#,(l:Except[d[_][__]]->r_):>(l==r)]&/@firstRound;
secondRound=Together[UnwrapLengthOneList[With[{vars2=Union[Cases[#,d[_][__],∞]]},Solve[Take[#,Length[vars2]],vars2]]]]&/@extras;
thirdRound=Together[(#[[1]]/.#[[2]])~Join~#[[2]]]&/@Transpose[{firstRound,secondRound}];
fourthRound=Sort/@(DeleteCases[#,True]&/@(thirdRound/.
(l:Except[d[_][__]]->r_):>(l==r)))
]
]
]

RelativeDimensionsByDepth[g1_BigraphWithDuals,g2_BigraphWithDuals,t:(0|1):1]:=
Function[{d,n,q},
Evaluate[
Module[{g,sols},
{g[1],g[2]}={g1,g2};
sols=DeleteCases[UnwrapLengthOneList[SolveRelativeDimensionsByDepthEquations[g1,g2,t][d,n,q]],HoldPattern[_==_]];
Table[d[k][m,l]/.sols,{k,1,2},{m,0,GraphDepth[g[k]]},{l,1,RankAtDepth[g[k],m]}]
]
]]

RelativeDimensionsConditions[g1_BigraphWithDuals,g2_BigraphWithDuals,t:(0|1):1]:=
Function[{d,n,q},
Evaluate[
Simplify[DeleteCases[UnwrapLengthOneList[SolveRelativeDimensionsByDepthEquations[g1,g2,t][d,n,q]],HoldPattern[_->_]]]
]]

RelativeBranchFactor[g1_BigraphWithDuals,g2_BigraphWithDuals,t:(0|1):1] := 
Function[{d,n,q},
Evaluate[
Together[With[{S=UnwrapLengthOneList[DeleteCases[#,HoldPattern[_==_]]&/@SolveRelativeDimensionsByDepthEquations[g1,g2,t][d,n,q]]},d[1][DepthOfBranchPoint[g1]+1,1]/d[1][DepthOfBranchPoint[g1]+1,2]/.S]]
]
]

OmegaPlusOmegaInverse[g1_BigraphWithDuals,g2_BigraphWithDuals,t:(0|1):1] :=
Function[{d,n,q},
Evaluate[
qi[n+DepthOfBranchPoint[g1]+1,q]qi[n+DepthOfBranchPoint[g1]+3,q](RelativeBranchFactor[g1,g2,t][d,n,q]+(((RelativeBranchFactor[g1,g2,t][d,n,q]))^(-1))-2)-2
]]

PositiveOmegaInequality[g1_BigraphWithDuals,g2_BigraphWithDuals,t:(0|1):1] :=Function[{d,n,q},
Evaluate[
Together[OmegaPlusOmegaInverse[g1,g2,t][d,n,q] -2]
]]

End

End[];

End of package

EndPackage[];