(* ::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:: *)
Once[<<KnotTheory`]


(* ::Input::Initialization:: *)
SubPlus[n][pd_PD]:=Count[pd,X[i_,j_,k_,l_]/;j-l==1\[Or]l-j>1];
SubMinus[n][pd_PD]:=Count[pd,X[i_,j_,k_,l_]/;l-j==1\[Or]j-l>1];


(* ::Input::Initialization:: *)
SetAttributes[p,Orderless]


(* ::Input::Initialization:: *)
S[pd_PD,s_String]:=S[pd,Characters[s]/.{"0"->0,"1"->1, "*"->\[FivePointedStar]}]


(* ::Input::Initialization:: *)
m_\[Diamond]n_:=Min[m,n];
S[pd_PD,a_List]:=Times@@({List@@pd,a}\[Transpose]/.{
{X[i_,j_,k_,l_],0}:>Subscript[p[i,j], i\[Diamond]j] Subscript[p[k,l], k\[Diamond]l],
{X[i_,j_,k_,l_],1}:>Subscript[p[i,l], i\[Diamond]l] Subscript[p[j,k], j\[Diamond]k],
{x_X,\[FivePointedStar]}:>x}
)//.{
Subscript[p[i_,j_], m_] Subscript[p[j_,k_], n_]:>Subscript[p[i,k], m\[Diamond]n]
}//.{
X[i_,j_,k_,l_] Subscript[p[i_,j_], m_] Subscript[p[k_,l_], n_]:>(Subscript[c, m] Subscript[c, n]->Subscript[c, m\[Diamond]n]),X[i_,j_,k_,l_] Subscript[p[i_,l_], m_] Subscript[p[j_,k_], n_]:>(Subscript[c, m\[Diamond]n]->Subscript[c, m] Subscript[c, n])
}//.\!\(
\*SubsuperscriptBox[\(p[__]\), \(m_\), \(_.\)] :> 
\*SubscriptBox[\(c\), \(m\)]\)


(* ::Input::Initialization:: *)
V[pd_PD,a_]:=List@@Expand[S[pd,a]/.Subscript[c, x_]:>(Subscript[vp, x]+Subscript[vm, x])]


(* ::Input::Initialization:: *)
d[pd_PD,a_]:=S[pd,a]/.{
(Subscript[c, x_] Subscript[c, y_]->Subscript[c, z_])*_.:>{Subscript[vp, x] Subscript[vp, y]->Subscript[vp, z],Subscript[vp, x] Subscript[vm, y]->Subscript[vm, z],Subscript[vm, x] Subscript[vp, y]->Subscript[vm, z],Subscript[vm, x] Subscript[vm, y]->0},(Subscript[c, z_]->Subscript[c, x_] Subscript[c, y_])*_.:>{Subscript[vp, z]->Subscript[vp, x] Subscript[vm, y]+Subscript[vm, x] Subscript[vp, y],Subscript[vm, z]->Subscript[vm, x] Subscript[vm, y]}
}


(* ::Input::Initialization:: *)
udeg[P_]:=Exponent[P/.{Subscript[v, a_]:>q^Total[a],Subscript[vp, _]->q,Subscript[vm, _]->q^-1},q]


(* ::Input::Initialization:: *)
KC[pd_PD,r_]:=If[r<-SubMinus[n][pd]||r>SubPlus[n][pd],{},
Join@@(((Subscript[v, #]) V[pd,#])&/@Permutations[Table[0,SubPlus[n][pd]-r]~Join~Table[1,r+SubMinus[n][pd]]])
];
KC[pd_PD,r_,deg_]:=Cases[KC[pd,r],u_ /;udeg[u]-2SubMinus[n][pd]+SubPlus[n][pd]==deg]


(* ::Input::Initialization:: *)
dd[pd_PD][expr_]:=Expand[expr]/.s_*Subscript[v, a_]:>Expand[\[Sigma]=1;
Sum[
If[a[[i]]==0,\[Sigma]*Subscript[v, ReplacePart[a,1,i]]*s/.d[pd,List@@ReplacePart[a,\[FivePointedStar],i]],\[Sigma]*=-1;0],{i,Length[a]}
]
]


(* ::Input::Initialization:: *)
Rank[pd_PD,r_,deg_]:=(
B0=KC[pd,r,deg];
B1=KC[pd,r+1,deg];
If[B0=={}\[Or]B1=={}, 0,
dB0=dd[pd][B0];
MatrixRank[Table[Coefficient[db0,b1],{db0,dB0},{b1,B1}]]
]
);


(* ::Input::Initialization:: *)
Betti[pd_PD,r_,deg_]:=Length[KC[pd,r,deg]]-Rank[pd,r,deg]-Rank[pd,r-1,deg]


(* ::Input::Initialization:: *)
Kh1[pd_PD]:=Sum[
t^r q^deg Betti[pd,r,deg],
{r,-SubMinus[n][pd],SubPlus[n][pd]},
{deg,Union[udeg/@KC[pd,r]]-2SubMinus[n][pd]+SubPlus[n][pd]}
]


(* ::Input::Initialization:: *)
m_\[Diamond]n_:=Min[m,n];
Kh2[K_]:=Module[{pd,np,nm,p,S,a,\[FivePointedStar],c,V,vp,vm,d,udeg,KC,v,dd,\[Sigma],Rank,B0,B1,dB0,db0,b1,Betti},
pd=PD[K];
np=Count[pd,X[i_,j_,k_,l_]/;j-l==1\[Or]l-j>1];
nm=Count[pd,X[i_,j_,k_,l_]/;l-j==1\[Or]j-l>1];
SetAttributes[p,Orderless];
S[a_List]:=S[a]=Times@@({List@@pd,a}\[Transpose]/.{
{X[i_,j_,k_,l_],0}:>Subscript[p[i,j], i\[Diamond]j] Subscript[p[k,l], k\[Diamond]l],
{X[i_,j_,k_,l_],1}:>Subscript[p[i,l], i\[Diamond]l] Subscript[p[j,k], j\[Diamond]k],
{x_X,\[FivePointedStar]}:>x}
)//.{
Subscript[p[i_,j_], m_] Subscript[p[j_,k_], n_]:>Subscript[p[i,k], m\[Diamond]n]
}//.{
X[i_,j_,k_,l_] Subscript[p[i_,j_], m_] Subscript[p[k_,l_], n_]:>(Subscript[c, m] Subscript[c, n]->Subscript[c, m\[Diamond]n]),
X[i_,j_,k_,l_] Subscript[p[i_,l_], m_] Subscript[p[j_,k_], n_]:>(Subscript[c, m\[Diamond]n]->Subscript[c, m] Subscript[c, n])
}//.\!\(
\*SubsuperscriptBox[\(p[__]\), \(m_\), \(_.\)] :> 
\*SubscriptBox[\(c\), \(m\)]\);
V[a_]:=V[a]=List@@Expand[S[a]/.Subscript[c, x_]:>(Subscript[vp, x]+Subscript[vm, x])];
d[a_]:=d[a]=S[a]/.{
(Subscript[c, x_] Subscript[c, y_]->Subscript[c, z_])*_.:>{Subscript[vp, x] Subscript[vp, y]->Subscript[vp, z],Subscript[vp, x] Subscript[vm, y]->Subscript[vm, z],Subscript[vm, x] Subscript[vp, y]->Subscript[vm, z],Subscript[vm, x] Subscript[vm, y]->0},(Subscript[c, z_]->Subscript[c, x_] Subscript[c, y_])*_.:>{Subscript[vp, z]->Subscript[vp, x] Subscript[vm, y]+Subscript[vm, x] Subscript[vp, y],Subscript[vm, z]->Subscript[vm, x] Subscript[vm, y]}
};
udeg[P_]:=Exponent[P/.{Subscript[v, a_]:>q^Total[a],Subscript[vp, _]->q,Subscript[vm, _]->q^-1},q];
KC[r_]:=KC[r]=If[r<-nm||r>np,{},
Join@@(((Subscript[v, #]) V[#])&/@Permutations[Table[0,np-r]~Join~Table[1,r+nm]])
];
KC[r_,deg_]:=KC[r,deg]=Cases[KC[r],u_ /;udeg[u]-2nm+np==deg];
dd[expr_]:=Expand[expr]/.s_*Subscript[v, a_]:>Expand[\[Sigma]=1;
Sum[
If[a[[i]]==0,\[Sigma]*Subscript[v, ReplacePart[a,1,i]]*s/.d[List@@ReplacePart[a,\[FivePointedStar],i]],\[Sigma]*=-1;0],{i,Length[a]}
]
];
Rank[r_,deg_]:=Rank[r,deg]=(
B0=KC[r,deg];
B1=KC[r+1,deg];
If[B0=={}\[Or]B1=={}, 0,
dB0=dd[B0];
MatrixRank[Table[Coefficient[db0,b1],{db0,dB0},{b1,B1}]]
]
);
Betti[r_,deg_]:=Length[KC[r,deg]]-Rank[r,deg]-Rank[r-1,deg];
Sum[
t^r q^deg Betti[r,deg],
{r,-nm,np},
{deg,Union[udeg/@KC[r]]-2nm+np}
]
]



