Pensieve header: Extraction graphs for braids representing the Rolfsen table knots.

Old program, from Gamma.nb.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\OU"];
<<KnotTheory`

SetAttributes[VD,Orderless]

bp[i_,j_]:=(Subscript[σ, i,j]); bm[i_,j_]:=(Subscript[(OverBar[σ]), i,j]);

Tidy[vd_VD]:=Module[{ps=Union@@(List@@@vd)},
Replace[vd,Thread[ps->Range@Length@ps],{2}] ]

R12Reduce1[vd_VD]:=Tidy@Module[{R2s,R2},Which[
Length[R2s=Cases[vd,(Subscript[X, s_])[i_,j_]:>(Subscript[X, -s])[i+1,j+1]]⋂(List@@vd)]>0,
Complement[vd,VD[R2=First@R2s,R2/.(Subscript[X, s_])[i_,j_]:>(Subscript[X, -s])[i-1,j-1]]],
Length[R2s=Cases[vd,(Subscript[X, s_])[i_,j_]:>(Subscript[X, -s])[i+1,j-1]]⋂(List@@vd)]>0,
Complement[vd,VD[R2=First@R2s,R2/.(Subscript[X, s_])[i_,j_]:>(Subscript[X, -s])[i-1,j+1]]],
True,DeleteCases[vd,(Subscript[X, _])[i_,j_]/;Abs[i-j]==1]  ]]

R12Reduce[vd_VD]:=FixedPoint[R12Reduce1,vd]

γ[vd_VD] :=Module[{js,s1,i1,j1,s2,i2,j2},
js=Cases[vd,(Subscript[X, _])[_,j_]:>j]⋂Cases[vd,(Subscript[X, _])[i_,_]:>i-1];
If[Length[js]==0,vd,
j1=RandomChoice[js]; i2=j1+1;
Cases[vd,(Subscript[X, s_])[i_,j1]:>(s1=s;i1=i)];
Cases[vd,(Subscript[X, s_])[i2,j_]:>(s2=s;j2=j)];
Tidy@Join[Complement[vd,VD[(Subscript[X, s1])[i1,j1],(Subscript[X, s2])[i2,j2]]],
VD[(Subscript[X, s2])[j1,j2],(Subscript[X, s1])[i1,i2],(Subscript[X, s1 s2])[i1-s1/3,j2+s2/3],(Subscript[X, -s1 s2])[i1+s1/3,j2-s2/3]]
]  ]]

Γ[vd_VD]:=FixedPoint[γ,vd,(2^16)]

Γ[T_] /; Head[T]=!=VD := Γ[VD[T]]

(OverBar[Γ])[vd_VD]:=FixedPoint[γ@*R12Reduce,vd,(2^16)]

(OverBar[Γ])[T_] /; Head[T]=!=VD := (OverBar[Γ])[VD[T]]

VPB[n_,{σs___}]:=VPB[n,σs];

VD /: vd1_VD **vd2_VD := Module[{es1, es2,m2},
es1=Cases[vd1,EOS[i_]:>i];
m2=Max[es2=Cases[vd2,EOS[i_]:>i]];
Tidy[vd1⋃Replace[DeleteCases[vd2,_EOS], i_:>i/m2-1+es1[[1+Count[es2,e_/;i>e]]], {2}]]
]

VD[VPB[n_]]:=VD@@(EOS/@Range[n]);
VD[VPB[n_,(Subscript[σ, i_,j_])]]:=Tidy@Append[VD@@(EOS/@Range[n]),(Subscript[X, +1])[i-0.5,j-0.5]];
VD[VPB[n_,(Subscript[(OverBar[σ]), i_,j_])]]:=Tidy@Append[VD@@(EOS/@Range[n]),(Subscript[X, -1])[i-0.5,j-0.5]];
VD[VPB[n_,σ_,σs__]]:=VD[VPB[n,σ]]**VD[VPB[n,σs]]

VPBGenerators[n_]:=VPBGenerators[n]=Flatten@Table[{(Subscript[σ, i,j]),(Subscript[(OverBar[σ]), i,j])},{i,n},{j,DeleteCases[Range@n,i]}];

ProudFollowers[n_,(Subscript[σ, i_,j_])] :=ProudFollowers[n,(Subscript[σ, i,j])]=Module[{p,q,s},
Flatten@{(Subscript[σ, i,j]),(Subscript[σ, j,i]),(Subscript[(OverBar[σ]), j,i]),
Table[{(Subscript[σ, p,q]),(Subscript[σ, q,p]),(Subscript[(OverBar[σ]), p,q]),(Subscript[(OverBar[σ]), q,p])},{p,{i,j}},{q,Complement[Range[n],{i,j}]}],
Table[{(Subscript[σ, p,q]),(Subscript[(OverBar[σ]), p,q])},{p,Complement[Range[i+1,n],{j}]},{q,Complement[Range[n],{i,j,p}]}]
}];
ProudFollowers[n_,(Subscript[(OverBar[σ]), i_,j_])] := ProudFollowers[n,(Subscript[(OverBar[σ]), i,j])]=ProudFollowers[n,(Subscript[σ, i,j])]/.(Subscript[σ, i,j])->(Subscript[(OverBar[σ]), i,j])

ProudVPBs[n_,0]:={VPB[n]};
ProudVPBs[n_,1]:=VPB[n,#]&/@VPBGenerators[n];
ProudVPBs[n_,m_]/;m>1:=Flatten[ProudVPBs[n,m-1]/.VPB[n,σs___,σ_]:>(VPB[n,σs,σ,#]&/@ProudFollowers[n,σ])]

CountOUForms[n_,m_]:=Module[{k},
Length@Union@Flatten@Table[(OverBar[Γ])@vpb, {k,0,m},{vpb,ProudVPBs[n,k]}]]

New Code

AllOUs[n_,0]:={VD@@Flatten@Table[{BT[2i-1],EOS[2i]},{i,n}]};
AllOUs[n_,m_] /; m>0 := Sort@Flatten[AllOUs[n,m-1] /. vd_VD:>Module[{BTs,EOSs,k,maxO,s},
BTs=Sort@Cases[vd, BT[i_]:>i];
EOSs=Sort@Cases[vd, EOS[i_]:>i];
maxO=Max[1,Max[Cases[vd,(Subscript[X, _])[i_,_]:>i]]];
Table[
Tidy[Append[vd,(Subscript[X, s])[p-0.5,q+0.5]]],
{s,{-1,1}},{k,Length[BTs]},{q,BTs[[k]],EOSs[[k]]-1},{p,Select[BTs,(#≥maxO)&]}
]]]

AllROUs[n_,m_]:= Select[AllOUs[n,m]/.vd_VD:>Tidy@DeleteCases[vd,_BT], (#===R12Reduce[#])&]

ξ[vd_VD]:=Count[(OverBar[Γ])[vd], (Subscript[X, _])[_,_]]

VD/:((Subscript[σ, i_,j_])∣vd_VD):=Switch[Order[ξ[vd],ξ[VD[VPB[Count[vd,_EOS],(Subscript[(OverBar[σ]), i,j])]]**vd]],
0, Print["OMG, Trouble!"],
1, False, -1, True];
VD/:((Subscript[(OverBar[σ]), i_,j_])∣vd_VD):=Switch[Order[ξ[vd],ξ[VD[VPB[Count[vd,_EOS],(Subscript[σ, i,j])]]**vd]],
0, Print["OMG, Trouble!"],
1, False, -1, True];

VD/:Divisors[vd_VD]:=Select[VPBGenerators[Count[vd,_EOS]], (#∣vd)&];
VD/:Quotients[vd_VD]:=(OverBar[Γ])[VD[VPB[Count[vd,_EOS],#/.{σ->(OverBar[σ]),(OverBar[σ])->σ}]]**vd]& /@ Divisors[vd];

OUGraph[n_,m_]:=Module[{gens,OUs,k,d,g,q,m1,m2},
gens=VPBGenerators[n];
OUs=Flatten@Table[AllROUs[n,k],{k,0,m}];
OURule=Dispatch@Thread[OUs->Range@Length@OUs];
Graph[
Range@Length@OUs,
Union@Flatten@Table[
m1=Count[d,(Subscript[X, _])[_,_]];
m2=Count[q=(OverBar[Γ])[VD[VPB[n,g]]**d],(Subscript[X, _])[_,_]];
If[m2<m1,Labeled[(d\[DirectedEdge]q)/.OURule,g],Nothing],
{d,OUs},{g,gens}
]
]
]

ExtractVPB[vd_VD]:=Module[{n,ds,d},
n=Count[vd,_EOS];
If[Length[ds=Divisors[vd]]==0, VPB[n],
d=First@Sort[ds];
q=(OverBar[Γ])[VD[VPB[n,d/.{σ->(OverBar[σ]),(OverBar[σ])->σ}]]**vd];
Insert[ExtractVPB[q],d,2]
]];
CF[vpb_VPB]:=ExtractVPB[(OverBar[Γ])[vpb]];

ExtractionGraph[obj_]:=Module[{vd,n,gs,vs,es,p,m1,m2,g,q,k},
gs=VPBGenerators[n=Count[vd=(OverBar[Γ])[obj],_EOS]];
vs={vd}; es={}; p=0;
While[p<Length[vs],
m1=Count[vd=vs[[++p]],(Subscript[X, _])[_,_]];
Do[
m2=Count[q=(OverBar[Γ])[VD[VPB[n,g/.{σ->(OverBar[σ]),(OverBar[σ])->σ}]]**vd],(Subscript[X, _])[_,_]];
If[m2<m1,
If[!MemberQ[vs,q],AppendTo[vs,q]];
k=Position[vs,q][[1,1]];
AppendTo[es,Labeled[p\[DirectedEdge]k,g]]
],
{g,gs}
]
];
Graph[Table[Labeled[k,(Subscript[k, Length[vs[[k]]]-n])],{k,p}],es]
]

VPB[BR[n_,is_List]] := VPB[n,Module[{π,i},
π=Range[n];
Sequence@@Table[
If[i>0,
π[[{i,i+1}]]=π[[{i+1,i}]]; (Subscript[σ, π[[i+1]],π[[i]]]),
π[[{-i,-i+1}]]=π[[{-i+1,-i}]]; (Subscript[(OverBar[σ]), π[[-i]],π[[-i+1]]])
],
{i,is}
] ]];
VD[br_BR]:=VD[VPB@br]

RandomBraid[n_,m_]:=BR[n,Table[RandomChoice[Range[n-1]⋃(-Range[n-1])],{m}]]

Extraction Graphs for All Knots

(Print[#->(#//BR)];Print[#//BR//ExtractionGraph])&/@AllKnots[];