Pensieve Header: Computing the Alexander polynomial in β-calculus.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2012-01"];
<< betaCalculus.m
<< KnotTheory`
GC[K_] := GC @@ (
PD[K] /. X[i_,j_,k_,l_] :> If[PositiveQ[X[i,j,k,l]],
Ar[l,i,+1], Ar[j,i,-1]
]
)

The Program and a Test Run

{K=Knot[8,17];
Alexander[K][X], GC[K]
}

βForm[Plus@@(GC[K] /. {Ar[i_, j_, +1] :> R[i,j], Ar[i_, j_, -1] :> RInv[i,j]})];

βAlex[K_] := Module[
{gc, β},
gc = GC[K];
β = βCollect[Plus@@(gc /. {Ar[i_, j_, +1] :> R[i,j], Ar[i_, j_, -1] :> RInv[i,j]})];
Do[β = dm[1,k,1][β], {k, 2, 2Length[gc]}];
Expand[β /. h[1] -> 0 /. E^(n_. c[1]) :> X^n /. W[a_] :> a]
]

βAlex[K]

Testing the Full Rolfsen Table

{βAlex[#], Alexander[#][X]}& /@ AllKnots[{3,7}] // MatrixForm

Test[K_] := Factor[βAlex[K]/Alexander[K][X]]

Union[Test /@ AllKnots[{3,11}]]

Avoiding Exponentials

ar[1,2]**(((-1)/(1+c[1])) ar[1,2])

βalex[K_] := Module[
{gc, β},
gc = GC[K];
β = βCollect[W[1]+Plus@@(gc /. {Ar[i_, j_, +1] :> ar[i,j], Ar[i_, j_, -1] :>-(1/(1+c[i])) ar[i,j]})];
Do[β = dm[1,k,1][β], {k, 2, 2Length[gc]}];
Expand[β] /. c[1] -> Y
]

βalex[K]

{Expand[βalex[#] /. {h[1] -> 0, W[a_] :> a} /. {Y->X-1}], Expand[βalex[#] /. {h[1] -> 0, W[a_] :> a}], βAlex[#], Alexander[#][X], Conway[#][Y]}& /@ AllKnots[{3,7}] // MatrixForm

βSimplify=Factor;
gc = GC[K];
β = βCollect[W[1]+Plus@@(gc /. {Ar[i_, j_, +1] :> ar[i,j], Ar[i_, j_, -1] :>-(1/(1+c[i])) ar[i,j]})];
(
Table[{
(β = dm[1,k,1][β]) /. _c -> c-1//βCollect // βForm,
Collect[β /. {_W -> 0,  t[s_] :> c[s]}, _h, Factor]
}, {k, 2, 2Length[gc]}]
) // ColumnForm

-((2-4 c-(c^2)+(c^3)-2 (c^4)+(c^5))/((-2+c) (c^2) (-1+2 c-(c^2)+(c^3))))+-(1/((-2+c) c (-1+2 c-(c^2)+(c^3)))) // Simplify

((-1+5 c-9 (c^2)+7 (c^3)-4 (c^4)+(c^5))/((-2+c) c (-1+2 c-(c^2)+(c^3))))+(((((-1+c))^2) (1-c+(c^2)))/((-2+c) c (-1+2 c-(c^2)+(c^3)))) // Simplify

((1-3 c+3 (c^2)-3 (c^3)+(c^4))/((-2+c) c (-1+2 c-(c^2)+(c^3))))+(((-1+c) (1-4 c+4 (c^2)-3 (c^3)+(c^4)))/((-2+c) c (-1+2 c-(c^2)+(c^3)))) // Simplify