Computing the Jones Polynomial

The function JP[ ] returns the Jones polynomial of a knot - an embedding of (S^1) in 3 dimensional Euclidean space defined up to ambient isotopies - while also printing its Kauffman bracket and writhe. The computation of the Kauffman bracket works as the one made in class. For the computation of the writhe to work, the expression of the form X[(Subscript[i, 1]),(Subscript[j, 1]),(Subscript[k, 1]),(Subscript[l, 1])]... X[(Subscript[i, n]),(Subscript[j, n]),(Subscript[k, n]),(Subscript[l, n])] representing the knot must be chosen in a systematic way (more so than what is necessary to compute the Kauffman bracket). The method for entering a knot K is as follows :

Choose an orientation on K

Number the edges of K separated by crossings consecutively following the positive orientation, until coming back to edge 1. Doing so, choose edge 1 so that, at the first crossing encountered in the positive direction along K, the thread going from edge 1 to edge 2 passes ‘under’ the other thread.

For each crossing X in K, multiply the expression for K by the factor X[i,j,k,l], where i is the label of the edge incoming to the crossing on the thread going ‘under’. j,k,l are the numbers of the other edges, in the order given by counterclockwise rotation starting from the edge i. That is, X[i,j,k,l] is associated to the crossing drawn below. This process yields the final expression for K.

Note that the function JP cannot compute the Jones polynomial of the simple unknot (i.e. of a circle without crossings). I suppose it would be easy to deal with this case, but obviously it’s not worth the effort... No need of an exoskeleton to compute that.

JP[K_]:=(Module[{b1,b2,b3,b4,b5,w1,w2,w3,w4,J},
(*This part computes the Kauffman bracket*)
b1=K//.X[i_,j_,k_,l_]:>A P[i,j] P[k,l]+B P[j,k] P[i,l];
b2=Expand[b1];
SetAttributes[P,Orderless];
b3=b2//.P[i_,j_] P[j_,k_]:>P[i,k];
b4=b3//.{((P[i_,j_])^2)->d,P[i_,i_]->d};
Print["The Kauffman bracket is "];
Print[b5=Expand[b4//.{B->1/A,d->-(A^2)-1/(A^2)}]];

(*This part computes the writhe. The systematic numbering of the edges insures that this can be made without adding more information to the input. This uses the fact that the crossing X[i,j,k,l] is right-handed if and only if the orientation on K goes from the edge l to the edge j. This happens if j>l or if j==1.*)
w1=K/.{Times:>Plus};
w2=w1//.X[i_,j_,k_,l_]:>If[j==1,1,X[i,j,k,l]]; 
w3=w2//.X[i_,j_,k_,l_]:>If[l==1,-1,X[i,j,k,l]];
w4=w3//.X[i_,j_,k_,l_]:>If[j>l,1,-1];
Print["The writhe is "];
Print[w4];

(*This part computes the Jones Polynomial*)
Print["The Jones Polynomial is "];
J=Expand[(((-(A^3)))^(-w4))b5]
]
)

Examples

Trefoil Knot

Ktre1=X[1,5,2,4]X[3,1,4,6]X[5,3,6,2];

JP[Ktre1]

Mirror Trefoil Knot

Ktre2=X[1,4,2,5]X[3,6,4,1]X[5,2,6,3];

JP[Ktre2]

Knot (Subscript[8, 17])

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

JP[K817]