Pensieve header: February 8: A faster Jones program.

The old Jones program

SetAttributes[P, Orderless];
OldJones[Knot_] := Module[{t1,t2},
t1=Expand[Knot /. {
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]+(q^(-1))*P[i,l]P[j,k]
}];
t2=t1 //. P[a_,b_]P[b_,c_] :> P[a,c];
Simplify[t2 /. {P[i_,i_] :> (q+1/q), ((P[i_,j_])^2) :> (q+1/q)}]
]

A 48-crossing knot

K=Xp[4,88,5,87] Xp[5,75,6,74] Xp[6,62,7,61] Xp[7,49,8,48] Xp[8,36,9,35] Xp[9,23,10,22] Xp[16,4,17,3] Xp[17,87,18,86] Xp[18,74,19,73] Xp[19,61,20,60] Xp[20,48,21,47] Xp[21,35,22,34] Xp[28,16,29,15] Xp[29,3,30,2] Xp[30,86,31,85] Xp[31,73,32,72] Xp[32,60,33,59] Xp[33,47,34,46] Xp[40,28,41,27] Xp[41,15,42,14] Xp[42,2,43,1] Xp[43,85,44,84] Xp[44,72,45,71] Xp[45,59,46,58] Xp[52,40,53,39] Xp[53,27,54,26] Xp[54,14,55,13] Xp[55,1,56,96] Xp[56,84,57,83] Xp[57,71,58,70] Xp[64,52,65,51] Xp[65,39,66,38] Xp[66,26,67,25] Xp[67,13,68,12] Xp[68,96,69,95] Xp[69,83,70,82] Xp[76,64,77,63] Xp[77,51,78,50] Xp[78,38,79,37] Xp[79,25,80,24] Xp[80,12,81,11] Xp[81,95,82,94] Xp[88,76,89,75] Xp[89,63,90,62] Xp[90,50,91,49] Xp[91,37,92,36] Xp[92,24,93,23] Xp[93,11,94,10];

The new Jones program

Dynamic[todo1]

1+1

NewJones[K_] := Module[{J=1,todo=List@@K,inter={},x},
While[Length[todo]≥1,
todo1=todo;
x=RandomChoice[MaximalBy[todo, Length[inter⋂(List@@#)]&]];
J=Expand[J*(x/. {
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]+(q^(-1))*P[i,l]P[j,k]
})] //. P[a_,b_]P[b_,c_] :> P[a,c] /. {P[i_,i_] :> (q+1/q), ((P[i_,j_])^2) :> (q+1/q)};
inter=Complement[inter⋃List@@x, inter⋂List@@x];
todo=Complement[todo, {x}]
];
Expand[J]
]

Jones[K]

inter=Complement[inter⋃List@@x, inter⋂List@@x]

J=Expand[J*(x/. {
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]+(q^(-1))*P[i,l]P[j,k]
})] //. P[a_,b_]P[b_,c_] :> P[a,c] /. {P[i_,i_] :> (q+1/q), ((P[i_,j_])^2) :> (q+1/q)}

{J=1,todo=List@@K,inter={}}

todo /. Xp[i_,j_,k_,l_] :> Length[Intersection[inter, {i,j,k,l}]]

Max[%]

x=RandomChoice[MaximalBy[todo, Length[inter⋂(List@@#)]&]]

Jones[K_] := Module[{J=1,todo=List@@K,inside={},x},
While[Length[todo]≥1,
x=RandomChoice[MaximalBy[todo, Length[inside⋂(List@@#)]&]];
J=Expand[J*(x/. {
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]+(q^(-1))*P[i,l]P[j,k]
})] //. P[a_,b_]P[b_,c_] :> P[a,c] /. {P[i_,i_]:>(q+1/q),((P[i_,j_])^2) :> (q+1/q)};
inside=inside⋃List@@x;
todo=DeleteCases[todo, x]
];
Expand[J]
]

Jones[K] // Timing

{y,(y^2),(y^3)} /. (y^(n_.)):> Table[y, n]

?Default

?DeleteCases