Deprecated in favour of cabling.nb

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

d[n_]:=2 Cos[Pi /(2n-2)]
d[4]
d[6]
d[8]

SetAttributes[P,Orderless]
P/:P[a_,b_]P[b_,c_]:=P[a,c]
P/:((P[a_,b_])^2):=-qI[2]
P[a_,a_]:=-qI[2]
qI[1]=1;
JW/:JW[1][a_,b_]:=P[a,b]
JW/:JW[n_][pp__]:=Module[{p={pp},b,i},
Collect[Sum[b=Drop[p,{2n-i,2n-i+1}];(qI[i]/qI[n])Expand[ (JW[n-1]@@b) P[p[[2n-i]],p[[2n-i+1]]]],{i,1,n}],_P,Together]
]

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_,e1_,f1_,g1_,h1_]:=Module[{f},Collect[Expand[(X[b1,c1,f[2],f[1]]X[f[2],d1,e1,f[3]]X[f[4],f[3],f1,g1]X[a1,f[1],f[4],h1])/.kauffmanRules],_P,Together]]

In what follows, input strand names around an n-box will always be read counter-clockwise, starting from 9 o'clock

cable[n_,X:(Xp|Xn)][a__]:=
Module[{northeast,northwest,i,j},
If[
Length[{a}]≠ 4n, 
"error:  wrong number of string names",
northeast[i_,0]:={a}[[i]];
northwest[n,i_] :={a}[[n+i]];
northeast[i_,n]:={a}[[2n+(n-i+1)]];
northwest[0,i_]:={a}[[3n+(n-i+1)]];
Collect[
Expand[
Product[X[northeast[i,j-1],northwest[i,j],northeast[i,j],northwest[i-1,j]],{i,1,n},{j,1,n}]/.kauffmanRules]
,_P,Together
]
]
]
cable[n_,P][a__]:=
If[Length[{a}]≠ 2n, 
"error:  wrong number of string names" ,
Product[P[{a}[[i]],{a}[[2n-i+1]]],{i,1,n}]
]
(*Gah, I don't know why this doesn't work but it doesn't*)
cable[n_,BR[s_,k_]][f_,m_]:=
cable[n,If[Sign[k]==1,Xp,Xn]]@@Flatten[Table[f[m,n (k-1)+i],{i,2n}],Table[f[m+1, n (k+1)-i+1],{i,2n}]]*
 Product[cable[n,P]@@Flatten[Table[f[m,n (j-1) + i],{i,n}],Table[f[m+1,n j -i + 1],{i,2n}]],{j,k-1}]*
 Product[cable[n,P]@@Flatten[Table[f[m,n (j-1) + i],{i,n}],Table[f[m+1,n j -i + 1],{i,2n}]],{j,k+2,s}]

Expand[cable[2,Xp][a,b,c,d,e,f,g,h]-double[Xp][a,b,c,d,e,f,g,h]]/.qI[2]->(q^2+q^{-2})

Simplify[Expand[cable[1,Xp][a,b,c,d] cable[1,Xn][d,c,e,f]]/.qI[2]->(q^2+q^{-2})]

Collect[Expand[cable[2,Xp][a,b,c,d,e,f,g,h]cable[2,Xn][h,g,f,e,k,l,m,n]]/.qI[2]->(q^2+q^{-2}),_P,Together]

Collect[Expand[cable[3,Xp][a,b,c,d,e,f,g,h,i,j,k,l]cable[3,Xn][l,k,j,i,h,g,m,n,o,p,q,r]]/.qI[2]->(q^2+q^{-2}),_P,Together]

Clear[d]

cable[1,BR[3,1]][f,0]