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


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" 


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\[Or]!(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\[Or]!(x>1),___}];
];
extras=Cases[#,(l:Except[d[_][__]]->r_):>(l==r)]&/@firstRound;
secondRound=Together[UnwrapLengthOneList[With[{vars2=Union[Cases[#,d[_][__],\[Infinity]]]},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[];


EndPackage[];
