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[G_Symbol,(Subscript[S, n_])]:=Module[{α,β,e},
G/:Ord[G]=n!;
G/:Elements[G]=PermutationCycles/@(Permutations@Range@n);
Do[G/:g[G,α]=e=Elements[G][[α]]; G/:ind[G,e]=α,
{α,Ord[G]} ];
Do[G/: m[G,α,β]=ind[G,g[G,α]~PermutationProduct~g[G,β]],
{α,Ord[G]},{β,Ord[G]} ];
Do[G/: inv[G,α]=ind[G,InversePermutation[g[G,α]]],
{α,Ord[G]} ] ]

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

g[α_]:=g[$G,α]; ind[α_]:=ind[$G,α]; m[α_,β_]:=m[$G,α,β]; inv[α_]:=inv[$G,α];

(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[$G=S3,(Subscript[S, 3])];
Table[m[i,j],{i,Ord[$G]},{j,Ord[$G]}]//MatrixForm

Elements[$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[$G]} ]

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[$G]} ]

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[$G]} ]

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[$G]}]]

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[$G]}] ]

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[$G=S4,(Subscript[S, 4])];
tab=Table[Echo@Timing[K->ZEF[K]], {K,AllKnots[{3,7}]}];

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

To do: Implement and verify Δ etc.