(* ::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["C:\\drorbn\\AcademicPensieve\\People\\Ledvinka"];
<<KnotTheory`;
<<DunfieldsKnots`;


(* ::Input::Initialization:: *)
NormalizePD[K_PD]:= K/.i_Integer :> Mod[i, 2 Crossings[K]];
FlipCrossing[X[i_,j_,k_,l_]]:=If[PositiveQ[ X[i,j,k,l]],X[l,i,j,k], X[j,k,l,i]];
FirstEdge[i_,j_]:= If[Abs[j-i]==1,Min[i,j], Max[i,j]];
OrderKnot[K_PD]:= Association @@ Flatten @ (List @@ K/.X[i_,j_,k_,l_]:> {i-> X[i,j,k,l], FirstEdge[j,l]->X[i,j,k,l]});
TruncatePolynomial[P_, x_, k_]:= P/.x^i_/;i>k->0;


(* ::Input::Initialization:: *)
HomflyptUpTo[K_PD, n_]:= Module[{m, L, OK, UnderCrossingQ, P, Linking},
m = 2 Crossings[K];
L = NormalizePD[K];
OK =OrderKnot[L];
UnderCrossingQ[i_]:= (First @ OK[i]==i);
P[k_,i_,j_]:=P[k,i,j] =  Expand @ Module[{t},
Piecewise[{
{1,j-i<= 4},
{P[k,i+1,j], t = FirstEdge @@ OK[i][[{2,4}]]; Not @ UnderCrossingQ[i] ||Not[ i<t<=j]}},
If[PositiveQ[OK[i]], -a^-2P[k,i+1,j] + a^-1 P[k,i,j,t], -a^2P[k,i+1,j] + a P[k,i,j,t]]
]];
Linking[i_,j_, t_]:=Sum[If[UnderCrossingQ[l]&&(i+1<=FirstEdge @@ OK[l][[{2,4}]]<=t-1), If[PositiveQ[OK[l]],1,-1], 0],{l,t+1,j-1}];
P[0,i_,j_,t_]:=(-a^-2)^ Linking[i,j,t] (a + a ^-1)P[ 0,i+1,t] P[0,t+1,j];
P[k_,i_,j_,t_]:= Module[{FlipCheck, e, Smooth, D, T, D0},
FlipCheck[X[a_,b_,c_,d_]]:= (e = FirstEdge[b,d];(a<i && Not[a<e<i]) ||( a >=j && a>e > i));
Smooth[D_,s_]:= Module[{r, d1, d2, d3, A},
r= FirstEdge @@ OK[s][[{2,4}]];
d1 = i + s - (t+1); 
d2 = d1 + t - (r+1);
d3 = d2 + r - (i+1);
A=AssociationThread[Join[Range[0,i],Range[t+1,s],Range[r+1,t],Range[i+1,r],Range[s+1,m-1]]->Join[Range[0,i],Range[i,d1],Range[d1,d2],Range[d2,d3],Range[d3, m -5]]];
D/.X[a_,b_,c_,d_]:> If[MatchQ[X[a,b,c,d],OK[s]], ##&[], X[A[a],A[b],A[c],A[d]]]];
T[j]:= (a + a^-1)P[k,i+1,t] P[k,t+1,j];
T[s_]:=If[UnderCrossingQ[s] && i+1<= FirstEdge @@ OK[s][[{2,4}]]<=t-1,
D0 = Smooth[D, s]; D = D/. OK[s]:>FlipCrossing[OK[s]];
If[PositiveQ[OK[s]], z^2 a^-1 HomflyptUpTo[D0,k-2]-a^-2 T[s + 1],z^2 a HomflyptUpTo[D0,k-2]- a^2 T[s+ 1]],T[s + 1]];
D = L/.x_X:>If[MatchQ[x,OK[i]],##&[], If[FlipCheck[x], FlipCrossing[x],x]]; 
 T[t+1]
];
  TruncatePolynomial[P[n,0,m],z,n]
];


(* ::Input::Initialization:: *)
HomflyptUpTo[K_,n_]:= HomflyptUpTo[PD @ K, n];



