Pensieve header: The WG Algebra with care for conjugacy invariant sets and for tangles.

Once[<<KnotTheory`];
HL[ℰ_] := Style[ℰ, Background -> If[TrueQ@ℰ,,]];
χ[cond_]:=If[TrueQ[cond],1,0];

DeclareGroup[(Subscript[S, k_])]:=Module[{α,β,e,γs},
Clear[G,n,g,ι,m,η,inv];
G=PermutationCycles/@(Permutations@Range@k);
n=Length[G];
Do[g[α]=e=G[[α]]; ι[e]=α,{α,n} ];
η=ι[Cycles[{}]];
Do[m[α,β]=ι[g[α]~PermutationProduct~g[β]],{α,n},{β,n} ];
m[α_]:=α; m[α_,β_,γs__]:=m[m[α,β],γs];
Do[inv[α]=ι[InversePermutation[g[α]]],{α,n}]
]

ConjugacyClasses:=Module[{sea=Range@n,ccs={},cc},
While[Length@sea>0,
cc=Union[Table[m[inv[α],First@sea,α], {α,n}]];
AppendTo[ccs,cc];
sea=Complement[sea,cc];
]; ccs]

(Subscript[m, i_,j_->k_])[ℰ_]:=Expand[ℰ]/.(Subscript[W, i])[α_,β_](Subscript[W, j])[γ_,δ_]:>χ[m[α,β]==m[β,γ]](Subscript[W, k])[α,m[β,δ]]

(* $CIS is a Conjugation Invariant Set *)
(Subscript[R, i_,j_]):=Sum[(Subscript[W, i])[α,1](Subscript[W, j])[β,α], {α,$CIS}, {β,$CIS}];
(Subscript[(OverBar[R]), i_,j_]):=Sum[(Subscript[W, i])[α,1](Subscript[W, j])[β,inv@α], {α,$CIS}, {β,$CIS}];
(Subscript[η, i_]):=Sum[(Subscript[W, i])[α,1], {α,$CIS}];

DeclareGroup[(Subscript[S, 3])];
Table[m[i,j],{i,n},{j,n}]//MatrixForm

G

ConjugacyClasses[$G]

Table[{
Short[lhs=(Subscript[R, 1,2])(Subscript[R, 4,3])(Subscript[R, 5,6])//(Subscript[m, 1,4->1])//(Subscript[m, 2,5->2])//(Subscript[m, 3,6->3])],
rhs=(Subscript[R, 2,3])(Subscript[R, 1,4])(Subscript[R, 5,6])//(Subscript[m, 1,5->1])//(Subscript[m, 2,6->2])//(Subscript[m, 3,4->3]); HL[lhs==rhs]},
{$CIS, ConjugacyClasses} ]

Table[
lhs=(Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]);rhs=(Subscript[η, 1])(Subscript[η, 2])//Expand; HL[lhs==rhs],
{$CIS, ConjugacyClasses} ]

Table[
lhs=(Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 4,2->2]); rhs=(Subscript[η, 1])(Subscript[η, 2])//Expand; HL[lhs==rhs],
{$CIS, ConjugacyClasses} ]

Z[K_]:=Module[{z},Sum[
z=Expand[Times@@PD[K]/.x:X[i_,j_,k_,l_]:>If[PositiveQ@x, (Subscript[R, l,i]),(Subscript[(OverBar[R]), j,i])]];
Do[z=z//(Subscript[m, c[[1]],c[[j]]->c[[1]]]),{c,Skeleton[K]},{j,2,Length@c}];
z,
{$CIS, ConjugacyClasses}]]

tab=Table[Echo@Timing[K->Z[K]], {K,AllKnots[{3,7}]}];

Edge-vertex convention: an oriented edge carries the same label as the vertex ending it.

ZF[K_]:=ZF[PD@K];
ZF[pd_PD]:=Module[{z,done,st,c,mn,k},
Sum[
z=1; done={};st=Range[2Length@pd];
Do[
z*=c/.X[i_,j_,_,l_]:>If[PositiveQ@c,mn={i,l}; (Subscript[R, l,i]),mn={i,j};(Subscript[(OverBar[R]), j,i])];
Do[
If[MemberQ[done, k+1],z=z//(Subscript[m, k,k+1->k]); st=st/.k+1->k];
If[MemberQ[done, k-1],z=z//(Subscript[m, st[[k-1]],k->st[[k-1]]]); st=st/.k->st[[k-1]]],
{k,mn}];
done=done⋃mn,
{c,List@@pd}];
z,
{$CIS, ConjugacyClasses}] ]

tab=Table[Echo@Timing[K->ZF[K]], {K,AllKnots[{3,9}]}];

ThinPosition[K_]:=Module[{todo,done,pd,c},
todo=List@@PD@K; done={}; pd=PD[];
While[todo=!={},
AppendTo[pd,c=RandomChoice@MaximalBy[todo, Length[done⋂List@@#]&]];
todo=DeleteCases[todo, c];
done=done⋃List@@c];
pd
]

ThinPosition[Knot[3,1]]

ZEF[K_]:=ZF@ThinPosition@K;

tab=Table[Echo@Timing[K->ZEF[K]], {K,AllKnots[{3,10}]}];

Max[First/@tab]

DeclareGroup[(Subscript[S, 4])];
tab=Table[Echo@Timing[K->ZEF[K]], {K,AllKnots[{3,7}]}];

DeclareGroup[(Subscript[S, 5])];
tab=Table[Echo@Timing[K->ZEF[K]], {K,AllKnots[{3,7}]}];

To do: Implement and verify Δ etc.