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


ParityTest::usage="";


HaagerupTypeBranchTest::usage="HaagerupTypeBranchTest[g] checks if g satisfies the condition on p.33 of the pre-preprint of Quadratic Tangles";


Begin["`Private`"];


HaagerupTypeBranchingQ[b_GradedBigraph]:=
HasSimpleBranchQ[b]\[And](DimensionOfLowWeightSpace[b][DepthOfBranchPoint[b]+2]==0)


ParityTest[b_GradedBigraph]:=
DimensionOfGenerator[b]<=2\[Or]Not[HaagerupTypeBranchingQ[b]]\[Or]OddQ[DepthOfBranchPoint[b]]


HaagerupTypePrincipalQ[b_GradedBigraph]:=
HaagerupTypeBranchingQ[b]\[And](((List@@b)[[DepthOfBranchPoint[b]+2]])=={{1,0},{0,1}})


HaagerupTypeDualQ[b_GradedBigraph]:=
HaagerupTypeBranchingQ[b]\[And](((List@@b)[[DepthOfBranchPoint[b]+2]])=={{1,0},{1,0}})


QRule[b_GradedBigraph,q_]:=N[Solve[q^2+1 ==q*DimensionOfGenerator[b], q][[2]][[1]]]


Quantum[n_, b_GradedBigraph] :=Module[{q}, 
((q^n-q^{-n})/(q-q^{-1})/.(QRule[b,q]))[[1]]]


AlmostOneQ[x_]:=(Abs[x-1]<0.00001)


HaagerupTypeBranchTest[b_GradedBigraph]:=DimensionOfGenerator[b]<=2\[Or]
Not[HaagerupTypePrincipalQ[b]] \[Or]
(Module[{n=DepthOfBranchPoint[b]+1, larger=Max[NumericDimensionsByDepth[b][[DepthOfBranchPoint[b]+2]][[1]],NumericDimensionsByDepth[b][[DepthOfBranchPoint[b]+2]][[2]]],smaller=Min[NumericDimensionsByDepth[b][[DepthOfBranchPoint[b]+2]][[1]],NumericDimensionsByDepth[b][[DepthOfBranchPoint[b]+2]][[2]]]},
Or @@(AlmostOneQ/@Flatten[(w^{n}/.Solve[(larger/smaller)*w+(larger/smaller)^{-1}*w-2*w-(2w+w^2+1)/(Quantum[n+2,b]*Quantum[n,b])==0,w]) ])
])


End[];


EndPackage[];
