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

EliminatingVinesContent.nb

Calculating vine constants

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

DisplayBigraph/@VineList

Length[VineList]

AList = FindA[#,q]&/@VineList;

sList = Finds/@VineList

KGammaList = FindKGamma/@VineList

RList=BoundR/@VineList

NList=FindN /@VineList

Running the Cyclotomic Test on the vines

GoodGraphsWithPrimes=Table[MultiPrimeVineCyclotomicTest[VineList[[t]],NList[[t]],200,50],{t,1,Length[VineList]}];

GoodGraphs=Flatten[GoodGraphsWithPrimes[[All,1]]];
GoodGraphsByVine=GoodGraphsWithPrimes[[All,1]];
PrimeList=GoodGraphsWithPrimes[[All,2]];

PrimeList={{179,181},{41,43},{41,43},{29,31},{59,61},{59,61},{41,43},{37,41},{41,43},{59},{59},{73,79},{73,79},{37,41},{73,79},{103,107},{43,47},{59,61},{59,61},{5,7},{37,41},{47,53},{5,7},{5,7},{37,41},{47,53},{47,53},{59,61},{59,61},{59,61},{59,61},{37,41},{17,19},{17,19},{43,47},{17,19},{17,19},{43,47}};

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

Eliminating remaining graphs with the d test and algebraic integer test

ReallyGoodGraphs=Select[GoodGraphs,KnownObstructions[#]=={}&];
KilledGoodGraphs=Select[GoodGraphs,KnownObstructions[#]≠{}&];

DisplayBigraph/@ReallyGoodGraphs

dNumberGraphs=Select[KilledGoodGraphs,DTest[#]&]; DisplayBigraph/@dNumberGraphs

Table[DimensionsByDepth[dNumberGraphs[[i]]][[4,1]],{i,1,Length[dNumberGraphs]}]

BadGlobalDimensionGraphs=Select[KilledGoodGraphs,Not[DTest[#]]&];DisplayBigraph/@BadGlobalDimensionGraphs

Table[{DisplayBigraph[BadGlobalDimensionGraphs[[i]]],TeXForm[MinimalPolynomial[GlobalEvenDimension[BadGlobalDimensionGraphs[[i]]],x]]},{i,1,Length[BadGlobalDimensionGraphs]}]

Calculating the bound for repeated roots on the circle (Non-salem only)

NonSalemVines=Select[VineList,Not[ASalemFormQ[FindA[#,q],q]]&];

DisplayBigraph/@NonSalemVines

DisplayGraphsFord[g_GradedBigraph,n_,q_]:=Module[{A,l,B,C,s},
{A,s}=FindAands[g,q];
{l,B,C}=FactorReciprocal[A,q];
2(n-l) Abs[Expand[C]]-Abs[Expand[D[C,q]]]-Abs[Expand[D[C/.(q->q^(-1)),q]]]
];

NonSalemNList=FindN /@NonSalemVines

Table[LogPlot[Evaluate[DisplayGraphsFord[NonSalemVines[[i]],200,q]/.(q->Exp[q I])],{q,0,2Pi},AxesOrigin->{0,0}],{i,1,Length[NonSalemVines]}]

Hence if n≥200, then all repeated roots on the circle of F_n are roots of B for each of the non Salem vines.

Generating the table

ListToString[list_List]:=Module[{string=Fold[#1<>ToString[#2]<>","&,"",list]},
StringTake[string,{1,StringLength[string]-1}]];

GetExceptionsTeX[Graphs_,Vine_]:=Module[{jlist},
If[Graphs=={},"None",
jlist=Table[GraphRank[Graphs[[i]]]-GraphRank[Vine],{i,1,Length[Graphs]}];
"$j="<>ListToString[jlist]<>"$"]];
GetExceptions[Graphs_,Vine_]:=Module[{jlist},
If[Graphs=={},"None",
jlist=Table[GraphRank[Graphs[[i]]]-GraphRank[Vine],{i,1,Length[Graphs]}];
"j="<>ListToString[jlist]]];

(* Displays TeX for the table of results.  It depends on VineList, sList, KGammaList, RList, Nlist, PrimeList, and GoodGraphsByVine *)
DisplayTableTeX:=Module[{tabletex},
tabletex="\\begin{longtable}{|c|c|c|c|c|c|c|c|}
\\hline
\\# & Vine & s &$K(\\Gamma)$ & $\\cR$ &$N(\\Gamma)$ & $p$ & Exceptions\\\\
\\hline\n";
tabletex=tabletex<>Fold[StringJoin,"",Table[StringJoin[
"%",ToString[i],"\n",
"\\vine\\label{",GraphToString[VineList[[i]]],"}\n",
"&$\\bigraph{",GraphToString[VineList[[i]]],"}$\n",
"& ",ToString[sList[[i]]]," & ",ToString[KGammaList[[i]]]," & ",
ToString[RList[[i]]]," & ",ToString[NList[[i]]], " & ", ListToString[PrimeList[[i]]], " & ",
GetExceptionsTeX[GoodGraphsByVine[[i]],VineList[[i]]],"\n",
"\\\\ \n",
"\\hline \n"],{i,1,Length[VineList]}]];
tabletex=tabletex<>"\\end{longtable}\n";
DisplayForm[tabletex]
];

(* Displays in Mathematica a table of results.  It depends on the same lists as DisplayTableTeX. *)
DisplayTable:=Module[{data},
data={{"#","Vine","s","K(Γ)","R","N(Γ)","p","Exceptions"}};
data=data~Join~Table[{i,DisplayBigraph[VineList[[i]]],sList[[i]],KGammaList[[i]],RList[[i]],NList[[i]],ListToString[PrimeList[[i]]],GetExceptions[GoodGraphsByVine[[i]],VineList[[i]]]},{i,1,Length[VineList]}];
Grid[data,Frame->All]]

DisplayTable

DisplayTableTeX