FusionAtlasPaths={"~/projects/fusionatlas/code/package/","~/Documents/research/fusionatlas/code/package/","C:\\Documents and Settings\\James Tener\\My Documents\\Research\\fusionatlas\\code\\package\\"};
$Path=$Path~Join~FusionAtlasPaths;
<<FusionAtlas`

Hexagon=GradedBigraph[{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{0,1}},{{1,1}}];

HexagonWithTail=GradedBigraph[{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{0,1}},{{1,1}},{{1}},{{1}}];

Families11={{BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{1,0},{1,0}}],DualData[{1},{1},{1,2}]],BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{0,1},{0,1}},{{1,0,0},{1,0,0},{0,1,0},{0,0,1}}],DualData[{1},{1},{1,2},{3,4,1,2}]]},{BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1},{1}},{{1,0},{1,0},{0,1}},{{0,0,1},{1,0,0}},{{1,0}}],DualData[{1},{1},{1,3,2},{1}]],BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1},{1}},{{1,0},{1,0},{0,1}},{{1,0,0},{0,0,1}},{{0,1}}],DualData[{1},{1},{1,3,2},{1}]]},{BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1},{1}},{{1,0},{1,0},{0,1}},{{1,0,0},{0,0,1}},{{0,1}}],DualData[{1},{1},{1,3,2},{1}]],BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1},{1}},{{1,0},{1,0},{0,1}},{{0,0,1},{1,0,0}},{{1,0}}],DualData[{1},{1},{1,3,2},{1}]]},{BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{1,0},{0,1}},{{0,1,0},{0,0,1}},{{0,1}}],DualData[{1},{1},{1,2},{2,1}]],BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{0,1},{0,1}},{{1,0,0},{0,1,0}},{{1,0}}],DualData[{1},{1},{1,2},{2,1}]]},{BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1},{1}},{{1,0},{1,0},{0,1}},{{0,0,1},{1,0,0},{1,0,0}},{{1,0,0},{1,0,0},{0,1,0}},{{0,1,0}}],DualData[{1},{1},{1,3,2},{1,3,2}]],BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1},{1}},{{1,0},{1,0},{0,1}},{{1,0,0},{1,0,0},{0,0,1}},{{0,1,0},{0,0,1},{0,0,1}},{{0,1,0}}],DualData[{1},{1},{1,3,2},{2,1,3}]]},{BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1},{1}},{{1,0},{1,0},{0,1}},{{1,0,0},{1,0,0},{0,0,1}},{{0,1,0},{0,0,1},{0,0,1}},{{0,1,0}}],DualData[{1},{1},{1,3,2},{2,1,3}]],BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1},{1}},{{1,0},{1,0},{0,1}},{{0,0,1},{1,0,0},{1,0,0}},{{1,0,0},{1,0,0},{0,1,0}},{{0,1,0}}],DualData[{1},{1},{1,3,2},{1,3,2}]]},{BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{1,0},{0,1}},{{0,1,0},{0,0,1},{0,0,1}},{{0,1,0},{1,0,0}},{{0,1}},{{1}}],DualData[{1},{1},{1,2},{2,1,3},{1}]],BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{0,1},{0,1}},{{1,0,0},{0,1,0},{0,0,1}},{{1,0,0},{0,0,1}},{{1,0},{0,1}},{{1,0}},{{1}}],DualData[{1},{1},{1,2},{2,1,3},{2,1},{1}]]},{BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{1,0},{0,1}},{{1,0,0},{0,1,0},{0,0,1}},{{1,0,0},{0,0,1}},{{1,0},{0,1}},{{0,1}},{{1}}],DualData[{1},{1},{1,2},{1,3,2},{2,1},{1}]],BigraphWithDuals[GradedBigraph[{{1}},{{1}},{{1}},{{1},{1}},{{1,0},{0,1},{0,1}},{{1,0,0},{1,0,0},{0,1,0}},{{0,0,1},{0,1,0}},{{1,0}},{{1}}],DualData[{1},{1},{1,2},{1,3,2},{1}]]}};

Families11Graphs=Flatten[Families11[[All,All,1]]];

Map[DisplayBigraph,Families11,{2}]

OcneanuDisplay[Families11[[1,1]],Families11[[1,2]]]

(*LaurentDegree[p_,x_]:=Exponent[p,x]+Exponent[p,x,-#&]*)

TestAForm[g_GradedBigraph]:=Module[{q},TestAForm[FindA[g,q],q]];
TestAForm[A_,q_]:=Module[{poly=Expand[q (A/.q->q^(-1))]},
And[Exponent[A,q]==1,Coefficient[A,q]==1,Select[CoefficientList[poly-1,q],#≤0&]==CoefficientList[poly-1,q]]];

CPrint[condition_,x_List]:=If[condition,Print@@x];
CPrint[condition_,x_]:=If[condition,Print[x];];

FindFj[g_GradedBigraph,q_,j_]:=Module[{x},Expand[(-1)^(GraphRank[g]+j)CharacteristicPolynomial[GraphAdjacencyMatrix[Translate[g,j]],x]/.x->(q+q^(-1))]]

FindModifiedFj[g_GradedBigraph,q_,j_]:=Expand[(q-q^(-1))FindFj[g,q,j]]

CheckA[g_GradedBigraph,candidate_,q_]:=Module[{n=GraphRank[g]},
And[Expand[q^n candidate - q^(-n)(candidate /. q->q^(-1))]==FindModifiedFj[g,q,0],Expand[q^(n+1) candidate - q^(-n-1)(candidate /. q->q^(-1))]==FindModifiedFj[g,q,1]]
];

FindAandj[g_GradedBigraph,q_, maxsteps_Integer:50] :=
Module[{n=GraphRank[g],j,oldcandidate=0,candidate},
For[j=n,j≤n+maxsteps,j++,
candidate = Expand[q^(-n-j)( FindModifiedFj[g,q,j]/.q^(n_/;n<0)->0)];
If[And[candidate==oldcandidate,CheckA[g,candidate,q]],Return[{candidate,j}];];
oldcandidate=candidate;
];
Message["Not found.  Try more steps?"];
Return[$Failed];
];

FindA[g_GradedBigraph,q_, maxsteps_Integer:50] :=FindAandj[g,q, maxsteps][[1]]

Findj[g_GradedBigraph,q_, maxsteps_Integer:50] :=FindAandj[g,q, maxsteps][[2]]

FindN[g_GradedBigraph,loud_:True,maxsteps_Integer:50]:=Module[{q,CGamma,RBound},
CGamma=FindCGamma[g,maxsteps];
RBound=BoundR[g,loud,maxsteps];
CPrint[loud,{"C(Γ): ",CGamma,". |R|≤",RBound,". N≤",4*CGamma+9*RBound}];
4*CGamma+9*RBound];

FindCGamma[g_GradedBigraph,maxsteps_Integer:50]:=Module[{q},Round[Total[(q/.NSolve[FindFj[g,q,Findj[g,q,maxsteps]]==0])^4]]];

FactorSymmetric[F_,q_]:=Module[{factorlist=FactorList[F],result},
result=(Times @@ Power @@@ # &) /@ GatherBy[factorlist,And[#[[2]]>0,(*Exponent[#[[1]],q]≠0,*)SymmetricPolynomialQ[#[[1]],q]]&]
(*If[Length[result]==1,If[SymmetricPolynomialQ[result[[1]],q],{1,result[[1]]},{result[[1]],1}],result]*)
];

(* This can be improved by comparing F(q) and F(q^(-1)) *)
SymmetricPolynomialQ[F_,q_]:=Module[{coefficientlist=CoefficientList[F,q],powerlist=Exponent[#,q]&/@ MonomialList[F]},
And[Or[coefficientlist==Reverse[coefficientlist],coefficientlist==-Reverse[coefficientlist]],powerlist==Exponent[F,q]-Reverse[powerlist]]
];

CountRootsOfUnity[P_,q_]:=Length[Select[q/.Solve[P==0,q],RootOfUnityQ]]

HalfIfEven[n_Integer]:=If[Mod[n,2]==0,n/2,n];

SignChanges[A_,q_]:=Length[Split[Select[CoefficientList[A*q^(Exponent[A,q,-#&]),q],#≠0&],#1*#2>0&]]-1

GetRForSymmetricFactors[F_,q_]:=Module[{roots=q/.Solve[F==0,q],rootsofunity,nonrootsofunity},
If[Not[ListQ[roots]],0,
Fold[If[Or[#2[[2]]>1,RootOfUnityQ[#2[[1]]]],#1+If[Or[#2[[1]]==1,#2[[1]]==-1],#2[[2]],#2[[2]]/2],#1]&,0,Tally[roots]]]
];

GetRForCircleRoots[F_,q_]:=Module[{roots=q/.Solve[F==0,q],rootsofunity,nonrootsofunity},
If[Not[ListQ[roots]],0,
Fold[If[
Or[And[Not[Element[#2[[1]],Reals]],#2[[2]]>1],
RootOfUnityQ[#2[[1]]]],
#1+If[Or[#2[[2]]==1,#2[[2]]==-1],#2[[2]],#2[[2]]/2],#1]&,0,Tally[roots]]]]

BoundCyclotomicR[A_,q_,symmetricdegree_Integer,loud_:True,maxsteos_Integer:50]:=Module[{l,m,negativepower,lengthA,s,kthrootbound,dividends,k,zetak,r,goodk={},period},
l=Exponent[Expand[A],q,Abs[#]&];
m=Max[Exponent[Expand[q^l A],q],Exponent[Expand[q^l (A /.q->q^(-1))],q]];
negativepower=-Exponent[Expand[A],q,-#&];
lengthA=Length[MonomialList[Expand[q^(-negativepower) A]]];
s=Fold[Times,1,Table[Prime[k],{k,1,PrimePi[2*lengthA]}]];
kthrootbound=2*s*m;
dividends=Table[j*s,{j,1,2*m}];
CPrint[loud,kthrootbound];

For[k=3,k≤kthrootbound,k++,
If[Mod[k,10000]==0,CPrint[loud,k];];
If[Or@@(Mod[#,k]==0&/@dividends),
zetak=Exp[2Pi I /k];
r=(A/.q->Conjugate[zetak])/(A/.q->zetak);
If[RootReduce[Together[r^HalfIfEven[k]-1==0]],
For[n=0,n<HalfIfEven[k],n+=1,
If[RootReduce[Together[r-zetak^(2n+symmetricdegree)==0]],
(*Print["zeta ",k," is a root of F",n," with multiplicity ",N[GetMultiplicity[FindFj[g,q,Mod[n-GraphRank[g],HalfIfEven[k]]],q,zetak]]];*)
CPrint[loud,{"zeta ",k," is a root of F",n}];
goodk=Union[goodk,{{k,n}}]];
];
];
];
];

period =HalfIfEven[LCM @@ goodk[[All,1]]];

(*Print[ (GetRForPol[#,q]&/@Table[FindFj[g,q,j],{j,1,period}])];*)
(*Print[(Total[(( (#[[3]]-GetMultiplicity[symmetricfactors,q,Exp[2Pi I/#[[1]]]])*Exponent[Cyclotomic[#[[1]],q],q] )/2&)/@ #]+(symmetricdegree+GetMultiplicity[symmetricfactors,q,1]+GetMultiplicity[symmetricfactors,q,-1])/2 &) /@ Table[Select[goodk,Mod[2*#[[2]]-2*p,#[[1]]]==0&],{p,1,period}]];*)
1/2*(Max@@(Total[(Exponent[Cyclotomic[#[[1]],q],q] &)/@ #]&) /@ Table[Select[goodk,Mod[2*#[[2]]-2*p,#[[1]]]==0&],{p,1,period}])
];

BoundR[g_GradedBigraph,loud_:True,maxsteps_Integer:50]:=Module[{A,m,periodbound,j,n,lengthA,s,kthrootbound,k,zetak,r,goodk={},newA,symmetricfactors,symmetricdegree,negativepower,period,l,dividends,lcmdividends,q},
A=FindA[g,q,maxsteps];
{symmetricfactors,newA}=FactorSymmetric[A,q];
symmetricdegree=Exponent[symmetricfactors,q];

BoundCyclotomicR[newA,q,symmetricdegree,loud,maxsteps]+
Min[GetRForSymmetricFactors[symmetricfactors,q]+If[SignChanges[newA,q]==1,0,2*SignChanges[newA,q]+1],
GetRForCircleRoots[symmetricfactors,q]+If[SignChanges[A,q]==1,0,2*SignChanges[A,q]]]
(* REPORT THE NUMBER THAT MAKES THE ASSUMPTION THAT REPEATED  ROOTS ON CIRCLE ARE  IN symmetricfactors VALID  *)
];

Expand[FindModifiedFj[HaagerupBigraph,q,17]]

(Length[Split[Select[CoefficientList[FindModifiedFj[HaagerupBigraph,q,17]q^28,q],#≠0&],#1*#2>0&]]-1)-1

? SplitBy

FindN[HaagerupBigraph]

Expand[((-1-(q$6111^2)-(q$6111^4)+(q$6111^6))/(q$6111^11))*(1+(q$6111^2)) (1+(q$6111^4))]

Print @@ 21

AbsoluteTiming[FindN[HaagerupBigraph]]

AbsoluteTiming[BoundR[Families11Graphs[[3]]]]

Factor[FindA[HaagerupAsaedaBigraph,q] ]

Factor[(q^(14)FindA[HaagerupAsaedaBigraph,q] - q^(-14) (FindA[HaagerupAsaedaBigraph,q] /. q->q^(-1)))/(q-q^(-1))]

Factor[FindA[HaagerupAsaedaBigraph,q]]

AbsoluteTiming[BoundR[HaagerupAsaedaBigraph]]

BoundR[HexagonWithTail]

BoundR[Hexagon]

BoundR[HaagerupBigraph]

GraphRank[HexagonWithTail]

GraphRank[HaagerupBigraph]

Expand[(-1)^(GraphRank[HaagerupBigraph]+13)CharacteristicPolynomial[GraphAdjacencyMatrix[Translate[HaagerupBigraph,13]],x]]

GraphRank[HexagonWithTail]

Factor[FindFj[HexagonWithTail,q,0]]