1-co middle c program.

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

Logos[α_,β_,δ_,μ_ ,a_,c_,w_,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,Log[(Subscript[t, i])] (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,-Log[(Subscript[t, i])] (Subscript[c, j]),-(((Subscript[t, i]) )^(-1))(Subscript[a, i])(Subscript[w, j]),-(Subscript[c, i ])(Subscript[c, j])+((Subscript[t, i])^(-1))(Subscript[a, i])(Subscript[c, j])(Subscript[w, j])-((((Subscript[t, i])^(-2))((Subscript[a, i])^2)((Subscript[w, j])^2))/4)}

(*Cuaps*)
nr[i_]:={((Subscript[t, i])^(1/2)),0,0,-(Subscript[c, i])((Subscript[t, i])^2)}
nl[i_]:={1,0,0,0}
ur[i_]:={((Subscript[t, i])^(-1/2)),0,0,(Subscript[c, i])((Subscript[t, i])^(-2))}
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}]]
(Subscript[DP, x_->(Subscript[D, α_]),y_->(Subscript[D, β_]),z_->(Subscript[D, γ_]),w_->(Subscript[D, δ_])])[P_][f_] := Total[CoefficientRules[P, {x,y,z,w}] /. ({m_,n_,o_,p_}->c_) :> c D[f,{α,m},{β,n},{γ,o},{δ,p}]]

(*Stitching operation*)
NOwa[i_,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-(Subscript[t, k]))α β +α (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*)
α =(C^(-1)) D[Q,(Subscript[w, i])]/.(Subscript[a, j ])->0;
β =(C^(-1)) D[Q,(Subscript[a, j])]/.(Subscript[w, i ])->0;
δ =(C^(-1)) D[Q,(Subscript[a, j]),(Subscript[w, i])];
QRest=Q/.{(Subscript[a, j ])->0,(Subscript[w, i ])->0};
μ  = 1-(1-(Subscript[t, k]))δ;

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

NOc[i_,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[a, j]) (Subscript[w, i])+(E^Γ)α (Subscript[w, i])+ (E^γ)β (Subscript[a, j])+Γ (Subscript[c, j])+γ (Subscript[c, i]);
P=(Subscript[DP, (Subscript[w, i])->(Subscript[D, α]),(Subscript[c, j])->(Subscript[D, Γ]),(Subscript[a, j])->(Subscript[D, β]),(Subscript[c, i])->(Subscript[D, γ])])[P][Exp[q]]Exp[-q]; (*First deal with P formally*)
(*Then set the variables*)
α =(C^(-1)) D[Q,(Subscript[w, i])]/.{(Subscript[a, j])->0};
β =(C^(-1)) D[Q,(Subscript[a, j])]/.{(Subscript[w, i])->0};
δ =(C^(-1)) D[Q,(Subscript[a, j]),(Subscript[w, i])];
γ = D[L,(Subscript[c, i])];
Γ= D[L,(Subscript[c, j])];
QRest=Q/.{(Subscript[a, j])->0,(Subscript[w, i ])->0};
Q=QRest+C (E^(Γ+γ))δ (Subscript[a, j]) (Subscript[w, i])+C (E^Γ)α (Subscript[w, i])+C (E^γ)β (Subscript[a, j]);


{C,L,Q,P}//Expand
]

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

ZZ={10+(Subscript[t, 1]),-2(Subscript[b, 2]) (Subscript[c, 1])+(Subscript[b, 1]) (Subscript[c, 2])+2(Subscript[b, 3]) (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]),3(Subscript[t, 2]) (Subscript[a, 1])(Subscript[w, 1])+(Subscript[a, 2])(Subscript[c, 3])+(Subscript[t, 1]) (Subscript[c, 1])+(Subscript[a, 2 ])(Subscript[c, 2])(Subscript[w, 2])};
ZZ//m[1,2,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 taking into account the scalings!*)
DisjUnion[L_]:={Times@@L[[All,1]],Plus@@L[[All,2]],(Times@@L[[All,1]])Plus @@(L[[All,3]]/L[[All,1]]),(((Times@@L[[All,1]]))^4)Plus @@(L[[All,4]]/((L[[All,1]])^4))}//Expand

(*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,a]//m[2,5,b]//m[4,6,c])-
(DisjUnion@{Rp[1,2],Rp[3,4],Rp[5,6]}//m[3,5,a]//m[1,6,b]//m[2,4,c])//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

(*rotated crossings*)
(DisjUnion@{ur[1],Rm[2,5],nr[3],ur[4],nr[6]}//m[1,2,1]//m[1,3,1]//m[4,5,4]//m[4,6,4])-(DisjUnion@{ul[1],Rm[2,5],nl[3],ul[4],nl[6]}//m[1,2,1]//m[1,3,1]//m[4,5,4]//m[4,6,4])

(*the oppositely oriented RII *)
DisjUnion[{Rm[1,2],Rp[3,4],ur[5],nr[6]}]//m[1,3,1]//m[4,5,4]//m[4,2,4]//m[4,6,4]

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

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

(*Inverse Kinks*)
DisjUnion@{Kp[1],Km[2]}//m[1,2,1]//Together

(*Powers of the positive kink, patterns?!*)
DisjUnion@{Kp[1]}//Together//Expand
DisjUnion@{Kp[1],Kp[2]}//m[1,2,1]//Together//Expand
DisjUnion@{Kp[1],Kp[2],Kp[3]}//m[1,2,1]//m[1,3,1]//Together//Expand
DisjUnion@{Kp[1],Kp[2],Kp[3],Kp[4]}//m[1,2,1]//m[1,3,1]//m[1,4,1]//Together//Expand
DisjUnion@{Kp[1],Kp[2],Kp[3],Kp[4],Kp[5]}//m[1,2,1]//m[1,3,1]//m[1,4,1]//m[1,5,1]//Together//Expand

(*3_1 0-Framed*)
Timing[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//Factor]

-(((((1-(Subscript[t, 1])+(Subscript[t, 1]^2)))^2) (-2 (Subscript[c, 1])+(Subscript[t, 1])+2 (Subscript[c, 1]) (Subscript[t, 1])-2 (Subscript[t, 1]^2)+3 (Subscript[t, 1]^3)-2 (Subscript[c, 1]) (Subscript[t, 1]^3)-2 (Subscript[t, 1]^4)+2 (Subscript[c, 1]) (Subscript[t, 1]^4)+2 (Subscript[a, 1]) (Subscript[w, 1])+2 (Subscript[a, 1]) (Subscript[t, 1]^3) (Subscript[w, 1])))/(Subscript[t, 1]^4))/.{(Subscript[c, _])->0,(Subscript[a, _])->0}//Expand//Exponent[#,(Subscript[t, 1])]&

(*4_1 0-Framed*)
Timing[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//Factor]

(((1+(Subscript[t, 1])) (((1-3 (Subscript[t, 1])+(Subscript[t, 1]^2)))^3) (1-2 (Subscript[c, 1])-(Subscript[t, 1])+2 (Subscript[c, 1]) (Subscript[t, 1])+2 (Subscript[a, 1]) (Subscript[w, 1])))/(Subscript[t, 1]^4))/.{(Subscript[c, _])->0,(Subscript[a, _])->0}//Expand

(*5_1 0-framed*)
Timing[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//Factor]

-(1/(Subscript[t, 1]^8))(((1-(Subscript[t, 1])+(Subscript[t, 1]^2)-(Subscript[t, 1]^3)+(Subscript[t, 1]^4)))^2) (-4 (Subscript[c, 1])+(Subscript[t, 1])+6 (Subscript[c, 1]) (Subscript[t, 1])-2 (Subscript[t, 1]^2)-6 (Subscript[c, 1]) (Subscript[t, 1]^2)+4 (Subscript[t, 1]^3)+4 (Subscript[c, 1]) (Subscript[t, 1]^3)-6 (Subscript[t, 1]^4)+8 (Subscript[t, 1]^5)-4 (Subscript[c, 1]) (Subscript[t, 1]^5)-8 (Subscript[t, 1]^6)+6 (Subscript[c, 1]) (Subscript[t, 1]^6)+7 (Subscript[t, 1]^7)-6 (Subscript[c, 1]) (Subscript[t, 1]^7)-4 (Subscript[t, 1]^8)+4 (Subscript[c, 1]) (Subscript[t, 1]^8)+4 (Subscript[a, 1]) (Subscript[w, 1])-2 (Subscript[a, 1]) (Subscript[t, 1]) (Subscript[w, 1])+4 (Subscript[a, 1]) (Subscript[t, 1]^2) (Subscript[w, 1])+4 (Subscript[a, 1]) (Subscript[t, 1]^5) (Subscript[w, 1])-2 (Subscript[a, 1]) (Subscript[t, 1]^6) (Subscript[w, 1])+4 (Subscript[a, 1]) (Subscript[t, 1]^7) (Subscript[w, 1]))/.{(Subscript[c, _])->0,(Subscript[a, _])->0}//Expand//Exponent[#,(Subscript[t, 1])]&

Strand doubling

DoubleStrand[i_,J_,K_][E_]:=(*Just the q-coproduct. But we need to reorder the c-contributions to the quadratic part in the exponent giving rise to some perturbations*)
Block[{C,P,Q,L,α,β,δ,j,k},

C=E[[1]]; (*The (inverse of the) constant in front, aka ω*)
L=E[[2]]; (*The linear term of the exponential*)
Q=E[[3]]; (*The quadratic term, scaled by C.*)
P=E[[4]]; (*Perturbation, scaled by (C^4)*)

α =(C^(-1)) D[Q,(Subscript[w, i])]/.{(Subscript[a, i])->0};
β =(C^(-1)) D[Q,(Subscript[a, i])]/.{(Subscript[w, i])->0};
δ =(C^(-1)) D[Q,(Subscript[a, i]),(Subscript[w, i])];

(*First add the necessary perturbations to P*)
P=P+
(C^4)(α (Subscript[c, k])(Subscript[w, j])+((α^2)/2) (Subscript[w, j])(Subscript[w, k])-β (Subscript[a, k])(Subscript[c, j])-((β^2)/2)(Subscript[t, k]) (Subscript[a, k])(Subscript[a, j])-δ  (Subscript[a, k])(Subscript[c, j])((Subscript[w, j])+(Subscript[w, k]))-((δ^2)/2)(Subscript[t, k]) (Subscript[a, k])(Subscript[a, j])((((Subscript[w, j])+(Subscript[w, k])))^2)+
δ ((Subscript[t, k])(Subscript[a, j])+(Subscript[a, k]))(Subscript[c, k])(Subscript[w, j])+((δ^2)/2)((((Subscript[t, k])(Subscript[a, j])+(Subscript[a, k])))^2)(Subscript[w, j])(Subscript[w, k]));
(*Finally apply the obvious part of the coproduct, without ϵ.*)
{C,L,Q,P}/.{(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]),(Subscript[a, j])->(Subscript[a, J]),(Subscript[a, k])->(Subscript[a, K]),(Subscript[c, j])->(Subscript[c, J]),(Subscript[c, k])->(Subscript[c, K]),(Subscript[w, j])->(Subscript[w, J]),(Subscript[w, k])->(Subscript[w, K]),(Subscript[t, j])->(Subscript[t, J]),(Subscript[t, k])->(Subscript[t, K])}
(*Careful with the case i=J=K!*)
]

(*Test by doubling the overstrand of a positive crossing*)
Simplify[DoubleStrand[1,4,5]@Rp[1,2]-
(DisjUnion[{Rp[4,2],Rp[5,x]}]//m[2,x,2])//Expand,Assumptions->{(Subscript[t, 4])>0}]
(*Test by doubling the understrand of a positive crossing*)
Simplify[DoubleStrand[2,4,5]@Rp[1,2]-
(DisjUnion[{Rp[1,5],Rp[x,4]}]//m[1,x,1])//Expand,Assumptions->{(Subscript[t, 4])>0}]
(*Test by doubling the overstrand of a negative crossing*)
Simplify[DoubleStrand[1,4,5]@Rm[1,2]-
(DisjUnion[{Rm[5,2],Rm[4,x]}]//m[2,x,2])//Expand,Assumptions->{(Subscript[t, 4])>0}]
(*Test by doubling the understrand of a negative crossing*)
Simplify[DoubleStrand[2,4,5]@Rm[1,2]-
(DisjUnion[{Rm[1,4],Rm[x,5]}]//m[1,x,1])//Expand,Assumptions->{(Subscript[t, 4])>0}]

DoubleStrand[1,4,5]@Rm[1,2]

(*Test by doubling a negative kink*)
(FullSimplify[(DisjUnion@{Rm[1,-3],Rm[2,3],Rm[-1,-4],Rm[-2,4],ur[-5],ur[5]}//m[1,2,1]//m[1,5,1]//m[1,3,1]//m[1,4,1]//m[-1,-2,-1]//m[-1,-5,-1]//m[-1,-3,-1]//m[-1,-4,-1]//Together)-DoubleStrand[1,-1,1]@Km[1],Assumptions->{(Subscript[t, 1])>0,(Subscript[t, -1])>0}]//Together)

(*Older Normal ordering operators*)
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-(Subscript[t, k]))α β +α (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*)
α =(C^(-1)) D[Q,(Subscript[w, i])]/.(Subscript[a, j ])->0;
β =(C^(-1)) D[Q,(Subscript[a, j])]/.(Subscript[w, i ])->0;
δ =(C^(-1)) D[Q,(Subscript[a, j]),(Subscript[w, i])];
QRest=Q/.{(Subscript[a, j ])->0,(Subscript[w, i ])->0};
μ  = 1-(1-(Subscript[t, k]))δ;

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

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*)
Q=Z[[3]]; (*The quadratic term.*)
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]//Expand; (*First deal with P formally*)
Print["Formal P=",P];
(*Then set the variables*)
α =(C^(-1)) D[Q,(Subscript[w, k])];
γ = D[L,(Subscript[c, j])];
Print[α,γ]; 

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

Q=QRest+C (E^γ)α (Subscript[w, k]);
{C,L,Q,P}//Expand
]

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*)
Q=Z[[3]]; (*The quadratic term.*)
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*)
β =(C^(-1)) D[Q,(Subscript[a, k])];
γ = D[L,(Subscript[c, i])];

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

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

(*Needs debugging!*)
ReverseStrand[i_][E_]:=(*Just the q-coproduct. But we need to reorder the c-contributions to the quadratic part in the exponent giving rise to some perturbations*)
Block[{C,P,Q,L,α,β,δ,x},
C=E[[1]]; (*The (inverse of the) constant in front, aka ω*)
L=E[[2]]; (*The linear term of the exponential*)
Q=E[[3]]; (*The quadratic term, scaled by C.*)
P=E[[4]]; (*Perturbation, scaled by (C^4)*)

α =(C^(-1)) D[Q,(Subscript[w, i])]/.{(Subscript[a, i])->0};
β =(C^(-1)) D[Q,(Subscript[a, i])]/.{(Subscript[w, i])->0};
δ =(C^(-1)) D[Q,(Subscript[a, i]),(Subscript[w, i])];

(*Now apply the 0-co antipode*)
C=C/.{(Subscript[a, i])->-((Subscript[t, i])^(-1))(Subscript[a, i]),(Subscript[c, i])->-(Subscript[c, i]),(Subscript[w, i])->-(Subscript[w, i]),(Subscript[t, i])->((Subscript[t, i])^(-1))};
L=L/.{(Subscript[a, i])->-((Subscript[t, i])^(-1))(Subscript[a, i]),(Subscript[c, i])->-(Subscript[c, i]),(Subscript[w, i])->-(Subscript[w, i]),(Subscript[t, i])->((Subscript[t, i])^(-1))};
Q=Q/.{(Subscript[a, i])->-((Subscript[t, i])^(-1))(Subscript[a, i]),(Subscript[c, i])->-(Subscript[c, i]),(Subscript[w, i])->-(Subscript[w, i]),(Subscript[t, i])->((Subscript[t, i])^(-1))};
P=P/.{(Subscript[a, i])->-((Subscript[t, i])^(-1))(Subscript[a, i]),(Subscript[c, i])->-(Subscript[c, i]),(Subscript[w, i])->-(Subscript[w, i]),(Subscript[t, i])->((Subscript[t, i])^(-1))};
Print["Q=",Q," P=",P];

(*Add the necessary perturbations to P coming from the 1-co S on Q.*)
P=P+
(C^4)(α (Subscript[w, i])(Subscript[c, i])+((α^2)/2) ((Subscript[w, i])^2)-β ((Subscript[t, i])^(-1))(Subscript[c, i])(Subscript[a, i])-((β^2)/2) ((Subscript[t, i])^(-2))((Subscript[a, i])^2));
Print["α = "α," P=",P];
(*Do the δ terms really cancel? things are in anti-canonical order now!*)

(*Finally reverse the order, using dummy variable k to avoid confusing the c's produced by NOwa.*)
Print[{C,L,Q,P}//NO[(Subscript[w, i]),(Subscript[c, i])]];
(({C,L,Q,P}//NO[(Subscript[w, i]),(Subscript[c, i])]//NO[(Subscript[w, i]),(Subscript[a, i]),x]//NO[(Subscript[c, i]),(Subscript[a, i])])/.{(Subscript[a, x])->(Subscript[a, i]),(Subscript[c, x])->(Subscript[c, i]),(Subscript[w, x])->(Subscript[w, i]),(Subscript[t, x])->(Subscript[t, i])})//Together
]

(*Testing Reversing overstrand of Rp gives negative crossing, i.e. (S tensor id)(Rp) = Rm*)
Simplify[ReverseStrand[1]@Rp[1,2]-Rm[1,2],Assumptions->(Subscript[t, 1])>0]

Rp[1,2]

(*Testing Reversing understrand of Rp gives negative crossing, when ur and nr are added (id tensor S)(Rp) != Rm*)
DisjUnion@{ReverseStrand[2]@Rp[1,2],ur[x],nr[y]}//m[y,2,2]//m[2,x,2]//Together
Rm[1,2]//Together

Stability

Suppose we start with Z = {C,L,Q,P} such that deg(Q),deg(P)< deg(C) where deg refers to the degree in t or perhaps s=1-t and deg of a rational function f/g is defined as deg(f/g) = deg f - deg g. We call such Z stable (of degree deg C). It looks like stitching preserves this property: Given Z stable of degree d and Z’ = (Subscript[(m^ab), c]) Z  then Z’ is again stable of degree d.

Below we test this idea on some generic examples. For this we only need the (Subscript[t, i])=t, one variable version of the stitching formula. We call it m1

(*Stitching operation*)
NOwa1[i_,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*)
α =(C^(-1)) D[Q,(Subscript[w, i])]/.(Subscript[a, j ])->0;
β =(C^(-1)) D[Q,(Subscript[a, j])]/.(Subscript[w, i ])->0;
δ =(C^(-1)) D[Q,(Subscript[a, j]),(Subscript[w, i])];
QRest=Q/.{(Subscript[a, j ])->0,(Subscript[w, i ])->0};
μ  = 1-(1-t)δ;

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

NOc1[i_,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[a, j]) (Subscript[w, i])+(E^Γ)α (Subscript[w, i])+ (E^γ)β (Subscript[a, j])+Γ (Subscript[c, j])+γ (Subscript[c, i]);
P=(Subscript[DP, (Subscript[w, i])->(Subscript[D, α]),(Subscript[c, j])->(Subscript[D, Γ]),(Subscript[a, j])->(Subscript[D, β]),(Subscript[c, i])->(Subscript[D, γ])])[P][Exp[q]]Exp[-q]; (*First deal with P formally*)
(*Then set the variables*)
α =(C^(-1)) D[Q,(Subscript[w, i])]/.{(Subscript[a, j])->0};
β =(C^(-1)) D[Q,(Subscript[a, j])]/.{(Subscript[w, i])->0};
δ =(C^(-1)) D[Q,(Subscript[a, j]),(Subscript[w, i])];
γ = D[L,(Subscript[c, i])];
Γ= D[L,(Subscript[c, j])];
QRest=Q/.{(Subscript[a, j])->0,(Subscript[w, i ])->0};
Q=QRest+C (E^(Γ+γ))δ (Subscript[a, j]) (Subscript[w, i])+C (E^Γ)α (Subscript[w, i])+C (E^γ)β (Subscript[a, j]);


{C,L,Q,P}//Expand
]

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

Z= {(t^4)+(t^3)+(t^2)+1,(Subscript[c, 3])Log[t]+(Subscript[c, 1])Log[t]+(Subscript[c, 2])Log[t],(Subscript[X, 11])(Subscript[a, 1])(Subscript[w, 1])+(Subscript[X, 12])(Subscript[a, 1])(Subscript[w, 2])+(Subscript[X, 21])(Subscript[a, 2])(Subscript[w, 1])+(Subscript[X, 22])(Subscript[a, 2])(Subscript[w, 2])+QOther , (Subscript[a, 1]) (t^2)+(Subscript[c, 2])(Subscript[w, 1])};Zp=Z//m1[1,2,1]//Together;
Zp[[3]]
Zp[[4]]/.{(Subscript[a, _])->0,(Subscript[c, _])->0}//(Exponent[Numerator[#],t]-Exponent[Denominator[#],t]&)