0-co one step middle c program.

The format is E = {Const,Linear,Quad} which means O(Const (e^(Linear+Quad)))  we take b=Log[t]

(*Stitching operation*)
m[i_,j_,k_][E_]:=Block[
{α,β,γ,Γ,δ,C,L,Q,QRest,μ },
C=E[[1]]; (*The (inverse of the) constant in front, aka ω*)
L=E[[2]]; (*The linear term of the exponential, unscaled*)
Q=E[[3]]; (*The quadratic term (unscaled).*)

α = D[Q,(Subscript[w, i])]/.(Subscript[a, j ])->0;
β = D[Q,(Subscript[a, j])]/.(Subscript[w, i ])->0;
γ = D[L,(Subscript[c, i])]; (*includes b*)
Γ = D[L,(Subscript[c, j])];
δ = D[Q,(Subscript[a, j]),(Subscript[w, i])];
QRest=Q/.{(Subscript[a, j ])->0,(Subscript[w, i ])->0};
μ  = 1-(1-(Subscript[t, k]))δ;

{μ C,L, QRest+(μ^(-1))((1-(Subscript[t, k]))α β +Exp[Γ]α (Subscript[w, i])+Exp[γ]β (Subscript[a, j])+Exp[γ+Γ]δ (Subscript[a, j])(Subscript[w, i]) )}/.
{(Subscript[c, i|j])->(Subscript[c, k]),(Subscript[a, i|j])->(Subscript[a, k]),(Subscript[w, i|j])->(Subscript[w, k]),(Subscript[t, i|j])->(Subscript[t, k])}//Together
]

EE={2-(Subscript[t, 1]),Log[(Subscript[t, 2])] (Subscript[c, 1])+2 Log[(Subscript[t, 1])](Subscript[c, 2]),2r (Subscript[a, 3])(Subscript[w, 1])+3s (Subscript[a, 2])(Subscript[w, 1])+2r (Subscript[a, 2])(Subscript[w, 3])};

(*Meta-associativity*)
(EE//m[1,2,1]//m[1,3,1]//Expand)-
(EE//m[2,3,2]//m[1,2,1]//Expand)

(*Disjoint union of two tangles, multiplies the constant terms, adds the exponents*)
DisjUnion[L_]:={Times@@L[[All,1]],Plus@@L[[All,2]],Plus @@L[[All,3]]}

(*R-matrix*)
Rp[i_,j_]:={1,Log[(Subscript[t, i])] (Subscript[c, j]),(Subscript[a, i])(Subscript[w, j])}
Rm[i_,j_]:={1,-Log[(Subscript[t, i])](Subscript[c, j]),-(((Subscript[t, i]) )^(-1))(Subscript[a, i])(Subscript[w, j])}

(*Cuaps*)
nr[i_]:={((Subscript[t, i])^(1/2)),0,0}
nl[i_]:={1,0,0}
ur[i_]:={((Subscript[t, i])^(-1/2)),0,0}
ul[i_]:={1,0,0}

(*Reidemeister 2*)
DisjUnion@{Rp[1,2],Rm[3,4]}//m[1,3,x]//m[2,4,y]

(*Reidemeister 3*)
(DisjUnion@{Rp[1,2],Rp[3,4],Rp[5,6]}//m[1,3,x]//m[2,5,y]//m[4,6,z])-
(DisjUnion@{Rp[1,2],Rp[3,4],Rp[5,6]}//m[3,5,x]//m[1,6,y]//m[2,4,z])

(*Kinks*)
Kp[i_]:={(Sqrt[(Subscript[t, i])]),Log[(Subscript[t, i])] (Subscript[c, i]),(Subscript[a, i]) (Subscript[w, i])}
Km[i_]:={(1/(Sqrt[(Subscript[t, i])])),-Log[(Subscript[t, i])] (Subscript[c, i]),-(((Subscript[a, i]) (Subscript[w, i]))/(Subscript[t, i]))}

DisjUnion[{Rp[1,4],nr[2],ul[3]}]//m[1,2,1]//m[1,3,1]//m[1,4,1]
DisjUnion[{Rm[4,1],nr[2],ul[3]}]//m[1,2,1]//m[1,3,1]//m[1,4,1];
DisjUnion[{Rp[4,1],nl[2],ur[3]}]//m[1,2,1]//m[1,3,1]//m[1,4,1];
DisjUnion[{Rm[1,4],nl[2],ur[3]}]//m[1,2,1]//m[1,3,1]//m[1,4,1];

(*3_1 0-Framed*)
Z=DisjUnion@{Rp[5,1],Rp[2,6],Rp[7,3],ur[4],Km[8],Km[9],Km[10]};
For[i=2,i≤10,i++,Z=Z//m[1,i,1]];
Z//Expand

(*4_1 0-Framed*)
Z=DisjUnion@{Rm[8,1],Rp[5,9],Rm[2,6],Rp[10,3],nr[7],ur[4]};
For[i=2,i≤10,i++,Z=Z//m[1,i,1]];
Z//Expand

(*5_1 0-framed*)
Z=DisjUnion@{Rp[7,1],Rp[2,8],Rp[9,3],Rp[4,10],Rp[11,5],ur[6],Km[12],Km[13],Km[14],Km[15],Km[16]};
For[i=2,i≤16,i++,Z=Z//m[1,i,1]];
Z//Expand

ReverseStrand[i_][E_]:=Block[(*Strand reversal means taking the q-antipode S at strand i. This changes the order acw to the opposite order wca so we need to commute it back.*)
 {α,β,γ,Γ,δ,C,L,Q,QRest,μ },
(*First apply the antipode to the terms*)
C=E[[1]]/.{(Subscript[a, i])->-((Subscript[t, i])^(-1))(Subscript[a, i]),(Subscript[t, i])->((Subscript[t, i])^(-1)),(Subscript[c, i])->-(Subscript[c, i]),(Subscript[w, i])->-(Subscript[w, i])}; L=E[[2]]/.{(Subscript[a, i])->-((Subscript[t, i])^(-1))(Subscript[a, i]),(Subscript[t, i])->((Subscript[t, i])^(-1)),(Subscript[c, i])->-(Subscript[c, i]),(Subscript[w, i])->-(Subscript[w, i])}; Q=E[[3]]/.{(Subscript[a, i])->-((Subscript[t, i])^(-1))(Subscript[a, i]),(Subscript[t, i])->((Subscript[t, i])^(-1)),(Subscript[c, i])->-(Subscript[c, i]),(Subscript[w, i])->-(Subscript[w, i])};

α = D[Q,(Subscript[w, i])]/.(Subscript[a, i ])->0;
β = D[Q,(Subscript[a, i])]/.(Subscript[w, i ])->0;
γ = D[L,(Subscript[c, i])]; (*includes b*)
δ = D[Q,(Subscript[a, i]),(Subscript[w, i])];
QRest=Q/.{(Subscript[a, i ])->0,(Subscript[w, i ])->0};
β=β Exp[γ];δ =δ Exp[γ]; (*first commute a and c in wca*)
μ  = 1-(1-(Subscript[t, i]))δ;
(*Print[α,β,γ,δ];*)
{μ C,L, QRest+(μ^(-1))((1-(Subscript[t, i]))α β  +Exp[γ]α (Subscript[w, i])+β (Subscript[a, i])+Exp[γ]δ (Subscript[a, i])(Subscript[w, i]) )}(*//Together*)
]

DoubleStrand[i_,j_,k_][E_]:=(*Just the q-coproduct*)E/.{(Subscript[a, i])->(Subscript[t, k])(Subscript[a, j])+(Subscript[a, k]),(Subscript[c, i])->(Subscript[c, j])+(Subscript[c, k]),(Subscript[w, i])->(Subscript[w, j])+(Subscript[w, k]),(Subscript[t, i])->(Subscript[t, j])(Subscript[t, k])}

Simplify[Log[a b]-Log[a]-Log[b],Assumptions->{a>0,b>0}]

(*Double positive crossing*)
Simplify[(DoubleStrand[1,x,y]@Rp[1,2]//Expand)-
(DisjUnion[{Rp[x,2],Rp[y,z]}]//m[2,z,2]),Assumptions->{(Subscript[t, x])>0}]
(DoubleStrand[2,x,y]@Rp[1,2]//Expand)-
(DisjUnion[{Rp[1,y],Rp[z,x]}]//m[1,z,1])

(*Reverse positive crossing*)
Simplify[ReverseStrand[1]@Rp[1,2]-
Rm[1,2],Assumptions->{(Subscript[t, 1])>0}]
ReverseStrand[2]@Rp[1,2]-
Rm[1,2]/.(Subscript[b, i_])->Log[(Subscript[t, i])]

(*Double negative Kink*)
Simplify[(DoubleStrand[1,2,3]@Km[1]//Expand)-
(DisjUnion@{Rm[2,8],Rm[4,9],Rm[3,6],Rm[5,7]}//m[2,4,2]//m[2,6,2]//m[2,8,2]//m[3,5,3]//m[3,7,3]//m[3,9,3])//Together,Assumptions->{(Subscript[t, 2])>0}]

Kp[1]
Km[1]

Rp[1,2]//m[1,2,1]

(*Reverse Kinks*)
Simplify[ReverseStrand[1]@Kp[1]-Kp[1],Assumptions->{(Subscript[t, 1])>0}]
Simplify[ReverseStrand[1]@Km[1]-Km[1],Assumptions->{(Subscript[t, 1])>0}]

Now let’s build a trefoil by strand doubling and then reversing the left hand strand, starting with this tangle:

(*It's just two negative curls crossing over in a positive crossing.*)
Start=DisjUnion@{Km[1],Km[2],Rp[x,y]}//m[1,x,1]//m[y,2,2]

Simplify[(DoubleStrand[2,-2,2]@DoubleStrand[1,-1,1]@Start//Expand//Together)-
((DisjUnion@{Rp[2,5],Rp[1,6],Rp[3,8],Rp[4,7],DoubleStrand[1,x,y]@Km[1],DoubleStrand[1,z,j]@Km[1]}//m[5,6,5]//m[7,8,7]//m[1,3,1]//m[2,4,2]//m[y,1,y]//m[x,2,x]//m[5,j,j]//m[7,z,z])/.{j->2,z->-2,y->1,x->-1}),Assumptions->{(Subscript[t, 1])>0,(Subscript[t, 2])>0}]

ReverseStrand[-2]@ReverseStrand[-1]@DoubleStrand[2,-2,2]@DoubleStrand[1,-1,1]@Start//m[1,-2,1]//m[1,-1,1]//m[1,2,1]

ReverseStrand[-2]@ReverseStrand[-1]@DoubleStrand[2,-2,2]@DoubleStrand[1,-1,1]@(DisjUnion@{Km[1],Km[2],Rp[x,y]}//m[1,x,1]//m[y,2,2])//m[1,-2,1]//m[1,-1,1]//m[1,2,1]
(*We could also do a negative crossing instead of a positive one and the result would still be the trefoil.*)
ReverseStrand[-2]@ReverseStrand[-1]@DoubleStrand[2,-2,2]@DoubleStrand[1,-1,1]@(DisjUnion@{Km[1],Km[2],Rm[x,y]}//m[1,y,1]//m[x,2,2])//m[1,-2,1]//m[1,-1,1]//m[1,2,1]