(* ::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.                                                         *)
(************************************************************************)



(* ::Input::Initialization:: *)
(*SetDirectory["~/AcademicPensieve/People/Overbay"];*)
SetDirectory["C:\\drorbn\\AcademicPensieve\\People\\Overbay"]


(* ::Input::Initialization:: *)
OverbayP2Data=Get["OverbayP2Data.m"];
OP2[K_Knot]:=K/.OverbayP2Data /. T->t


(* ::Input::Initialization:: *)
OP12[Knot[n_,k_]] := OP12[{n,k}];
OP12[knot_List] := OP12[knot]=Module[
{initialcrossing,initialmatrix,braidword,Quad, A, F, HigherOrder,kerbeforesub,keraftersub,exp2,poly,poly2,tr,n,p1,p2,
f,HO,INV,Matrix,Imatrix,alex,amp,d,z,trace,Sz,Sder,ISz,ISder,Higher,h,Der,w,x,g,a,test3,test4,list,firstcrossing,firstmatrix,rep2,rep3,rep4,rep5,rep6,qh,p,Inv,NO3,subd,subz,qhend3,
test1,test2,q,HigherOrder3,kerbeforesub3,sub,sub3,sub4,sub5,series},
f[{i_,n_}]:=If[n>0,ConstantArray[{i,i+1},{n}],ConstantArray[{i+1,i},{-n}]];
list=Flatten[f/@Echo[KnotData[knot,"BraidWord"]]];
initialcrossing=firstcrossing[Take[list,{1,2}]];
initialmatrix=firstmatrix[Take[list,{1,2}]];
braidword=Sequence[Partition[Take[list,2-Length[list]],2]];
n=KnotData[knot,"BraidIndex"];
firstcrossing[{x_,y_}]:=If[x<y,Subscript[HO, x,y],Subscript[INV, y,x]] ;
firstmatrix[{x_,y_}]:= If[x<y,Subscript[Matrix, x,y],Subscript[Imatrix, y,x]];
alex=KnotData[knot,"AlexanderPolynomial"][t^2];
amp=KnotData[knot,"Amphichiral"];
rep2[i_,j_]:=Which[i==j==0,1,True,((i!j!Coefficient[exp2,Subscript[d, 2]^i Subscript[z, 2]^j ])/.{Subscript[z, 2]->0,Subscript[d, 2]->0})];
rep3[i_,j_,k_,l_]:=Which[i==j==k==l==0,1,True,((i!j!k!l!Coefficient[exp2,Subscript[d, 2]^i Subscript[z, 2]^j Subscript[d, 3 ]^k Subscript[z, 3]^l])/.{Subscript[z, 2]->0,Subscript[d, 2]->0,Subscript[z, 3]->0,Subscript[d, 3]->0})];
rep4[i_,j_,k_,l_,m_,n_]:=Which[i==j==k==l==m==n==0,1,True,((i!j!k!l!m!n!Coefficient[exp2,Subscript[d, 2]^i Subscript[z, 2]^j Subscript[d, 3 ]^k Subscript[z, 3]^l Subscript[d, 4 ]^m Subscript[z, 4]^n])/.{Subscript[z, 2]->0,Subscript[d, 2]->0,Subscript[z, 3]->0,Subscript[d, 3]->0,Subscript[z, 4]->0,Subscript[d, 4]->0})];
rep5[i_,j_,k_,l_,m_,n_,o_,p_]:=Which[i==j==k==l==m==n==o==p==0,1,True,((i!j!k!l!m!n!o!p!Coefficient[exp2,Subscript[d, 2]^i Subscript[z, 2]^j Subscript[d, 3 ]^k Subscript[z, 3]^l Subscript[d, 4 ]^m Subscript[z, 4]^n Subscript[d, 5 ]^o Subscript[z, 5]^p])/.{Subscript[z, 2]->0,Subscript[d, 2]->0,Subscript[z, 3]->0,Subscript[d, 3]->0,Subscript[z, 4]->0,Subscript[d, 4]->0,Subscript[z, 5]->0,Subscript[d, 5]->0})];
rep6[i_,j_,k_,l_,m_,n_,o_,p_,q_,r_]:=Which[i==j==k==l==m==n==o==p==q==r==0,1,True,((i!j!k!l!m!n!o!p!q!r!Coefficient[exp2,Subscript[d, 2]^i Subscript[z, 2]^j Subscript[d, 3 ]^k Subscript[z, 3]^l Subscript[d, 4 ]^m Subscript[z, 4]^n Subscript[d, 5 ]^o Subscript[z, 5]^p Subscript[d, 6]^q Subscript[z, 6]^r])/.{Subscript[z, 2]->0,Subscript[d, 2]->0,Subscript[z, 3]->0,Subscript[d, 3]->0,Subscript[z, 4]->0,Subscript[d, 4]->0,Subscript[z, 5]->0,Subscript[d, 5]->0,Subscript[z, 6]->0,Subscript[d, 6]->0})];
Subscript[trace, 2][s_]:=Expand[Plus@@(s/.Rule[{a_,b_},c_]:>rep2[a,b]c)];
Subscript[trace, 3][s_]:=Expand[Plus@@(s/.Rule[{a_,b_,e_,f_},c_]:>rep3[a,b,e,f]c)];
Subscript[trace, 4][s_]:=Expand[Plus@@(s/.Rule[{a_,b_,e_,f_,g_,h_},c_]:>rep4[a,b,e,f,g,h]c)];
Subscript[trace, 5][s_]:=Expand[Plus@@(s/.Rule[{a_,b_,e_,f_,g_,h_,i_,j_},c_]:>rep5[a,b,e,f,g,h,i,j]c)];
Subscript[trace, 6][s_]:=Expand[Plus@@(s/.Rule[{a_,b_,e_,f_,g_,h_,i_,j_,k_,l_},c_]:>rep6[a,b,e,f,g,h,i,j,k,l]c)];
qh[n_]:=(1+h Coefficient[Product[1+2h Subscript[z, i] Subscript[d, i],{i,2,n}],h,1]+h^2 Coefficient[Product[1+2h Subscript[z, i] Subscript[d, i]+2 h^2(Subscript[z, i] Subscript[d, i]+Subscript[z, i]^2Subscript[d, i]^2),{i,2,n}],h,2]+h^3 Coefficient[Product[1+2h Subscript[z, i] Subscript[d, i]+2 h^2(Subscript[z, i] Subscript[d, i]+Subscript[z, i]^2Subscript[d, i]^2)+(4/3)h^3(Subscript[z, i] Subscript[d, i]+3Subscript[z, i]^2 Subscript[d, i]^2+Subscript[z, i]^3 Subscript[d, i]^3),{i,2,n}],h,3]+h^4 Coefficient[Product[1+2h Subscript[z, i] Subscript[d, i]+2 h^2(Subscript[z, i] Subscript[d, i]+Subscript[z, i]^2Subscript[d, i]^2)+(4/3)h^3(Subscript[z, i] Subscript[d, i]+3Subscript[z, i]^2 Subscript[d, i]^2+Subscript[z, i]^3 Subscript[d, i]^3)+(2/3)h^4(Subscript[z, i] Subscript[d, i]+7Subscript[z, i]^2 Subscript[d, i]^2+6Subscript[z, i]^3 Subscript[d, i]^3+Subscript[z, i]^4 Subscript[d, i]^4),{i,2,n}],h,4]);
Subscript[p, l_,k_][i_,j_]:=Which[i==k&&j==l,t,i==l&&j==k,t,i==j==l,0,i==j==k,1-t^2,i==j,1,True,0];
Subscript[Matrix, l_,k_]:=Array[Subscript[p, l,k],{n,n}];
Subscript[Imatrix, l_,k_]:=Inverse[Subscript[Matrix, l,k]];
Subscript[Sz, l_,k_][Subscript[z, j_]]:=Expand[Sum[Subscript[z, i]Subscript[Imatrix, l,k][[i,j]],{i,1,n}]];

Subscript[Sder, l_,k_][Subscript[d, j_]]:=Expand[Sum[Subscript[Matrix, l,k][[i,j]]Subscript[d, i],{i,1,n}]];
Subscript[ISz, l_,k_][Subscript[z, j_]]:=Expand[Sum[Subscript[z, i]Subscript[Matrix, l,k][[i,j]],{i,1,n}]];
Subscript[ISder, l_,k_][Subscript[d, j_]]:=Expand[Sum[Subscript[Imatrix, l,k][[i,j]]Subscript[d, i],{i,1,n}]];
Higher[a_,b_,w_,x_]:=1+h (2 a b w x-(2 a^2 w x)/t+2 a^2 t w x+3 a^2 x^2-(a^2 x^2)/t^2+(a b x^2)/t-3 a b t x^2-2 a^2 t^2 x^2)+h^2 (2 a b w x-(2 a^2 w x)/t+2 a^2 t w x+2 a^2 b w^2 x-(2 a^3 w^2 x)/t+2 a^3 t w^2 x+5 a^2 x^2-(a^2 x^2)/t^2+(a b x^2)/t-5 a b t x^2-4 a^2 t^2 x^2+4 a^3 w x^2+2 a b^2 w x^2-(2 a^2 b w x^2)/t-2 a^2 b t w x^2-4 a^3 t^2 w x^2-4 a^4 w^2 x^2+2 a^2 b^2 w^2 x^2+(2 a^4 w^2 x^2)/t^2-(4 a^3 b w^2 x^2)/t+4 a^3 b t w^2 x^2+2 a^4 t^2 w^2 x^2+10/3 a^2 b x^3-(2 a^2 b x^3)/(3 t^2)+(4 a^3 x^3)/(3 t)+(2 a b^2 x^3)/(3 t)-16/3 a^3 t x^3-14/3 a b^2 t x^3+4/3 a^2 b t^2 x^3+4 a^3 t^3 x^3+14 a^3 b w x^3+(2 a^4 w x^3)/t^3-(4 a^3 b w x^3)/t^2-(8 a^4 w x^3)/t+(2 a^2 b^2 w x^3)/t+10 a^4 t w x^3-6 a^2 b^2 t w x^3-10 a^3 b t^2 w x^3-4 a^4 t^3 w x^3+(13 a^4 x^4)/2-3 a^2 b^2 x^4+(a^4 x^4)/(2 t^4)-(a^3 b x^4)/t^3-(3 a^4 x^4)/t^2+(a^2 b^2 x^4)/(2 t^2)+(6 a^3 b x^4)/t-11 a^3 b t x^4-6 a^4 t^2 x^4+9/2 a^2 b^2 t^2 x^4+6 a^3
 b t^3 x^4+2 a^4 t^4 x^4);
Inv[a_,b_,w_,x_]:=1+h (b^2 w^2+(a b w^2)/t+a b t w^2-b^2 t^2 w^2-2 a b w x)+h^2 (b^2 w^2-(a b w^2)/t+a b t w^2-b^2 t^2 w^2+10/3 a b^2 w^3+(4 a b^2 w^3)/(3 t^2)-(2 a^2 b w^3)/(3 t)+(8 b^3 w^3)/(3 t)+2/3 a^2 b t w^3-8/3 b^3 t w^3-2/3 a b^2 t^2 w^3+a^2 b^2 w^4+(b^4 w^4)/2+(a^2 b^2 w^4)/(2 t^2)+(a b^3 w^4)/t+1/2 a^2 b^2 t^2 w^4-b^4 t^2 w^4-a b^3 t^3 w^4+1/2 b^4 t^4 w^4+2 a b w x+2 a^2 b w^2 x-4 b^3 w^2 x-(4 a b^2 w^2 x)/t-4 a b^2 t w^2 x+4 b^3 t^2 w^2 x-2 a b^3 w^3 x-(2 a^2 b^2 w^3 x)/t-2 a^2 b^2 t w^3 x+2 a b^3 t^2 w^3 x+2 a b^2 w x^2+2 a^2 b^2 w^2 x^2);
Subscript[HO, i_,j_]:=Higher[Subscript[z, i],Subscript[z, j],Subscript[d, i],Subscript[d, j]];
Subscript[INV, i_,j_]:=Inv[Subscript[z, i],Subscript[z, j],Subscript[d, i],Subscript[d, j]];
Subscript[Der, i_][f_]:=f+Sum[(1/k!)D[f,{Subscript[w, i],k},{Subscript[x, i],k}],{k,1,8}];
NO3[l_,{i_,j_}]/;i<j :=(Subscript[Der, j][Subscript[Der, i][Expand[1+h Coefficient[((l/.Flatten[Table[{Subscript[z, k]->Subscript[Sz, i,j][Subscript[z, k]],Subscript[d, k]->Subscript[Sder, i,j][Subscript[d, k]]},{k,1,n}]])/.{Subscript[d, i]->Subscript[w, i],Subscript[d, j]->Subscript[w, j]})*Higher[Subscript[x, i],Subscript[x, j],Subscript[d, i],Subscript[d, j]],h,1]+h^2Coefficient[((l/.Flatten[Table[{Subscript[z, k]->Subscript[Sz, i,j][Subscript[z, k]],Subscript[d, k]->Subscript[Sder, i,j][Subscript[d, k]]},{k,1,n}]])/.{Subscript[d, i]->Subscript[w, i],Subscript[d, j]->Subscript[w, j]})*Higher[Subscript[x, i],Subscript[x, j],Subscript[d, i],Subscript[d, j]],h,2]]]])/.{Subscript[w, i]->Subscript[d, i],Subscript[w, j]->Subscript[d, j],Subscript[x, i]->Subscript[z, i],Subscript[x, j]->Subscript[z, j]};
NO3[l_,{i_,j_}]/;i>j:=(Subscript[Der, j][Subscript[Der, i][Expand[1+h Coefficient[((l/.Flatten[Table[{Subscript[z, k]->Subscript[ISz, j,i][Subscript[z, k]],Subscript[d, k]->Subscript[ISder, j,i][Subscript[d, k]]},{k,1,n}]])/.{Subscript[d, i]->Subscript[w, i],Subscript[d, j]->Subscript[w, j]})*Inv[Subscript[x, j],Subscript[x, i],Subscript[d, j],Subscript[d, i]],h,1]+h^2Coefficient[((l/.Flatten[Table[{Subscript[z, k]->Subscript[ISz, j,i][Subscript[z, k]],Subscript[d, k]->Subscript[ISder, j,i][Subscript[d, k]]},{k,1,n}]])/.{Subscript[d, i]->Subscript[w, i],Subscript[d, j]->Subscript[w, j]})*Inv[Subscript[x, j],Subscript[x, i],Subscript[d, j],Subscript[d, i]],h,2]]]])/.{Subscript[w, i]->Subscript[d, i],Subscript[w, j]->Subscript[d, j],Subscript[x, i]->Subscript[z, i],Subscript[x, j]->Subscript[z, j]};
subd=Flatten[Table[Subscript[d, i]->Subscript[w, i],{i,2,n}]];
subz=Flatten[Table[Subscript[z, i]->Subscript[x, i],{i,2,n}]];
g[l_,{x_ ,y_}]:=If[x<y,l.(Subscript[Matrix, x,y]),l.(Subscript[Imatrix, y,x])];
qhend3[f_]:=Expand[(f/.subd)+h (Coefficient[qh[n],h,1]/.subz)+h^2 (Coefficient[qh[n],h,2]/.subz)+h^2 ((Coefficient[f,h,1]/.subd)*(Coefficient[qh[n],h,1]/.subz))];
Quad=Expand[Fold[g,initialmatrix,braidword]];
Subscript[a, i_,j_]:=If[i==j,Quad[[i,j]]-1,Quad[[i,j]]];
A=Table[Subscript[a, i,j],{i,2,n},{j,2,n}];
F=Inverse[-A];
HigherOrder3=Fold[NO3,initialcrossing,braidword];

kerbeforesub3=((l=qhend3[HigherOrder3];Do[l=Subscript[Der, i][l],{i,2,n,1}];l)/.Flatten[Table[{Subscript[x, i]->Subscript[z, i],Subscript[w, i]->Subscript[d, i]},{i,2,n}]]);
sub=Flatten[Table[Subscript[z, k]->Expand[Sum[Quad[[i,k]] Subscript[z, i],{i,1,n}]],{k,1,n}]];
keraftersub=1+h Expand[Coefficient[kerbeforesub3/.sub,h,1]]+h^2 Expand[Coefficient[kerbeforesub3/.sub,h,2]];
sub3=Flatten[Table[{Subscript[z, i]->Subscript[z, i]+Expand[Sum[F[[k,i-1]]Quad[[1,k+1]]Subscript[z, 1],{k,1,n-1}]],Subscript[d, i]->Subscript[d, i]+Expand[Sum[F[[i-1,l]]Quad[[l+1,1]]Subscript[d, 1],{l,1,n-1}]]},{i,2,n}]];
twopoly=1+h Expand[Coefficient[keraftersub/.sub3,h,1]]+h^2 Expand[Coefficient[keraftersub/.sub3,h,2]];
sub4=Sum[(Expand[Sum[F[[i-1,j-1]]Subscript[d, i] Subscript[z , j],{j,2,n},{i,2,n}]])^i/i!,{i,1,10}];
exp2=Expand[1+sub4];
sub5=Flatten[Table[{Subscript[d, i],Subscript[z, i]},{i,2,n}]];
poly2=CoefficientRules[twopoly,sub5];
tr=Subscript[trace, n][poly2];
test1=Together[Coefficient[tr,h,1]];
test2=Together[Coefficient[tr,h,2]];
p=If[amp==True,Cancel[Denominator[test1]/alex],Cancel[Denominator[test1]/alex^2]];
q=If[amp==True,Cancel[Denominator[test2]/alex^3],Cancel[Denominator[test2]/alex^4]];
series=If[amp==True,Normal[Series[((((1+h test1+h^2test2+h^3 test3+h^4 test4)(1/alex))/.{t->t Exp[h]})(alex)/.{h-> h/2-h^2/4})/.{h->-Sqrt[1+h]+1/Sqrt[1+h]},{h,0,2}]],Normal[Series[((((1+h test1+h^2test2+h^3 test3+h^4 test4)(1/alex))/.{t->t Exp[h]})alex)/.{h-> h/2-h^2/4},{h,0,2}]]];
p1=Expand[Numerator[Coefficient[series,h,1]]/p];
p2=Expand[Numerator[Coefficient[series,h,2]]/q];

{p1,p2}
];


(* ::Input::Initialization:: *)
AllKnots={Knot[3,1],Knot[4,1],Knot[5,1],Knot[5,2],Knot[6,1],Knot[6,2],Knot[6,3],Knot[7,1],Knot[7,2],Knot[7,3],Knot[7,4],Knot[7,5],Knot[7,6],Knot[7,7],Knot[8,1],Knot[8,2],Knot[8,3],Knot[8,4],Knot[8,5],Knot[8,6],Knot[8,7],Knot[8,8],Knot[8,9],Knot[8,10],Knot[8,11],Knot[8,12],Knot[8,13],Knot[8,14],Knot[8,15],Knot[8,16],Knot[8,17],Knot[8,18],Knot[8,19],Knot[8,20],Knot[8,21],Knot[9,1],Knot[9,2],Knot[9,3],Knot[9,4],Knot[9,5],Knot[9,6],Knot[9,7],Knot[9,8],Knot[9,9],Knot[9,10],Knot[9,11],Knot[9,12],Knot[9,13],Knot[9,14],Knot[9,15],Knot[9,16],Knot[9,17],Knot[9,18],Knot[9,19],Knot[9,20],Knot[9,21],Knot[9,22],Knot[9,23],Knot[9,24],Knot[9,25],Knot[9,26],Knot[9,27],Knot[9,28],Knot[9,29],Knot[9,30],Knot[9,31],Knot[9,32],Knot[9,33],Knot[9,34],Knot[9,35],Knot[9,36],Knot[9,37],Knot[9,38],Knot[9,39],Knot[9,40],Knot[9,41],Knot[9,42],Knot[9,43],Knot[9,44],Knot[9,45],Knot[9,46],Knot[9,47],Knot[9,48],Knot[9,49],Knot[10,1],Knot[10,2],Knot[10,3],Knot[10,4],Knot[10,5],Knot[10,6],Knot[10,7],Knot[10,8],Knot[10,9],Knot[10,10],Knot[10,11],Knot[10,12],Knot[10,13],Knot[10,14],Knot[10,15],Knot[10,16],Knot[10,17],Knot[10,18],Knot[10,19],Knot[10,20],Knot[10,21],Knot[10,22],Knot[10,23],Knot[10,24],Knot[10,25],Knot[10,26],Knot[10,27],Knot[10,28],Knot[10,29],Knot[10,30],Knot[10,31],Knot[10,32],Knot[10,33],Knot[10,34],Knot[10,35],Knot[10,36],Knot[10,37],Knot[10,38],Knot[10,39],Knot[10,40],Knot[10,41],Knot[10,42],Knot[10,43],Knot[10,44],Knot[10,45],Knot[10,46],Knot[10,47],Knot[10,48],Knot[10,49],Knot[10,50],Knot[10,51],Knot[10,52],Knot[10,53],Knot[10,54],Knot[10,55],Knot[10,56],Knot[10,57],Knot[10,58],Knot[10,59],Knot[10,60],Knot[10,61],Knot[10,62],Knot[10,63],Knot[10,64],Knot[10,65],Knot[10,66],Knot[10,67],Knot[10,68],Knot[10,69],Knot[10,70],Knot[10,71],Knot[10,72],Knot[10,73],Knot[10,74],Knot[10,75],Knot[10,76],Knot[10,77],Knot[10,78],Knot[10,79],Knot[10,80],Knot[10,81],Knot[10,82],Knot[10,83],Knot[10,84],Knot[10,85],Knot[10,86],Knot[10,87],Knot[10,88],Knot[10,89],Knot[10,90],Knot[10,91],Knot[10,92],Knot[10,93],Knot[10,94],Knot[10,95],Knot[10,96],Knot[10,97],Knot[10,98],Knot[10,99],Knot[10,100],Knot[10,101],Knot[10,102],Knot[10,103],Knot[10,104],Knot[10,105],Knot[10,106],Knot[10,107],Knot[10,108],Knot[10,109],Knot[10,110],Knot[10,111],Knot[10,112],Knot[10,113],Knot[10,114],Knot[10,115],Knot[10,116],Knot[10,117],Knot[10,118],Knot[10,119],Knot[10,120],Knot[10,121],Knot[10,122],Knot[10,123],Knot[10,124],Knot[10,125],Knot[10,126],Knot[10,127],Knot[10,128],Knot[10,129],Knot[10,130],Knot[10,131],Knot[10,132],Knot[10,133],Knot[10,134],Knot[10,135],Knot[10,136],Knot[10,137],Knot[10,138],Knot[10,139],Knot[10,140],Knot[10,141],Knot[10,142],Knot[10,143],Knot[10,144],Knot[10,145],Knot[10,146],Knot[10,147],Knot[10,148],Knot[10,149],Knot[10,150],Knot[10,151],Knot[10,152],Knot[10,153],Knot[10,154],Knot[10,155],Knot[10,156],Knot[10,157],Knot[10,158],Knot[10,159],Knot[10,160],Knot[10,161],Knot[10,162],Knot[10,163],Knot[10,164],Knot[10,165]};



