Pensieve header: Computing the Jones polynomial, rough procedure.

First, Class Introduction as in http://drorbn.net/AcademicPensieve/Classes/17-1350-AKT/About.html.

The Jones Polynomial of the Trefoil Knot

<< KnotTheory`

K=Knot[4,1]

PD[K]

PositiveQ[X[3,6,4,1]]

(x+y)^2

(x+y)^2//TreeForm

(x+y)^2 /. y->z

(x+y)^2 /. 2->3.14

{1,2,3,4} /. _  :> 7

{1,2,3,4} /. _Integer  :> 7

{1,2,3,4} /. Travis_Integer  :> 7

{1,2,3,4} /. Travis_Integer  :> Travis^3

f@@((x+y)^2)

(x+y)^2

Power[Plus[x,y],2]

PD[K]

t1=PD[K] /. x_X :> If[PositiveQ[x], Xp@@x, Xm@@x]

t1

t2=Times@@t1

t3=t2 /. {
Xp[i_,j_,k_,l_] :> q*P[i,j]P[k,l]-q^2*P[i,l]P[j,k],
Xm[i_,j_,k_,l_] :> -q^(-2)*P[i,j]P[k,l]+1/q*P[i,l]P[j,k]
}

Expand[(a+b)(c+d)]

Expand[(x+y)^10]

t4=Expand[t3]

{PP[1,3], PP[3,1]}

SetAttributes[PP, Orderless]

{PP[1,3], PP[3,1]}

SetAttributes[P, Orderless]

t5=t4 //. P[a_,b_]P[b_,c_] :> P[a,c]

t6=t5 /. {
P[i_,i_] :> (q+1/q),
P[i_,j_]^2 :> (q+1/q)
}

Expand[t6]

Simplify[t6]

Jones[Knot[4,1]][q]

Simplify[(t6/(q+(q^(-1)))) /. q->(Sqrt[q])]

A Jones Polynomial Program

J[K_] := Module[{t1,t2,t3,t4,t5,t6,P},
SetAttributes[P, Orderless];
t1=PD[K] /. x_X :> If[PositiveQ[x], Xp@@x, Xm@@x];
t2=Times@@t1;
t3=t2 /. {
Xp[i_,j_,k_,l_] :> q*P[i,j]P[k,l]-q^2*P[i,l]P[j,k],
Xm[i_,j_,k_,l_] :> -q^(-2)*P[i,j]P[k,l]+1/q*P[i,l]P[j,k]
};
t4=Expand[t3];
t5=t4 //. P[a_,b_]P[b_,c_] :> P[a,c];
t6=t5 /. {
P[i_,i_] :> (q+1/q),
P[i_,j_]^2 :> (q+1/q)
};
Simplify[(t6/(q+(q^(-1)))) /. q->(Sqrt[q])]
]

J[Knot[8,17]]

Jones[Knot[8,17]][q]

(K|->Expand[J[K]]==Jones[K][q]) /@ AllKnots[{3,10}]

Testing the Reidemeister Moves

SetAttributes[P, Orderless];
TJ[t2_] := Module[{t3,t4,t5,t6},
t3=t2 /. {
Xp[i_,j_,k_,l_] :> q*P[i,j]P[k,l]-q^2*P[i,l]P[j,k],
Xm[i_,j_,k_,l_] :> -q^(-2)*P[i,j]P[k,l]+1/q*P[i,l]P[j,k]
};
t4=Expand[t3];
t5=t4 //. P[a_,b_]P[b_,c_] :> P[a,c];
t6=t5 /. {
P[i_,i_] :> (q+1/q),
P[i_,j_]^2 :> (q+1/q)
};
Simplify[t6]
]

Xp[2,2,3,1] // TJ

Xm[1,2,2,3] // TJ

TJ /@ {Xp[1,5,2,4]Xm[2,5,3,6], Xp[4,3,5,2]Xm[5,1,6,2]}

TJ /@ {Xp[4,2,5,1]Xp[7,3,8,2]Xp[8,6,9,5], Xp[7,5,8,4]Xp[8,2,9,1]Xp[5,3,6,2]}

%[[1]]==%[[2]]

Analyzing a knot suggested by David Vincent

K1=PD[X[6,14,7,13], X[14,6,15,5], X[4,7,5,8], X[8,15,9,16],
X[16,3,1,4], X[12,9,13,10], X[10,1,11,2], X[2,11,3,12]];

J1=J[K1]

Select[AllKnots[{3,8}], J[#]==J1&]