1-co middle c program.

The format is E = {Const,Linear,Quad,Pert} which means O(Const (e^(Linear+Quad))(1+ϵ Pert)) no tricky scalings.
This is a stand alone notebook but, all formulas were checked in NewVdVAlgebraAt15.nb

(*Can be simplified a bit more*)
Logos[α_,β_,δ_,μ_ ,a_,c_,w_]:=
-(1/(4(μ^4)))(1+t)(4a c w (δ^2) (μ^2)+δ (1+μ)((w^2) (α^2)+ (a^2) (β^2) )+
 (a^2) (w^2) (δ^3) (1+3 μ)+(1-t)(2(((α β+δ μ))^2)-(α^2) (β^2))+
2(α β+2δ μ+ a w (δ^2) (1+2 μ)+2c  δ (μ^2))(w α +a β )+
 4(c (μ^2)+a w δ (1+μ) )(α β+δ μ)  )

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

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

(Subscript[DP, x_->(Subscript[D, α_]),y_->(Subscript[D, β_])])[P_][f_] := Total[CoefficientRules[P, {x,y}] /. ({m_,n_}->c_) :> c D[f,{α,m},{β,n}]]

(*Stitching operation*)
NO[(Subscript[w, i_]),(Subscript[a, j_]),k_][Z_]:=Block[
{α,β,δ,C,L,Q,P,QRest,μ,q },
C=Z[[1]]; (*The (inverse of the) constant in front, aka ω*)
L=Z[[2]]; (*The linear term of the exponential, unscaled*)
Q=Z[[3]]; (*The quadratic term, unscaled.*)
P=Z[[4]]; 
q= (μ^(-1))((1-t)α β +α (Subscript[w, i])+β (Subscript[a, j])+δ (Subscript[a, j])(Subscript[w, i]));
P=(Subscript[DP, (Subscript[w, i])->(Subscript[D, α]),(Subscript[a, j])->(Subscript[D, β])])[P][Exp[q]]Exp[-q]; (*First deal with P formally*)
(*Then set the variables*)
α = D[Q,(Subscript[w, i])]/.(Subscript[a, j ])->0;
β = D[Q,(Subscript[a, j])]/.(Subscript[w, i ])->0;
δ = D[Q,(Subscript[a, j]),(Subscript[w, i])];
QRest=Q/.{(Subscript[a, j ])->0,(Subscript[w, i ])->0};
μ  = 1-(1-t)δ;

C=μ C;
Q=QRest+(μ^(-1))((1-t)α β +α (Subscript[w, i])+β (Subscript[a, j])+δ (Subscript[a, j])(Subscript[w, i]));
P=P+Logos[α,β,δ,μ ,(Subscript[a, j]),(Subscript[c, k]),(Subscript[w, i])];
{C,L,Q,P}/.{b->Log[t]}
]

NO[(Subscript[w, k_]),(Subscript[c, j_])][Z_]:=Block[
{α,γ,C,L,Q,P,QRest,q },
C=Z[[1]]; (*The (inverse of the) constant in front, aka ω*)
L=Z[[2]]; (*The linear term of the exponential, unscaled*)
Q=Z[[3]]; (*The quadratic term, unscaled.*)
P=Z[[4]]; 
q=(E^γ)α (Subscript[w, k])+γ (Subscript[c, j]);
P=(Subscript[DP, (Subscript[w, k])->(Subscript[D, α]),(Subscript[c, j])->(Subscript[D, γ])])[P][Exp[q]]Exp[-q]; (*First deal with P formally*)
(*Then set the variables*)
α = D[Q,(Subscript[w, k])];
γ = D[L,(Subscript[c, j])];
QRest=Q/.{(Subscript[w, k ])->0};

Q=QRest+(E^γ)α (Subscript[w, k]);
{C,L,Q,P}/.{b->Log[t]}
]

NO[(Subscript[c, i_]),(Subscript[a, k_])][Z_]:=Block[
{β,γ,C,L,Q,P,QRest,q },
C=Z[[1]]; (*The (inverse of the) constant in front, aka ω*)
L=Z[[2]]; (*The linear term of the exponential, unscaled*)
Q=Z[[3]]; (*The quadratic term, unscaled.*)
P=Z[[4]]; 
q=(E^γ)β (Subscript[a, k])+γ (Subscript[c, i]);
P=(Subscript[DP, (Subscript[a, k])->(Subscript[D, β]),(Subscript[c, i])->(Subscript[D, γ])])[P][Exp[q]]Exp[-q]; (*First deal with P formally*)
(*Then set the variables*)
β = D[Q,(Subscript[a, k])];
γ = D[L,(Subscript[c, i])];

QRest=Q/.{(Subscript[a, k ])->0};

Q=Q/.{(Subscript[a, k])->(E^γ) (Subscript[a, k])};
(*Q=QRest+(E^γ)β (Subscript[a, k]);*)
{C,L,Q,P}/.{b->Log[t]}
]

m[i_,j_,k_][Z_]:=Block[{x},(Z//NO[(Subscript[w, i]),(Subscript[a, j]),x]//NO[(Subscript[c, i]),(Subscript[a, j])]//NO[(Subscript[w, i]),(Subscript[c, j])])/.{(Subscript[a, i|j])->(Subscript[a, k]),(Subscript[c, i|j|x])->(Subscript[c, k]),(Subscript[w, i|j])->(Subscript[w, k])}//Together]

ZZ={10+t,-2b (Subscript[c, 1])+b (Subscript[c, 2])+3b (Subscript[c, 3]),(Subscript[a, 2])(Subscript[w, 2])+(Subscript[a, 3])(Subscript[w, 2])+(Subscript[a, 2])(Subscript[w, 1])+(Subscript[a, 1])(Subscript[w, 1])+(Subscript[a, 3])(Subscript[w, 1])+(Subscript[a, 1])(Subscript[w, 2]),3t (Subscript[a, 1])(Subscript[w, 1])+(Subscript[a, 2])(Subscript[c, 3])+t (Subscript[c, 1])};

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

(*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]],Plus @@L[[All,4]]}

(*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])//Expand
(DisjUnion@{Rm[1,2],Rm[3,4],Rm[5,6]}//m[1,3,x]//m[2,5,y]//m[4,6,z])-
(DisjUnion@{Rm[1,2],Rm[3,4],Rm[5,6]}//m[3,5,x]//m[1,6,y]//m[2,4,z])//Expand

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

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

(*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//Together

(*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//Together

(*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//Together