KnotTheoryPathScott = "c:\\scott\\projects\\KnotTheory\\trunk\\";
KnotTheoryPathEmily="/Users/emilypeters/Documents/Math/Knot Theory/trunk";
AppendTo[$Path, KnotTheoryPathScott];
AppendTo[$Path, KnotTheoryPathEmily];
<< KnotTheory`

d=(Sqrt[3])

ω=-(1/2)+I((Sqrt[3])/2)

Clear[q]

q/:(q^(n_))/;EvenQ[n]:=(((I ω))^(n/2))

Simplify[(q^(-4))(d^2)+4 (q^(-2))d+6(d^2)+4(q^2)(d^3)+(q^4)(d^4)]

twoRs[a1_,b1_,c1_,d1_,a2_,b2_,c2_,d2_]:=
-P[a1,a2]P[b1,b2]P[c1,c2]P[d1,d2]+
(Sqrt[3])(P[a1,b1]P[a2,b2]P[c1,c2]P[d1,d2]+P[a1,a2]P[b1,b2]P[c1,d1]P[c2,d2])+
2(Sqrt[3])P[a1,a2]P[b1,c1]P[b2,c2]P[d1,d2]+
(-2)((P[a1,b1]P[c1,a2]P[b2,c2]+P[a1,c2]P[b1,c1]P[a2,b2])P[d1,d2]+P[a1,a2](P[b1,c1]P[d1,b2]P[c2,d2]+P[b1,d2]P[c1,d1]P[b2,c2]))+
(2/(Sqrt[3]))(P[a1,b1]P[c1,a2]P[d1,b2]P[c2,d2]+P[a1,c2]P[b1,d2]P[c1,d1]P[a2,b2])+
(-2)P[a1,d1]P[b1,c1]P[a2,d2]P[b2,c2]+
(4/(Sqrt[3]))(P[a1,d1]P[b1,c1]P[a2,b2]P[c2,d2]+P[a1,b1]P[c1,d1]P[a2,d2]P[b2,c2])+
(-3)P[a1,b1]P[c1,d1]P[a2,b2]P[c2,d2]

twoJWs[a1_,b1_,c1_,d1_,a2_,b2_,c2_,d2_]:=
P[a1,a2]P[b1,b2]P[c1,c2]P[d1,d2]-
(1/(Sqrt[3])) P[a1,b1]P[a2,b2]P[c1,c2]P[d1,d2]-
(1/(Sqrt[3])) P[a1,a2]P[b1,b2]P[c1,d1]P[c2,d2]+
(1/3) P[a1,b1]P[a2,b2]P[c1,d1]P[c2,d2]

Expand[twoJWs[a1,b1,c1,d1,a2,b2,c2,d2]P[a2,a1]P[b2,b1]P[c2,c1]P[d2,d1]]

SetAttributes[P,Orderless]

Clear[P]

P/:P[a_,b_]P[b_,c_]:=P[a,c]
P/:((P[a_,b_])^2):=d
P[a_,a_]:=d

Together[Expand[twoRs[a1,b1,c1,d1,a2,b2,c2,d2]P[a1,a2]]]

twoJWs[a1,a1,c1,d1,a2,b2,c2,d2]

twoJWs[a1,b1,b1,d1,a2,b2,c2,d2]

Together[Expand[twoRs[a1,b1,c1,d1,a2,b2,c2,d2]P[a1,b1]]]

Together[Expand[twoRs[a1,b1,c1,d1,a2,b2,c2,d2]P[b1,c1]P[a1,d1]]]

kauffmanRules={Xp[a_,b_,c_,d_]:>q P[a,d]P[b,c]+(q^(-1))P[a,b]P[c,d],Xn[a_,b_,c_,d_]:>(q^(-1)) P[a,d]P[b,c]+q P[a,b]P[c,d]};

double[X:(Xp|Xn)][a1_,b1_,c1_,d1_,a2_,b2_,c2_,d2_]:=Module[{f},Collect[Expand[(X[b1,c1,f[2],f[1]]X[f[2],d1,d2,f[3]]X[f[4],f[3],c2,b2]X[a1,f[1],f[4],a2])/.kauffmanRules],_P,Together]]

double[BR[3,{k:(-1|1)}]][f_,m_]:=double[If[k==1,Xp,Xn]][f[m,1],f[m,2],f[m,3],f[m,4],
f[m+1,1],f[m+1,2],f[m+1,3],f[m+1,4]]P[f[m,5],f[m+1,5]]P[f[m,6],f[m+1,6]]
double[BR[3,{k:(-2|2)}]][f_,m_]:=double[If[k==2,Xp,Xn]][f[m,3],f[m,4],f[m,5],f[m,6],
f[m+1,3],f[m+1,4],f[m+1,5],f[m+1,6]]P[f[m,1],f[m+1,1]]P[f[m,2],f[m+1,2]]

double[BR[3,{1}]][f,0]

double[BR[3,{-2}]][f,1]

double[BR[n_,{k_,l__}]][f_,m_]:=Collect[Expand[double[BR[n,{k}]][f,m] double[BR[n,{l}]][f,m+1]],_P,Simplify]

elementaryTransposition[n_,k_]:=Range[k-1]~Join~{k+1,k}~Join~Range[k+2,n]

UnderlyingPermutation[BR[n_,{k_}]]:=elementaryTransposition[n,Abs[k]]
UnderlyingPermutation[BR[n_,{k_,l__}]]:=UnderlyingPermutation[BR[n,{l}]][[elementaryTransposition[n,Abs[k]]]]

UnderlyingPermutation[BR[3,{1,2}]]

UnderlyingPermutation[BR[3,{2,1}]]

Clear[CJ,RPart,d4]

Writhe[BR[_,k_List]]:=Plus@@(Sign/@k)

framingCorrection=-(1/2)-((I (Sqrt[3]))/2);

CJ[K_]/;(Length[Skeleton[PD[K]]]==2∧BR[K][[1]]==3):=CJ[K]=FullSimplify[Module[{br=BR[K],l,Rs,f},
l=Length[br[[2]]];
(framingCorrection^(Writhe[br]))Collect[Expand[
If[UnderlyingPermutation[br][[1]]==1,
twoJWs[f[0,1],f[0,2],f[0,3],f[0,4],f[1,1],f[1,2],f[1,3],f[1,4]]P[f[0,5],f[1,5]]P[f[0,6],f[1,6]],
P[f[0,1],f[1,1]]P[f[0,2],f[1,2]] twoJWs[f[0,3],f[0,4],f[0,5],f[0,6],f[1,3],f[1,4],f[1,5],f[1,6]]
]
double[br][f,1]
P[f[0,1],f[l+1,1]]P[f[0,2],f[l+1,2]]P[f[0,3],f[l+1,3]]P[f[0,4],f[l+1,4]]P[f[0,5],f[l+1,5]]P[f[0,6],f[l+1,6]]
],_P,Simplify]
]]

RPart[K_]/;(Length[Skeleton[PD[K]]]==2∧BR[K][[1]]==3):=RPart[K]=FullSimplify[Module[{br=BR[K],l,Rs,f},
l=Length[br[[2]]];
(framingCorrection^(Writhe[br]))Collect[Expand[
If[UnderlyingPermutation[br][[1]]==1,
twoRs[f[0,1],f[0,2],f[0,3],f[0,4],f[1,1],f[1,2],f[1,3],f[1,4]]P[f[0,5],f[1,5]]P[f[0,6],f[1,6]],
P[f[0,1],f[1,1]]P[f[0,2],f[1,2]] twoRs[f[0,3],f[0,4],f[0,5],f[0,6],f[1,3],f[1,4],f[1,5],f[1,6]]
]
double[br][f,1]
P[f[0,1],f[l+1,1]]P[f[0,2],f[l+1,2]]P[f[0,3],f[l+1,3]]P[f[0,4],f[l+1,4]]P[f[0,5],f[l+1,5]]P[f[0,6],f[l+1,6]]
],_P,Simplify]
]]

d4[K_]/;(Length[Skeleton[PD[K]]]==2∧BR[K][[1]]==3):=FullSimplify[((1/4)(CJ[K]+RPart[K]))]

Kn=Knot["L5a1"];

BR[Kn]

d4[Kn]

RPart[Kn]

CJ[Kn]

N@d4[BR[3,{1,1,2}]]

N@d4[BR[3,{1,1,-2}]]

%%/%

Simplify[Expand[doubleX[f][a1,b1,c1,d1,a2,b2,c2,d2]P[a2,b2]]]

FullSimplify[Expand[twoRs[a1,b1,c1,d1,a2,b2,c2,d2]doubleX[f][a2,b2,c2,d2,a3,b3,c3,d3]doubleX[g][a3,b3,c3,d3,a1,b1,c1,d1]]]

FullSimplify[Expand[twoRs[a1,b1,c1,d1,a2,b2,c2,d2]doubleX[f][a2,b2,c2,d2,a3,b3,c3,d3]doubleX[g][a3,b3,c3,d3,a4,b4,c1,d1]]]

Simplify[Expand[twoRs[a1,b1,c1,d1,a2,b2,c2,d2]doubleX[f][a2,b2,c2,d2,a3,b3,c3,d3]]]

Simplify[Expand[% doubleX[f][a3,b3,c3,d3,a4,b4,c4,d4]]]

Simplify[Expand[% doubleX[f][a4,b4,c4,d4,a5,b5,c5,d5]]]

Simplify[Expand[% doubleX[g][a5,b5,c5,d5,a1,b1,c1,d1]]]

FullSimplify[%]

d4TorusLink[n_,2]:=Module[{Rs,f,g,k=0},
Rs=twoRs[f[0,1],f[0,2],f[0,3],f[0,4],f[1,1],f[1,2],f[1,3],f[1,4]];
FullSimplify[Expand[Nest[(++k;Simplify[Expand[# double[Xp][f[k,1],f[k,2],f[k,3],f[k,4],f[k+1,1],f[k+1,2],f[k+1,3],f[k+1,4]]]])&,Rs,n]
P[f[0,1],f[k+1,1]]P[f[0,2],f[k+1,2]]P[f[0,3],f[k+1,3]]P[f[0,4],f[k+1,4]]
]
]
]

d4TorusLink[2,2]

d4TorusLink[4,2]

d4TorusLink[6,2]

d4TorusLink[8,2]

d4TorusLink[10,2]