Pensieve header: A fast program for the Kauffman bracket.

BarcodeImage["https://drorbn.net/AcademicPensieve/People/Burton"]

From https://en.wikipedia.org/wiki/Bracket_polynomial:

From https://www.math.uni-hamburg.de/home/runkel/Material/SS20/L1hand.pdf:

<<KnotTheory`

PD[GST48]=PD[X[1,15,2,14],X[29,2,30,3],X[40,4,41,3],X[4,44,5,43],X[5,26,6,27],X[95,7,96,6],X[7,1,8,96],X[8,14,9,13],X[28,9,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]];

GordianUnknot from mail/Burton/250415:

PD[GordianUnknot]=PD[X[1,156,2,157],X[3,225,4,224],X[8,149,9,150],X[9,179,10,178],X[13,207,14,206],X[15,184,16,185],X[18,211,19,212],X[20,137,21,138],X[21,7,22,6],X[25,248,26,249],X[26,277,27,278],X[27,130,28,131],X[29,78,30,79],X[32,167,33,168],X[33,124,34,125],X[34,272,35,271],X[37,106,38,107],X[38,52,39,51],X[39,119,40,118],X[40,195,41,196],X[41,245,42,244],X[44,113,45,114],X[48,200,49,199],X[49,108,50,109],X[50,241,51,242],X[52,120,53,119],X[54,248,55,247],X[55,192,56,193],X[56,101,57,102],X[57,43,58,42],X[58,115,59,116],X[61,46,62,47],X[62,178,63,177],X[63,94,64,95],X[64,263,65,264],X[65,203,66,202],X[67,90,68,91],X[68,268,69,267],X[69,172,70,173],X[70,239,71,240],X[72,35,73,36],X[73,84,74,85],X[75,276,76,277],X[76,164,77,163],X[79,127,80,126],X[80,31,81,32],X[81,166,82,167],X[82,274,83,273],X[85,37,86,36],X[86,71,87,72],X[87,171,88,170],X[88,238,89,237],X[89,268,90,269],X[91,66,92,67],X[92,203,93,204],X[93,263,94,262],X[95,176,96,177],X[96,48,97,47],X[98,59,99,60],X[99,115,100,114],X[100,43,101,44],X[102,194,103,193],X[103,246,104,247],X[104,53,105,54],X[105,120,106,121],X[107,241,108,240],X[109,198,110,199],X[110,98,111,97],X[111,60,112,61],X[112,45,113,46],X[116,243,117,244],X[117,197,118,196],X[121,74,122,75],X[122,84,123,83],X[123,272,124,273],X[125,169,126,168],X[127,30,128,31],X[128,78,129,77],X[131,279,132,278],X[132,250,133,249],X[134,23,135,24],X[136,7,137,8],X[139,213,140,212],X[140,17,141,18],X[142,184,143,183],X[143,15,144,14],X[144,205,145,206],X[146,11,147,12],X[148,179,149,180],X[150,135,151,136],X[151,23,152,22],X[153,4,154,5],X[154,225,155,226],X[157,252,158,253],X[158,281,159,282],X[160,219,161,220],X[161,28,162,29],X[162,130,163,129],X[165,274,166,275],X[171,239,172,238],X[173,266,174,267],X[180,259,181,260],X[181,230,182,231],X[186,155,187,156],X[187,3,188,2],X[190,134,191,133],X[191,24,192,25],X[194,245,195,246],X[200,176,201,175],X[201,264,202,265],X[204,235,205,236],X[208,231,209,232],X[209,182,210,183],X[210,258,211,257],X[214,6,215,5],X[215,152,216,153],X[216,190,217,189],X[220,159,221,160],X[221,281,222,280],X[223,188,224,189],X[226,213,227,214],X[227,139,228,138],X[228,19,229,20],X[232,207,233,208],X[233,13,234,12],X[234,145,235,146],X[242,197,243,198],X[250,218,251,217],X[251,222,252,223],X[254,185,255,186],X[255,16,256,17],X[256,142,257,141],X[258,230,259,229],X[260,147,261,148],X[261,11,262,10],X[265,174,266,175],X[269,236,270,237],X[270,169,271,170],X[275,164,276,165],X[279,219,280,218],X[282,254,1,253]];

1+1

SetAttributes[p,Orderless]

K=Knot[3,1]

PD[K]

PD[K]/.X[i_,j_,k_,l_]:>A p[i,j]p[k,l]+(A^(-1))p[i,l]p[j,k]

Expand[Times@@PD[K]/.X[i_,j_,k_,l_]:>A p[i,j]p[k,l]+(A^(-1))p[i,l]p[j,k]]

Expand[Times@@PD[K]/.X[i_,j_,k_,l_]:>A p[i,j]p[k,l]+(A^(-1))p[i,l]p[j,k]]//.p[i_,j_]p[j_,k_]:>p[i,k]

Expand[Expand[Times@@PD[K]/.X[i_,j_,k_,l_]:>A p[i,j]p[k,l]+(A^(-1))p[i,l]p[j,k]]//.p[i_,j_]p[j_,k_]:>p[i,k]/.((p[_,_])^2)->(-(A^2)-(A^(-2)))]

K=Knot[10,165]

Expand[Expand[Times@@PD[K]/.X[i_,j_,k_,l_]:>A p[i,j]p[k,l]+(A^(-1))p[i,l]p[j,k]]//.p[i_,j_]p[j_,k_]:>p[i,k]/.((p[_,_])^2)->(-(A^2)-(A^(-2)))]

FKB[K_]:=Module[{front={},v,todo,x,kb=1},
v[X[i_,j_,k_,l_]]:=Length[front⋂{i,j,k,l}];
todo=List@@PD[K];
While[todo=!={},
x=RandomChoice[MaximalBy[todo,v]];
kb=Expand[Expand[(x/.X[i_,j_,k_,l_]:>A p[i,j]p[k,l]+(A^(-1))p[i,l]p[j,k])kb]//.p[i_,j_]p[j_,k_]:>p[i,k]/.((p[_,_])^2)->(-(A^2)-(A^(-2)))];
todo=DeleteCases[todo,x];
front=front⋃(List@@x);
];
Expand@Together[kb/(-(A^2)-(A^(-2)))]
]

FKB[Knot[3,1]]

FKB[Knot[10,165]]

FKB[GST48]

NaiveWidth[K_]:=Module[{front={},v,todo,x,w=0},
v[X[i_,j_,k_,l_]]:=Length[front⋂{i,j,k,l}];
todo=List@@PD[K];
While[todo=!={},
x=RandomChoice[MaximalBy[todo,v]];
todo=DeleteCases[todo,x];
front=Complement[front⋃(List@@x),front⋂(List@@x)];
w=Max[w,Length@front]
];
w
]

Table[NaiveWidth[GST48], {32}]

Min@Table[NaiveWidth[GST48], {1000}]

Table[NaiveWidth[GordianUnknot], {32}]

Min@Table[NaiveWidth[GordianUnknot], {1000}]

AbsoluteTiming@FKB[GordianUnknot]