Pensieve header: A guest class in Lisa Jeffrey’s UTSC reading course (edited).

BarcodeImage["https://drorbn.net/AcademicPensieve/Classes/25-GuestAtUTSC"]

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

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

<<KnotTheory`

PD[Knot[3,1]]

PD[Mirror@Knot[3,1]]

PD[Mirror@Knot[3,1]]/.i_Integer:>If[i<6,i+1,1]

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]];

SetAttributes[p,Orderless]

pd=PD[Knot[3,1]]

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

t2=Expand[Times@@t1]

t3=t2//.p[i_,j_]p[j_,k_]:>p[i,k]

Expand[t3/.{p[i_,i_]:>-(A^2)-(A^(-2)), ((p[i_,j_])^2)->-(A^2)-(A^(-2))}]

pd=PD[Knot[8,17]]

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

t2=Expand[Times@@t1]

t3=t2//.p[i_,j_]p[j_,k_]:>p[i,k]

Expand[t3/.{p[i_,i_]:>-(A^2)-(A^(-2)), ((p[i_,j_])^2)->-(A^2)-(A^(-2))}]

KB1[K_]:=Module[{pd,t1,t2,t3},
pd=PD[K];
t1=pd/.X[i_,j_,k_,l_]:>A p[i,j]p[k,l]+A^(-1)p[i,l]p[j,k];
t2=Expand[Times@@t1];
t3=t2//.p[i_,j_]p[j_,k_]:>p[i,k];
Expand[t3/.{p[i_,i_]:>-(A^2)-(A^(-2)), ((p[i_,j_])^2)->-(A^2)-(A^(-2))}]
]

KB1[Knot[10,165]]

(*KB1[GST48]*)

pd=PD[Knot[4,1]]

front={}; kb=1; todo=List@@pd

v[X[i_,j_,k_,l_]]:=Length[front⋂{i,j,k,l}]

v/@todo

?MaximalBy

MaximalBy[todo,v]

c=RandomChoice[MaximalBy[todo,v]]

t1=Expand[kb*(c/.X[i_,j_,k_,l_]:>A p[i,j]p[k,l]+A^(-1)p[i,l]p[j,k])]

t2=t1//.p[i_,j_]p[j_,k_]:>p[i,k]

kb=Expand[t2/.{p[i_,i_]:>-(A^2)-(A^(-2)), ((p[i_,j_])^2)->-(A^2)-(A^(-2))}]

todo=DeleteCases[todo,c]

front=front⋃List@@c

v/@todo

MaximalBy[todo,v]

c=RandomChoice[MaximalBy[todo,v]]

t1=Expand[kb*(c/.X[i_,j_,k_,l_]:>A p[i,j]p[k,l]+A^(-1)p[i,l]p[j,k])]

t2=t1//.p[i_,j_]p[j_,k_]:>p[i,k]

kb=Expand[t2/.{p[i_,i_]:>-(A^2)-(A^(-2)), ((p[i_,j_])^2)->-(A^2)-(A^(-2))}]

todo=DeleteCases[todo,c]

front=front⋃List@@c

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

KB2[Knot[3,1]]

KB2[Knot[8,17]]

KB2[GST48]

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

KB3[Knot[3,1]]

KB3[GST48]

KB4[K_]:=Module[{front,kb,todo,v,c,t1,t2},
front={}; kb=1; todo=List@@PD[K];
v[X[i_,j_,k_,l_]]:=Length[front⋂{i,j,k,l}];
While[todo=!={},
c=First[todo];
t1=Expand[kb*(c/.X[i_,j_,k_,l_]:>A p[i,j]p[k,l]+A^(-1)p[i,l]p[j,k])];
t2=t1//.p[i_,j_]p[j_,k_]:>p[i,k];
kb=Expand[t2/.{p[i_,i_]:>-(A^2)-(A^(-2)), ((p[i_,j_])^2)->-(A^2)-(A^(-2))}];
todo=DeleteCases[todo,c];
front=Echo@Complement[front⋃List@@c, front⋂List@@c]
];
kb
]

KB4[GST48]