Pensieve Header: Computing the Alexander polynomial following the Bigelow formalism. See also <a href=http://katlas.math.toronto.edu/drorbn/bbs/show?shot=Bigelow-110321-092650.jpg>http://katlas.math.toronto.edu/drorbn/bbs/show?shot=Bigelow-110321-092650.jpg</a>.

<< KnotTheory`

EPD[pd_PD] := Module[
{
n=Length[First[Skeleton[pd]]]
},
(EPD@@ pd /. i_Integer /; i>n :> i+1)/. {
X[i_,j_,1,k_] :> X[i,j,n+1,k],
X[i_, n,j_,1] :> X[i,n,j,n+1],
X[i_,1,j_,n] :> X[i,n+1,j,n]
} /. {
X[i_,j_,k_,l_] /; PositiveQ[X[i,j,k,l]] :> Xp[i,j,k,l],
X[i_,j_,k_,l_] /; NegativeQ[X[i,j,k,l]] :> Xm[i,j,k,l]
}
];
EPD[K_Knot] := EPD[PD[K]];

EPD[Knot[4,1]]

K=Knot[4,1];
n=Crossings[K];
epd =EPD[Knot[4,1]]

t1=Expand[Times @@ epd /. {
Xp[i_,j_,k_,l_] :> (
q OP[l,k]OP[i,j]
+q(OP[i,k]DE[j]DE[l]-OP[i,j]DE[l]DE[k]-DE[i]DE[j]DE[k]DE[l])
+1/q(OP[l,j]DE[i]DE[k]-OP[l,k]DE[j]DE[i]-DE[i]DE[j]DE[k]DE[l])
),
Xm[i_,j_,k_,l_] :> (
1/q OP[i,l]OP[j,k]
+q(OP[j,l]DE[i]DE[k]-OP[j,k]DE[i]DE[l]-DE[i]DE[j]DE[k]DE[l])
+1/q(OP[i,k]DE[j]DE[l]-OP[i,l]DE[j]DE[k]-DE[i]DE[j]DE[k]DE[l])
)
}]

(t1 //. OP[i_,j_]OP[j_,k_] :> OP[i,k]) //. P[i_,j_]DE[j_] :> DE[i] /. {
DE[_]^2 -> 1, P[_,_]^2->0, P[i_,i_] -> 0
}

Alexander[K][t]

BigAlex[EPD[],_,r_]:=r;
BigAlex[epd_EPD, done_, r_] := Module[{pos},
pos=First[Ordering[Length[Complement[List@@#,done]]&/@epd]];
BigAlex[
Delete[epd, pos],
Union[done,List@@epd[[pos]]],
Expand[r*epd[[pos]]/. {
Xp[i_,j_,k_,l_] :> (
q OP[l,k]OP[i,j]
+q(OP[i,k]DE[j]DE[l]-OP[i,j]DE[l]DE[k]-DE[i]DE[j]DE[k]DE[l])
+1/q(OP[l,j]DE[i]DE[k]-OP[l,k]DE[j]DE[i]-DE[i]DE[j]DE[k]DE[l])
),
Xm[i_,j_,k_,l_] :> (
1/q OP[i,l]OP[j,k]
+q(OP[j,l]DE[i]DE[k]-OP[j,k]DE[i]DE[l]-DE[i]DE[j]DE[k]DE[l])
+1/q(OP[i,k]DE[j]DE[l]-OP[i,l]DE[j]DE[k]-DE[i]DE[j]DE[k]DE[l])
)
}] //. 
OP[i_,j_]OP[j_,k_] :> OP[i,k] //. 
{
OP[i_,j_]DE[j_] :> DE[i],
DE[i_]OP[i_,j_] :> DE[j]
} /. 
{
DE[_]^2 -> 1, OP[i_,i_] -> 0
}
]
];
BigAlex[epd_EPD] := BigAlex[epd, {}, 1]

epd

done={}

Length[Complement[List@@#,done]]&/@epd

pos=First[Ordering[Length[Complement[List@@#,done]]&/@epd]]

BigAlex[epd]

EPD[Knot[4,1]]

BigAlex[EPD[Knot[10,42]]]

Expand[OP[1,21]Alexander[Knot[10,42]][q^2]/q^0]

BigAlex[EPD[Xp[2,4,3,1],Xm[3,4,6,5]]]

t1=BigAlex[EPD[Xm[3,1,2,4],Xp[6,5,3,4]]]

t2=Expand[OP[1,5]OP[6,2]-t1 /. OP[i_,j_] :> DP[i,j]+DE[i]DE[j]]

t2 //. DP[is__]DP[js__] :> DP[is,js] //. dp_DP :> Signature[dp]Sort[dp]

r31=EPD[Xp[7,9,6,1],Xp[3,8,7,2],Xp[8,4,5,9]];
r32=EPD[Xp[3,4,7,9],Xp[7,5,6,8],Xp[2,9,8,1]];
{BigAlex[r31], BigAlex[r32]}

BigAlex[r31]-BigAlex[r32]

res4 = BigAlex/@ {
EPD[
Xm[19,1,20,2],Xp[11,3,12,2], Xp[3,30,4,29], Xm[4,21,5,22],
Xp[6,23,7,22], Xm[7,28,8,29], Xm[12,8,13,9], Xp[18,10,19,9],
Xm[27,13,28,14], Xp[23,15,24,14], Xm[24,16,25,17], Xp[26,18,27,17]
],
EPD[
Xp[1,28,2,27], Xm[2,23,3,24], Xm[17,3,18,4], Xp[13,5,14,4],
Xm[14,6,15,7], Xp[16,8,17,7], Xp[8,25,9,24], Xm[9,26,10,27],
Xm[29,11,30,12], Xp[21,13,22,12], Xm[22,18,23,19], Xp[28,20,29,19]
]
}

{1,-1}.res4

Expand[
{1,-1}.res4 /. OP[i_,j_] :> DP[i,j]+DE[i]DE[j]
] //. DP[is__]DP[js__] :> DP[is,js] //. dp_DP :> Signature[dp]Sort[dp]

Expand[BigAlex[EPD[Xp[1,2,3,4]]] /. OP[i_,j_] :> DP[i,j]+DE[i]DE[j]
] //. DP[is__]DP[js__] :> DP[is,js] //. dp_DP :> Signature[dp]Sort[dp]

epd=EPD[PD[Link["L6a4"]]]

BigAlex[epd] // Simplify

MultivariableAlexander[Link["L6a4"]][t] /. t[i_] -> q^2

pd=PD[Link["L9n17"]]

{
n=Length[First[Skeleton[pd]]],
m=Crossings[pd]
}

EPD[PD[Link["L9n19"]]]

BigAlex[EPD[PD[Link["L9n19"]]]] // Factor

MultivariableAlexander[Link["L9n19"]][t] /. t[i_] -> q^2 // Factor