Pensieve Header: Part of the Fiedler project.

<< KnotTheory`

Perm /: Perm[p1___]**Perm[p2___] := Perm[p2][[{p1}]];
Perm[BR[n_, {}]] := Perm @@ Range[n];
Perm[BR[n_, {xs___, x_}]] := Module[{a=Abs[x]},
Perm[BR[n, {xs}]] /. {a-> a+1, a+1->a}
];
TwistedDouble[BR[w_,br_List]] :=BR[2 w,Flatten[{
br/.{j_Integer:>{2 j+{0,-1,1,0}}},
Table[-Sign[Total[Sign@br]],{2*Abs[Total[Sign@br]]}], {1}
}]];
Phi3Table[BR[n_, xings_List], k_] := Module[
{l=Length[xings],j, lft, rgt,jj,perm,tt},
Table[
j=Abs[xings[[i]]];
lft=Join[
-Range[n-k+1,n],
Take[xings,i-1],
Range[n,2+j,-1]
];
rgt=Join[
Range[j-1,1,-1],
Drop[xings,i] /. {jj_Integer :> jj+Sign[jj]},
-Range[2,n-k]
];
perm=Perm[BR[n+1,Join[lft,{j,j+1,j}, rgt]]];
tt=Perm[BR[n+1,rgt]][[If[xings[[i]]>0,j+2, j+1]]];
While[tt>n-k, tt=perm[[tt]]];
Expand[t[tt]*(
BR[n+1,Join[lft,{TP[j]}, rgt]]
)],
{i,l}
]
];

b=Phi3Table[TwistedDouble[BR[Knot[4,1]]],5][[10]] /t[1]

{n,l}=List@@b; len=Length[l];

Module[
{t},
Clear[kt];
kt[s=1, i=0] = t= 0;
While[{s,i} ≠ {1, len},
If[(++i) > len, kt[s,i]=t; i=0];
l[[i]] /. {
j_Integer /; s==Abs[j] :> (kt[++s, i]=++t),
j_Integer /; s==(1+Abs[j]) :> (kt[--s, i]=++t),
TP[j_] /; s==Abs[j] :> (kt[s+=2, i]=++t),
TP[j_] /; s==Abs[j]+1 :> (kt[s, i]=++t),
TP[j_] /; s==Abs[j]+2 :> (kt[s-=2, i]=++t),
_ :> (kt[s,i]=t)
}
]];
tpi=Position[l, _TP][[1,1]];
tpj= Abs[l[[tpi,1]]];  tps=Sign[l[[tpi,1]]];
kt[j_] := kt[j, tpi-1];
tp=If[s>0,
TP[kt[tpj+2], kt[tpj+1], kt[tpj]],
TP[kt[tpj+2], kt[tpj], kt[ tpj+1]]
];
gds=Delete[Table[
j=Abs[l[[i]]];
If[l[[i]]<0,
X[kt[j+1, i-1], kt[j, i-1]],
X[kt[j, i-1], kt[j+1, i-1]]
],
{i,len}
], tpi]*tp;
gds = (# /. Thread[Sort[Cases[#, _Integer, Infinity]] -> {1,2,3,4,5}])& /@gds

?MemberQ

CyclicQ[a_,b_,c_,d_] := If[MemberQ[
{{1,2,3,4},{2,3,4,1},{3,4,1,2},{4,1,2,3}},
Ordering[{a,b,c,d}]
],1,0];
gds /. TP[t1_, t2_, t3_] X[t4_, t5_] :> {
{t1,t2,t3,t4,t5},
eta=If[Signature[{t1,t2,t3}]== 1, 0, 1],
alpha1=CyclicQ[t1,t3,t5,t4],
alpha2=CyclicQ[t1,t4,t5,t3],
alpha3=If[eta==0, CyclicQ[t1,t5,t3,t4], CyclicQ[t1,t4,t3, t5]],
alpha1+alpha2+alpha3
}

Table[kt[s,i], {s,n}, {i,0,Length[l]}] // MatrixForm

b

BraidPlot[CollapseBraid @ BR[Knot["K11n34"]]]