Pensieve header: October 13: A Faster Jones Program.

Today. A faster Jones, then whatever you may suggest, then EIWL 9-12, then, if time, Patterns.

Topics (in no particular order). Whatever you may suggest; whatever comes to my mind; the Fibonacci numbers; the Catalan numbers; the Jones polynomial; a more efficient Jones algorithm; a riddle on spheres; Khovanov homology; Γ-calculus; the Hopf fibration; Hilbert’s 13th problem; non-commutative Gaussian elimination; free Lie algebras; the Baker-Campbell-Hausdorff formula; wacky numbers; an order 4 torus; the Schwarz Lantern; knot colourings; the Temperley-Lieb pairing; the dodecahedral link; sound experiments; barycentric subdivisions; a Peano curve; braid closures and Vogel’s algorithm; the insolubility of the quintic; phase portraits; the Mandelbrot set; shadows of the Cantor aerogel; quilt plots; some image transformations; De Bruijn graphs; the Riemann series theorem; finite type invariants and the Willerton fish; the Hanoi towers.

<<KnotTheory`

PD[Knot[3,1]]

Knot[8,17]

Knot[8,17] // PD

Jones[PD[Knot[3,1]]][q]

AllKnots[{3,10}] // Length

SetAttributes[P,Orderless];
JP[K_Times,opts___Rule]:=Module[{verb,n, b1,b2,b3,b4,b5,w,J},
verb=Verbose/.{opts} /. Verbose ->False;
n=Length[K];
If[verb, Print["K has ",n," crossings."]];
b1=K//.X[i_,j_,k_,l_]:>A P[i,j] P[k,l]+B P[j,k] P[i,l];
b2=Expand[b1];
b3=b2//.P[i_,j_] P[j_,k_]:>P[i,k];
b4=b3//.{((P[i_,j_])^2)->d,P[i_,i_]->d};
b5=Expand[b4//.{B->1/A,d->-(A^2)-1/(A^2)}];
If[verb, Print["The Kauffman bracket is "]];
If[verb, Print[b5]];
w=K/.{Times->Plus, X[_,1,_,2n] ->1, X[_,2n,_,1]->-1, X[_,j_,_,l_]:>If[j>l,1,-1]};
If[verb,Print["The writhe is "]];
If[verb,Print[w]];
If[verb,Print["The Jones Polynomial is "]];
J=Expand@Cancel[(((((-(A^3)))^(-w))b5)/(-(A^2)-1/(A^2))) /. A->(q^(-1/4))]
];
JP[K_PD, opts___] := JP[Times@@K, opts];
JP[K_Knot, opts___] := JP[PD@K, opts];

JP[Knot[3,1], Verbose -> True]

Timing[tab1=Table[JP[K], {K, AllKnots[{3,10}]}];]

tab2=Table[Jones[K][q], {K, AllKnots[{3,10}]}];

tab1==tab2

Union[tab1]//Length

A 48-crossing knot

Import["http://drorbn.net/AcademicPensieve/2016-09/GST48-Marked.png"]

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

(2^48)

b1=K//.X[i_,j_,k_,l_]:>A P[i,j] P[k,l]+B P[j,k] P[i,l];
b2=Expand[b1];
b3=b2//.P[i_,j_] P[j_,k_]:>P[i,k];
b4=b3//.{((P[i_,j_])^2)->d,P[i_,i_]->d};
b5=Expand[b4//.{B->1/A,d->-(A^2)-1/(A^2)}];

Knot[3,1] // PD

J1=X[1,4,2,5]/.X[i_,j_,k_,l_]:>A P[i,j] P[k,l]+(A^(-1)) P[j,k] P[i,l]

J2=Expand[J1]

J3=J2 //. P[i_,j_] P[j_,k_]:>P[i,k]

J4= J3 /. {((P[i_,j_])^2)->-(A^2)-1/(A^2),P[i_,i_]->-(A^2)-1/(A^2)}

J5=Expand[J4]

J1=J5*(X[3,6,4,1] /. X[i_,j_,k_,l_]:>A P[i,j] P[k,l]+(A^(-1)) P[j,k] P[i,l])

J2=Expand[J1];
J3=J2 //. P[i_,j_] P[j_,k_]:>P[i,k];
J4= J3 /. {((P[i_,j_])^2)->-(A^2)-1/(A^2),P[i_,i_]->-(A^2)-1/(A^2)};
J5=Expand[J4]

J1=J5*(X[5,2,6,3] /. X[i_,j_,k_,l_]:>A P[i,j] P[k,l]+(A^(-1)) P[j,k] P[i,l])

J2=Expand[J1];
J3=J2 //. P[i_,j_] P[j_,k_]:>P[i,k];
J4= J3 /. {((P[i_,j_])^2)->-(A^2)-1/(A^2),P[i_,i_]->-(A^2)-1/(A^2)};
J5=Expand[J4]

PD[Knot[3,1]]

FJ[K_PD] := Module[{J=1,todo,front,v,x,n,w},
n=Length[K];
todo=List@@K;
front={};
v[x_X]:=Length[front⋂(List@@x)];
While[todo=!={},
x=RandomChoice@MaximalBy[todo, v];
J=Expand[J*(x /. X[i_,j_,k_,l_]:>A P[i,j] P[k,l]+(A^(-1)) P[j,k] P[i,l])];
J=J//. P[i_,j_] P[j_,k_]:>P[i,k];
J=Expand[J/. {((P[i_,j_])^2)->-(A^2)-1/(A^2),P[i_,i_]->-(A^2)-1/(A^2)}];
todo=DeleteCases[todo, x];
(* todo=Complement[todo, {x}]; *)
(* front=Complement[front⋃(List@@x), front⋂(List@@x)]) *)
front=front⋃(List@@x);
];
w=K/.{PD->Plus, X[_,1,_,2n] ->1, X[_,2n,_,1]->-1, X[_,j_,_,l_]:>If[j>l,1,-1]};
Expand@Cancel[(((((-(A^3)))^(-w))J)/(-(A^2)-1/(A^2))) /. A->(q^(-1/4))]
];
FJ[K_Knot]:= FJ[PD@K];

FJ[Knot[3,1]]

Timing[tab3=FJ /@ AllKnots[{3,10}];]

tab3==tab1

FJ[GST48] // Timing

?MaximalBy

rands=RandomReal[{-1,1},20]

Max[rands]

Min [rands]

-Max[-rands]

MaximalBy[rands, Abs]

f[x_] := -x;
MaximalBy[rands, f]

(((f[x]+g))^3)//Expand

?Function

Function[-#][77]

Function[#1+#2][3,4]

(#1+#2)&[4,5]

MaximalBy[rands,-#&]

Function[{x,y},x+y][5,6]

(x|->(x^2))[5]

Clear[BFJ];
BFJ[K_PD] := Module[{J=1,todo=List@@K,ocean={},x,n=Length[K],w},
While[todo=!={},
x=RandomChoice@MaximalBy[todo, x|->Length[ocean⋂(List@@x)]];
J=Expand[J*(x /. X[i_,j_,k_,l_]:>A P[i,j] P[k,l]+(A^(-1)) P[j,k] P[i,l])];
J=J//. P[i_,j_] P[j_,k_]:>P[i,k];
J=Expand[J/. ((P[_,_])^2)|P[i_,i_]->-(A^2)-1/(A^2)];
todo=DeleteCases[todo, x];
ocean=ocean⋃(List@@x);
];
w=Plus@@K/.{X[_,1,_,2n] ->1, X[_,2n,_,1]->-1, X[_,j_,_,l_]:>If[j>l,1,-1]};
Expand@Cancel[(((((-(A^3)))^(-w))J)/(-(A^2)-1/(A^2))) /. A->(q^(-1/4))]
];
BFJ[K_Knot]:= BFJ[PD@K];

BFJ[Knot[3,1]]==FJ[Knot[3,1]]

Cases[{1,2,3,3.14,4,5}, _Integer]

Cases[{1,2,2.78,3,3.14,4,5}, 3.14|_Integer]