Double of the Sweedler Hopf algebra verification

The Sweedler Hopf algebra SW is a 4 dim Hopf algebra with generators s,w with relations (s^2)=1, (w^2)=0, sw+ws=0.
The Hopf structure is ϵ(s) = 1 ϵ(w)=0, Δ(s)=(Subscript[s, 1])(Subscript[s, 2]), Δ(w)=(Subscript[w, 1])(Subscript[s, 2])+(Subscript[w, 2]), S(s) = s, S(w) = sw.
Our preferred basis is 1,s,w, sw.
Its dual is isomorphic to SW and we take it to be generated by t,m subject to the same relations where t plays the role of s and m the role of w.
The dual pairing is given by the following matrix:
({{<>, 1, s, w, sw}, {1, 1, 1, 0, 0}, {t, 1, -1, 0, 0}, {m, 0, 0, 1, 1}, {tm, 0, 0, 1, -1}})
As the Drinfeld double we take (SW^( * cop))tensor SW with canonical basis the 16 monomials in order (t^i)(m^j)(s^k)(w^l) with i,j,k,l = 1 or 0. 
Hence, the R-matrix is given by (Subscript[R, i,j]) =(((1+(Subscript[t, i]))/2) -((1-(Subscript[t, i]))/2)(Subscript[s, j]))(1+(Subscript[m, i])(Subscript[w, j]))
Below we verify this is indeed a solution to Yang-Baxter and compute some knot invariants.

PBWRule={t->1,m->2,s->3,w->4};

B[U@s,U@w]=-(B[U@w,U@s]=-2U[s,w]);
B[U@t,U@m]=-(B[U@m,U@t]=-2U[t,m]);

B[U@s,U@t]=-(B[U@t,U@s]=0);
B[U@m,U@s]=-(B[U@s,U@m]=-2U[m,s]);
B[U@t,U@w]=-(B[U@w,U@t]=-2U[t,w]);
B[U@m,U@w]=-(B[U@w,U@m]=U[s]-U[t]);

UU[l___,((x_)^(n_)),r___]:= UU[l,Sequence@@Table[x,{n}],r];
UU[l___,1,r___]:= UU[l,r];
UU[]=U[]; UU[l_,r___]:=U[l]**UU[r];
(Subscript[U, i_])[ℰ_] := ℰ /. { u_U :> UU@@Replace[u, x_ :> (Subscript[x, i]),1]};

B[x_,x_]=0;
B[U[(Subscript[(x_), i_])],U[(Subscript[(y_), i_])]]:=(Subscript[U, i])[B[U@x,U@y]];
B[U[(Subscript[(x_), i_])],U[(Subscript[(y_), j_])]] /; i=!=j := 0;
B[x_,y_] := x**y-y**x;

x_⪯y_:=OrderedQ[{x,y}/.PBWRule]; x_≺y_:=!OrderedQ[{y,x}/.PBWRule]; (*ordering according to PBWRule*)
Simp[ℰ_]:= Collect[ℰ, _U,Together]/.{
U[a___,s,s,b___]->U[a,b],U[a___,w,w,b___]->0,
U[a___,(Subscript[s, i_]),(Subscript[s, i_]),b___]->U[a,b],U[a___,(Subscript[w, i_]),(Subscript[w, i_]),b___]->0,
U[a___,t,t,b___]->U[a,b],U[a___,m,m,b___]->0,
U[a___,(Subscript[t, i_]),(Subscript[t, i_]),b___]->U[a,b],U[a___,(Subscript[m, i_]),(Subscript[m, i_]),b___]->0};

Unprotect[NonCommutativeMultiply];
NonCommutativeMultiply[x_] := x;
0**_=_**0=0;
x_**U[]:=x; U[]**x_:=x;
U[1]=U[];
(a_*x_U)**(b_*y_U) := If[a b === 0, 0, Simp[a b (x**y)]];
(a_*x_U)**y_ := Simp[a(x**y)]; x_**(a_*y_U) := Simp[a(x**y)];
(x_Plus)**y_ := (#**y)& /@ x; x_**(y_Plus) := (x**#)& /@ y;
U[x_]**U[y_] := (*U[x]**U[y] =*) If[x≺y, U[x,y]//Simp, (U[y,x]+B[U@x,U@y])//Simp];
U[x_] ** U[y1_,yy__] := (*U[x] ** U[y1,yy] =*)If[x⪯y1,U[x,y1,yy]//Simp,((U@x**U@y1)**U@yy)//Simp];
U[xx__,xn_]**U[yy__] := (*U[xx,xn]**U[yy] =*) (U@xx**(U@xn**U@yy))//Simp;

σ[i_,j_][ℰ_] := ℰ /. {(Subscript[t, i])->(Subscript[t, j]),(Subscript[m, i])->(Subscript[m, j]),(Subscript[s, i])->(Subscript[s, j]),(Subscript[w, i])->(Subscript[w, j])};

mul[i_,j_][ℰ_] := Simp[ℰ /. x_U :> DeleteCases[x,(Subscript[_, j])]**U@@Cases[x,(Subscript[y_, j]):>(Subscript[y, i])] ];
(Subscript[m, i_,j_->k_])[ℰ_] := ℰ // mul[i,j] // σ[i,k];

R-matrix and its inverse

(Subscript[R, i_,j_]):=((1/2)U[]+(1/2)U[(Subscript[t, i])]+(1/2)U[(Subscript[s, j])]-(1/2)U[(Subscript[t, i]),(Subscript[s, j])])**(U[]+U[(Subscript[m, i]),(Subscript[w, j])])
(Subscript[(OverBar[R]), i_,j_]):=(1/2)U[]+(1/2)U[(Subscript[t, i])]+(1/2)U[(Subscript[s, j])]-(1/2)U[(Subscript[t, i]),(Subscript[s, j])]+((1/2)U[(Subscript[s, j])]+(1/2)U[(Subscript[t, i]),(Subscript[s, j])]-(1/2)U[]+(1/2)U[(Subscript[t, i])])**(U[(Subscript[m, i]),(Subscript[w, j])])

Check Reidemeister 3b

(Subscript[R, 1,2])**(Subscript[R, 1,3])**(Subscript[R, 2,3])-(Subscript[R, 2,3])**(Subscript[R, 1,3])**(Subscript[R, 1,2])

Check Reidemeister 2b

{(Subscript[R, 1,2])**(Subscript[(OverBar[R]), 1,2]),(Subscript[(OverBar[R]), 1,2])**(Subscript[R, 1,2])}

((Subscript[R, 1,2])**(Subscript[(OverBar[R]), 3,4]))//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2])

naive Reidemeister 2c fails because antipode has order 4.

((Subscript[R, 1,2])**(Subscript[(OverBar[R]), 3,4]))//(Subscript[m, 3,1->1])//(Subscript[m, 2,4->2])

Since (S^2) sends s,t to themselves and m and w to -m and -w we may explicitly write the four modified R-matrices R1,R2,(OverBar[R1])(OverBar[R2]) obtained by applying (S^(+-2)) on either side as follows. Note that in this case (S^(-2))=(S^2).

(Subscript[R1, i_,j_]):=((1/2)U[]+(1/2)U[(Subscript[t, i])]+(1/2)U[(Subscript[s, j])]-(1/2)U[(Subscript[t, i]),(Subscript[s, j])])**(U[]-U[(Subscript[m, i]),(Subscript[w, j])])
(Subscript[R2, i_,j_]):=((1/2)U[]+(1/2)U[(Subscript[t, i])]+(1/2)U[(Subscript[s, j])]-(1/2)U[(Subscript[t, i]),(Subscript[s, j])])**(U[]-U[(Subscript[m, i]),(Subscript[w, j])])
(Subscript[(OverBar[R1]), i_,j_]):=(1/2)U[]+(1/2)U[(Subscript[t, i])]+(1/2)U[(Subscript[s, j])]-(1/2)U[(Subscript[t, i]),(Subscript[s, j])]+((1/2)U[(Subscript[s, j])]+(1/2)U[(Subscript[t, i]),(Subscript[s, j])]-(1/2)U[]+(1/2)U[(Subscript[t, i])])**(-U[(Subscript[m, i]),(Subscript[w, j])])
(Subscript[(OverBar[R2]), i_,j_]):=(1/2)U[]+(1/2)U[(Subscript[t, i])]+(1/2)U[(Subscript[s, j])]-(1/2)U[(Subscript[t, i]),(Subscript[s, j])]+((1/2)U[(Subscript[s, j])]+(1/2)U[(Subscript[t, i]),(Subscript[s, j])]-(1/2)U[]+(1/2)U[(Subscript[t, i])])**(-U[(Subscript[m, i]),(Subscript[w, j])])

The point of these R-matrices is that stitching them with R,(OverBar[R]) we can produce any 0-framed 0-rotation number tangle without closed components. No Drinfeld element or ribbon element necessary.

Trefoil knot:

(((Subscript[(OverBar[R1]), 1,2])//(Subscript[m, 1,2->0]))**((Subscript[(OverBar[R1]), 1,2])//(Subscript[m, 2,1->0]))**((Subscript[(OverBar[R1]), 1,2])//(Subscript[m, 1,2->0])))**(((Subscript[R1, 1,4])**(Subscript[R1, 5,2])**(Subscript[R1, 3,6]))//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1])//(Subscript[m, 1,4->1])//(Subscript[m, 1,5->1])//(Subscript[m, 1,6->0]))

Figure eight knot:

((Subscript[(OverBar[R]), 6,1])**(Subscript[(OverBar[R2]), 2,5])**(Subscript[R1, 4,7])**(Subscript[R, 8,3]))//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1])//(Subscript[m, 1,4->1])//(Subscript[m, 1,5->1])//(Subscript[m, 1,6->1])//(Subscript[m, 1,7->1])//(Subscript[m, 1,8->1])

Implementing the Hopf algebra structure (under construction)

(Subscript[Δ, i_->j_,k_])[ℰ_] := Simp[ℰ/. {
z_.x_U :> z NonCommutativeMultiply@@(x /. {
(Subscript[s, i])->U[(Subscript[s, j]),(Subscript[s, k])],
(Subscript[w, i])-> U[(Subscript[w, j]),(Subscript[s, k])]+ U[(Subscript[w, k])],
(Subscript[t, i])->U[(Subscript[t, j]),(Subscript[t, k])],
(Subscript[m, i])-> U[(Subscript[m, k]),(Subscript[t, j])]+ U[(Subscript[m, j])],(*Opposite coproduct on the tm side because of double*)
 (Subscript[y_, l_]):>U@(Subscript[y, l])
})
}]

(Subscript[S, i_])[ℰ_] := Simp[ℰ /. {z_.x_U:>z (Subscript[S, i])[x]}];
(Subscript[S, i_])[U[]]=U[];
(Subscript[S, i_])[U[(Subscript[y_, j_]),more___]] /; i≠j := U[(Subscript[y, j])]**(Subscript[S, i])[U[more]];   (*Careful! if mathematica cannot decide i==j or not then we get an error*)
(Subscript[S, i_])[U[(Subscript[s, i_]),more___]] := (Subscript[S, i])[U[more]]**(U@(Subscript[s, i]));
(Subscript[S, i_])[U[(Subscript[w, i_]),more___]] := (Subscript[S, i])[U[more]]**(U[(Subscript[s, i]),(Subscript[w, i])]);
(Subscript[S, i_])[U[(Subscript[t, i_]),more___]] := (Subscript[S, i])[U[more]]**(U@(Subscript[t, i]));
(Subscript[S, i_])[U[(Subscript[m, i_]),more___]] := (Subscript[S, i])[U[more]]**(-U[(Subscript[t, i]),(Subscript[m, i])]); (*inverted antipode on the tm side because of double.*)

Sinv[i_][ℰ_] := Simp[ℰ /. {z_.x_U:>(z /. {(Subscript[c, i])->-(Subscript[c, i]),(Subscript[t, i])->((Subscript[t, i])^(-1))})Sinv[i][x]}];
Sinv[i_][U[]]=U[];
Sinv[i_][U[(Subscript[y_, j_]),more___]] /; i≠j := U[(Subscript[y, j])]**Sinv[i][U[more]];   (*Careful! if mathematica cannot decide i==j or not then we get an error*)
Sinv[i_][U[(Subscript[u, i_]),more___]] := Sinv[i][U[more]]**(-U@(Subscript[u, i]));
Sinv[i_][U[(Subscript[M, i_]),more___]] := Sinv[i][U[more]]**( (1+γ)S[i][U@(Subscript[M, i])]//Expand);Sinv[i_][U[(Subscript[w, i_]),more___]] := Sinv[i][U[more]]**( (1-γ)S[i][U@(Subscript[w, i])]//Expand);

CoUnit[i_][ℰ_] :=Simp[ℰ/. {z_.x_U:>(z/. {t->1,c->0,(Subscript[c, i])->0,(Subscript[t, i])->1})CoUnit[i][x]}] ;
CoUnit[i_][U[]]=U[];
CoUnit[i_][U[(Subscript[y_, j_]),more___]] /; i≠j := U[(Subscript[y, j])]**CoUnit[i][U[more]];
CoUnit[i_][U[(Subscript[y_, i_]),more___]] /;y≠a:=0;
CoUnit[i_][U[(Subscript[a, i_]),more___]]:= CoUnit[i][U[more]];

UExp[ℰ_,n_]:=Module[{t=U[],k}, U[]+Sum[((t=t**ℰ)/(k!)), {k,n}]]//Simp

ToDegree[n_][ℰ_] := (Simp[ℰ] /. {γ->ℏ γ, (Subscript[c, i_]):>ℏ (Subscript[c, i]), (Subscript[t, i_]):>(E^(ℏ (Subscript[c, i]))),c->ℏ c,  t:>(E^(ℏ c)),x_U:>(ℏ^(Count[x,w|(Subscript[w, _])]+Count[x,M|(Subscript[M, _])]))x} /. a_.x_U :>Normal[Series[a,{ℏ,0,n}]]*x)/.ℏ->1

Hopf algebra axioms

(*Sinv is the inverse of S *)
Sinv[1][S[1][U@(Subscript[M, 1])]]//Simp
Sinv[1][S[1][U@(Subscript[u, 1])]]//Simp
Sinv[1][S[1][U@(Subscript[w, 1])]]//Simp

(*Coassociativity only works properly with (Subscript[t, i]) instead of t!*)
(U@(Subscript[w, 1])//Δ[1,x,yy]//Δ[yy,y,z])-
(U@(Subscript[w, 1])//Δ[1,xx,z]//Δ[xx,x,y])
(U@(Subscript[u, 1])//Δ[1,x,yy]//Δ[yy,y,z])-
(U@(Subscript[u, 1])//Δ[1,xx,z]//Δ[xx,x,y])
(U@(Subscript[M, 1])//Δ[1,x,yy]//Δ[yy,y,z])-
(U@(Subscript[M, 1])//Δ[1,xx,z]//Δ[xx,x,y])

(*Convolution inverse*)
mul[2,3,1][S[2][Δ[1,2,3][U[(Subscript[w, 1])]]]]
mul[2,3,1][S[2][Δ[1,2,3][U[(Subscript[u, 1])]]]]
mul[2,3,1][S[2][Δ[1,2,3][U[(Subscript[M, 1])]]]]

mul[2,3,1][S[3][Δ[1,2,3][U[(Subscript[w, 1])]]]]
mul[2,3,1][S[3][Δ[1,2,3][U[(Subscript[u, 1])]]]]
mul[2,3,1][S[3][Δ[1,2,3][U[(Subscript[M, 1])]]]]

Testing Yang-Baxter

R[i_,j_,d_]:= Sum[((UU[((Subscript[w, i])^a)]**UU[((Subscript[u, i])^b)]**(((Subscript[c, j])^b)U[]+γ b ((Subscript[c, j])^(b-1))U[(Subscript[u, j])])**(U[]+γ a U[(Subscript[u, j])])**UU[((Subscript[M, j])^a)])/(a!b!))(1+γ(1/4)(a-1)a),{b,0,d},{a,0,d-b}]//ToDegree[d]

R3[d_] := (ToDegree[d][R[1,2,d]**R[1,3,d]]**R[2,3,d])-(ToDegree[d][R[2,3,d]**R[1,3,d]]**R[1,2,d])

(R3[2] // ToDegree[2])

Timing[R3[3] // ToDegree[2]]

Timing[R3[4] // ToDegree[3]]

Timing[R3[5] // ToDegree[4]]

Timing[R3[6] // ToDegree[4]]

Timing[R3[7] // ToDegree[5]]

(*Verifying the inverse is given by (S tensor id)(R)*)
(S[1][R[1,2,7]]**R[1,2,7]-U[])//ToDegree[4]
(*Verifying the inverse is given by (id tensor S^{-1})(R)  *)

(Sinv[2][R[1,2,7]]**R[1,2,7]-U[])//ToDegree[4]

Rinv[i_,j_,d_]:=S[i][R[i,j,d]]//Expand

Swaub[a_,b_,i_]:=S[i][(UU[((Subscript[w, i])^a)]**UU[((Subscript[u, i])^b)])]//Simp

Swaub[2,1,i]

S[i][UU[((Subscript[w, i])^2)]]//Simp

Rinv0[i_,j_,d_]:= Sum[((Swaub[a,b,i]**(((Subscript[c, j])^b)U[]+γ b ((Subscript[c, j])^(b-1))U[(Subscript[u, j])])**(U[]+γ a U[(Subscript[u, j])])**UU[((Subscript[M, j])^a)])/(a!b!))(1+γ(1/4)(a-1)a),{b,0,d},{a,0,d-b}]//ToDegree[d]

(Rinv[1,2,11]-Rinv0[1,2,11])//Simp//ToDegree[6]

TestSw[a_,b_]:=-Swaub[a,b,i]+(((-1))^(a+b))(1-a(a-1)(γ/2) )UU[((Subscript[w, i])^a)]**(U[]-a γ U[(Subscript[u, i])])**(Sum[Binomial[b,k]UU[((Subscript[u, i])^k)](a^(b-k)),{k,0,b}]//Simp)//Simp

TestSw[5,4]

Rinv01[i_,j_,d_]:= Sum[(1/(a!b!))((((-1))^(a+b))(1-a(a-1)(γ/2) )UU[((Subscript[w, i])^a)]**(U[]-a γ U[(Subscript[u, i])])**(Sum[Binomial[b,k]UU[((Subscript[u, i])^k)]If[a==0&&b-k==0,1,(a^(b-k))],{k,0,b}]//Simp)//Simp)**(((Subscript[c, j])^b)U[]+γ b ((Subscript[c, j])^(b-1))U[(Subscript[u, j])])**(U[]+γ a U[(Subscript[u, j])])**UU[((Subscript[M, j])^a)](1+γ(1/4)(a-1)a),{b,0,d},{a,0,d-b}]//ToDegree[d]

(Rinv[1,2,8]-Rinv01[1,2,8])//Simp//ToDegree[4]

Rinv02[i_,j_,d_]:= Sum[((((-1))^(a+b))/(a!b!))(UU[((Subscript[w, i])^a)]**(U[]-a γ U[(Subscript[u, i])])**(Sum[Binomial[b,k]UU[((Subscript[u, i])^k)]If[a==0&&b-k==0,1,(a^(b-k))],{k,0,b}]//Simp)//Simp)**(((Subscript[c, j])^b)U[]+γ b ((Subscript[c, j])^(b-1))U[(Subscript[u, j])])**(U[]+γ a U[(Subscript[u, j])])**UU[((Subscript[M, j])^a)](1-γ(1/4)(a-1)a),{b,0,d},{a,0,d-b}]//ToDegree[d]

(Rinv[1,2,8]-Rinv02[1,2,8])//Simp//ToDegree[4]

Rinv03[i_,j_,d_]:= Sum[(((((-1))^(a+b)) ((Subscript[t, j])^(-a)) ((Subscript[c, j])^b))/(a!b!))UU[((Subscript[w, i])^a)]**(U[]-a γ U[(Subscript[u, i])])**UU[((Subscript[u, i])^b)]**(U[]-γ UU[(Subscript[u, j]),(Subscript[u, i])]-γ a U[(Subscript[u, j])])**(U[]+γ a U[(Subscript[u, j])])**UU[((Subscript[M, j])^a)](1-γ(1/4)(a-1)a),{b,0,d},{a,0,d-b}]//ToDegree[d]

(Rinv[1,2,8]-Rinv03[1,2,8])//Simp//ToDegree[4]

Rinv04[i_,j_,d_]:= Sum[(((((-1))^(a+b)) ((Subscript[t, j])^(-a)) ((Subscript[c, j])^b))/(a!b!))UU[((Subscript[w, i])^a)]**(U[]-a γ U[(Subscript[u, i])])**UU[((Subscript[u, i])^b)]**(U[]-γ UU[(Subscript[u, j]),(Subscript[u, i])])**UU[((Subscript[M, j])^a)](1-γ(1/4)(a-1)a),{b,0,d},{a,0,d-b}]//ToDegree[d]

(Rinv[1,2,8]-Rinv04[1,2,8])//Simp//ToDegree[4]

Quasi triangularity axioms

(*Check the three quasi-triangularity axioms*)

(Δ[i,k,l][R[i,j,5]]-R[k,j,5]**R[l,j,5])//ToDegree[5]

(Δ[j,k,l][R[i,j,8]]-R[i,l,8]**R[i,k,8])//ToDegree[5]

CheckRDR[x_,d_]:=(R[2,3,d+4]**Δ[1,2,3][x]**Rinv[2,3,d+4]-σ[2,3][Δ[1,2,3][x]])//ToDegree[d]

CheckRDR[U@(Subscript[u, i]),5]
CheckRDR[U@(Subscript[w, i]),5]
CheckRDR[U@(Subscript[M, i]),5]

Drinfeld element

(*Drinfeld element*)
Dr[d_]:= R[1,2,d]//S[2]//mul[2,1,1]

(*Check that S(Dr) and Dr commute*)
S[1][Dr[4]]**Dr[4]-S[1][Dr[4]]**Dr[4]

S[1][Dr[2]]//ToDegree[2]

(*S(Dr) = (t^(-1 ))(e^(-2ϵc)) Dr *)
S[1][Dr[6]]-(U[]-2γ U[(Subscript[u, 1])])**(Dr[6]((Subscript[t, 1])^(-1))//ToDegree[6])//ToDegree[3]

(U[]-γ U[(Subscript[u, 1])])**Dr[4]-Dr[4]**(U[]-γ U[(Subscript[u, 1])])//ToDegree[4]

Therefore the Ribbon element v is implied by (v^2) = S(Dr)Dr = (t^(-1)) (e^(-2 γ u)) (Dr^2) so choose v =(t^(-1/2))(e^(-γ u)) Dr , note Dr commutes with (e^(-γu)).
According to Ohtsuki p.72 read upside down, we should set the left-moving cup and cap to 1 and the right-moving cap nr should be v (Dr^(-1))=(t^(-1/2))(e^(-γ u)) and 
the right-moving cup ur should be Dr (v^(-1))=(t^(1/2))(e^(γ u)).

(*Square of antipode*)
S[1]@S[1]@U@(Subscript[u, 1])
S[1]@S[1]@U@(Subscript[w, 1])
S[1]@S[1]@U@(Subscript[M, 1])

(U[]+γ U[u])**U[u]**(U[]-γ U[u])//Simp
(U[]+γ U[u])**U[w]**(U[]-γ U[u])//Simp
(U[]+γ U[u])**U[M]**(U[]-γ U[u])//Simp

Logos

B[U@M,U@w]

η=((t+1)/(t-1))γ;
q = 1+η;
qI[k_]:=k(1+η(k-1)/2)//Expand
qFac[n_]:=n!(1+η (n-1)n/4)//Expand
InvqFac[n_]:=(1-η (n-1)n/4)/n!//Expand
qBin[n_,k_]:= Binomial[n,k](1+η k (n-k) /2)//Expand

(*Checking the commutation relation for powers of a,w*)
WmAn[m_,n_]:=Sum[(((1-t))^j)qBin[m,j]qBin[n,j]qFac[j]UU[(w^(n-j))]**(U[]+j η U[u])**UU[(M^(m-j))],{j,0,Min[m,n]}]
TestWmAn[m_,n_]:=-UU[(M^m),(w^n)]+WmAn[m,n]
TestWmAn[5,3]//Together

Mawb[a_,b_]:=Sum[((a! b!)/((a-j)!(b-j)!j!))(((1-t))^j)UU[(w^(b-j))]**((U[]-(((1+t))/(1-t))γ ((((a+b-2)/2)U[]+U[u])j-(3/4)j(j-1)U[]))//Simp)**UU[(M^(a-j))],{j,0,Min[a,b]}]

TestMawb[a_,b_]:=-UU[(M^a),(w^b)]+Mawb[a,b]//Simp

TestMawb[7,10]

TestLemma20[d_]:=-Sum[Mawb[k,k]((δ^k)/(k!)),{k,0,d}]+ 
Sum[
Sum[(((δ^(k-j))k!)/((k-j)!(k-j)!j!))(δ^j)(((1-t))^j)UU[(w^(k-j))]**((U[]-(((1+t))/(1-t))γ (((k-1)U[]+U[u])j-(3/4)j(j-1)U[]))//Simp)**UU[(M^(k-j))],{j,0,k}]
,{k,0,d}]

TestLemma20[4]//ToDegree[3]

TestLemma21[d_]:=-Sum[Mawb[k,k]((δ^k)/(k!)),{k,0,d}]+ 
Sum[
Sum[(((δ^l)(l+j)!)/(l!l!j!))(δ^j)(((1-t))^j)UU[(w^l)]**((U[]-(((1+t))/(1-t))γ ((l U[]+U[u])j+(1/4)j(j-1)U[]))//Simp)**UU[(M^l)],{j,0,d}]
,{l,0,d}]

TestLemma21[6]//ToDegree[6]

TestLemma22[d_]:=-Sum[Mawb[k,k]((δ^k)/(k!)),{k,0,d}]+ 
Sum[((δ^l)/(l!))UU[(w^l)]**(((((1-δ(1-t)))^(-l-1))U[]
-(((1+t))/(1-t))γ (δ(1-t)(((1-δ(1-t)))^(-l-2))(l+1)(l U[]+U[u])
+(δ^2)(((1-t))^2)(((1-δ(1-t)))^(-l-3))(l+1)(l+2)(1/4)U[]))//Simp)**UU[(M^l)]
,{l,0,d}]

TestLemma22[7]//ToDegree[6]

TestLemma23[d_]:=Module[{ν},
ν=(((1-δ(1-t)))^(-1));
-Sum[Mawb[k,k]((δ^k)/(k!)),{k,0,d}]+ 
ν Sum[((((δ ν))^l)/(l!))UU[(w^l)]**(( U[]
-(((1+t))/(1-t))γ (δ(1-t)ν(l+1)(l U[]+U[u])
+(δ^2)(((1-t))^2)(ν^2)(l+1)(l+2)(1/4)U[]))//Simp)**UU[(M^l)]
,{l,0,d}]
]
TestLemma23[7]//ToDegree[6]

TestLemma24[d_]:=Module[{ν},
ν=(((1-δ(1-t)))^(-1));
-Sum[Mawb[k,k]((δ^k)/(k!)),{k,0,d}]+ 
ν Sum[((((δ ν))^l)/(l!))UU[(w^l)]**(( U[]
-(1+t)δ ν γ (δ(1-t)ν U[](1/2)+
l(2+δ(1-t)ν) U[]+
(l-1)l(1+(1/4)δ(1-t)ν) U[]
+(l+1) U[u]))//Simp)**UU[(M^l)]
,{l,0,d}]
]
TestLemma24[7]//ToDegree[6]

(*Guess qLogos first at q=1*)
ToDegh[F_,x_]:=Series[F/.{α->α h,δ->δ h,β->β h},{h,0,x}]
d=8;
LHS=Sum[(α^m)(δ^k)(β^n)InvqFac[m]InvqFac[k]InvqFac[n]WmAn[m+k,n+k],{m,0,d},{k,0,d-m},{n,0,d-m-k}]//Simp;
(*powers of nu as power series*)
nuA[z_]:=Sum[Binomial[z-1+x,x](((1-t))^x)(δ^x),{x,0,d}];
RHS = Sum[(((1-t))^j)nuA[m+k+n+j+1](α^(m+j))(δ^k)(β^(n+j))InvqFac[m]InvqFac[k]InvqFac[n]InvqFac[j]UU[(a^(n+k)),(w^(m+k))],{m,0,d},{k,0,d-m},{n,0,d-m-k},{j,0,d-m-n-k}]//Simp; 
ToDegh[(LHS-RHS)/.{ϵ->0}//Simp,8]

(*Now set up the LHS and RHS to find the Logos relating them.*)
d=11;
LHS=Sum[(α^m)(δ^k)(β^n)((WmAn[m+k,n+k])/(m!k!n!)),{m,0,d},{k,0,d-m},{n,0,d-m-k}]//Simp;
RHS =Sum[(((1-t))^j)(μ^(-(m+k+n+j+1)))(((α^(m+j))(δ^k)(β^(n+j)))/(m!k!n!j!))UU[(a^(n+k)),(w^(m+k))],{m,0,d},{k,0,d-m},{n,0,d-m-k},{j,0,d-m-n-k}];
CRHS = Sum[(((1-t))^j)(μ^(-(m+k+n+j+1)))(((α^(m+j))(δ^k)(β^(n+j)))/(m!n!k!j!))UU[(a^(n+k)),c,(w^(m+k))],{m,0,d},{k,0,d-m},{n,0,d-m-k},{j,0,d-m-n-k}]//Simp; 
μ = 1-(1-t)δ;

η

(*Here we guess and verify the Logos coefficient by coefficient*)
ToDegh[Coefficient[(-LHS+RHS+
(μ^(-4 ))(1-t)η (
(1-t)((1/2) (δ^2)(μ^2) + α β δ μ+(((α^2)(β^2))/4))RHS+
(μ^2)(δ μ+α β)CRHS+
β( δ μ+((α β )/2))  U[a]**RHS+
α( δ μ+((α β )/2) ) RHS**U[w]+
β δ (μ^2)   U[a]**CRHS+
α δ (μ^2)   CRHS**U[w]+
δ(1+μ)(μ δ+α β )U[a]**RHS**U[w]+
 (δ^2) (μ^2) U[a]**CRHS**U[w]+
(((β^2)δ)/4)(1+μ ) U[a,a]**RHS+
(((α^2)δ)/4)(1+μ )RHS**U[w,w]+
((β  (δ^2))/2) (1+2μ) U[a,a]**RHS**U[w]+
(( α  (δ^2))/2)(1+2μ) U[a]**RHS**U[w,w]+
 ((δ^3)/4)(1+3μ )U[a,a]**RHS**U[w,w])
),U[]],10]

(*Final check, put back ϵ.*)
ToDegh[(-LHS+RHS+
-(μ^(-4 ))(1+t)ϵ (
(1-t)((1/2) (δ^2)(μ^2) + α β δ μ+(((α^2)(β^2))/4))RHS+
(μ^2)(δ μ+α β)CRHS+
β( δ μ+((α β )/2))  U[a]**RHS+
α( δ μ+((α β )/2) ) RHS**U[w]+
β δ (μ^2)   U[a]**CRHS+
α δ (μ^2)   CRHS**U[w]+
δ(1+μ)(μ δ+α β )U[a]**RHS**U[w]+
 (δ^2) (μ^2) U[a]**CRHS**U[w]+
(((β^2)δ)/4)(1+μ ) U[a,a]**RHS+
(((α^2)δ)/4)(1+μ )RHS**U[w,w]+
((β  (δ^2))/2) (1+2μ) U[a,a]**RHS**U[w]+
(( α  (δ^2))/2)(1+2μ) U[a]**RHS**U[w,w]+
 ((δ^3)/4)(1+3μ )U[a,a]**RHS**U[w,w])
),10]//Simp

Double Reverse

Δ[1,2,3][U@(Subscript[c, 1])]//Simp
Δ[1,2,3][U@(Subscript[w, 1])]//Simp
Δ[1,2,3][U@(Subscript[a, 1])]//Simp

((Δ[1,2,3][U@(Subscript[w, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[w, 1])]//Simp)-(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])-ϵ U[(Subscript[w, 2]),(Subscript[w, 3])]-2ϵ U[(Subscript[c, 3]),(Subscript[w, 2]),(Subscript[w, 3])]-2ϵ U[(Subscript[c, 3]),(Subscript[w, 2]),(Subscript[w, 2])])//Simp

((Δ[1,2,3][U@(Subscript[a, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[a, 1])]//Simp)-((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])+ϵ (Subscript[t, 3]) U[(Subscript[a, 2]),(Subscript[a, 3])]+2ϵ (Subscript[t, 3]) U[(Subscript[a, 2]),(Subscript[a, 3]),(Subscript[c, 2])]+2ϵ U[(Subscript[a, 3]),(Subscript[a, 3]),(Subscript[c, 2])])//Simp

((Δ[1,2,3][U@(Subscript[a, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[a, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[a, 1])]//Simp)-((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])+3ϵ (Subscript[t, 3])( (Subscript[t, 3]) U[(Subscript[a, 2])]+U[(Subscript[a, 3])])** U[(Subscript[a, 2]),(Subscript[a, 3])]+3ϵ ( (Subscript[t, 3]) U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**( (Subscript[t, 3]) U[(Subscript[a, 2])]+U[(Subscript[a, 3])])** U[(Subscript[a, 3]),(Subscript[c, 2])])//Simp

((Δ[1,2,3][U@(Subscript[a, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[a, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[a, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[a, 1])]//Simp)-((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])+6 ϵ (Subscript[t, 3])( (Subscript[t, 3]) U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**( (Subscript[t, 3]) U[(Subscript[a, 2])]+U[(Subscript[a, 3])])** U[(Subscript[a, 2]),(Subscript[a, 3])]+4ϵ ( (Subscript[t, 3]) U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**( (Subscript[t, 3]) U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**( (Subscript[t, 3]) U[(Subscript[a, 2])]+U[(Subscript[a, 3])])** U[(Subscript[a, 3]),(Subscript[c, 2])])//Simp

(((Δ[1,2,3][U@(Subscript[a, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[a, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[a, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[a, 1])]//Simp))//Simp)**(((Δ[1,2,3][U@(Subscript[w, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[w, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[w, 1])]//Simp)**(Δ[1,2,3][U@(Subscript[w, 1])]//Simp))//Simp)-
(
((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])
+ϵ ((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**(4 U[(Subscript[c, 3]),(Subscript[w, 2])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])
+ϵ ((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**(6 U[(Subscript[w, 2]),(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])
-ϵ ((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**(4 U[(Subscript[a, 3]),(Subscript[c, 2])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])
-ϵ ((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**((Subscript[t, 3])U[(Subscript[a, 2])]+U[(Subscript[a, 3])])**(6 (Subscript[t, 3 ])U[(Subscript[a, 2]),(Subscript[a, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])**(U[(Subscript[w, 2])]+U[(Subscript[w, 3])])

)//Expand//Simp

UU[c,a]

S[1]@U@(Subscript[w, 1])-(-U[(Subscript[w, 1])]+ϵ UU[(Subscript[w, 1]),(Subscript[c, 1])])//Simp
S[1]@U@(Subscript[c, 1])//Simp
S[1]@U@(Subscript[a, 1])-(-((Subscript[t, 1])^(-1))(U[(Subscript[a, 1])]+ϵ UU[(Subscript[c, 1]),(Subscript[a, 1])]))//Expand//Simp

Δ[1,2,3][U@(Subscript[c, 1])]//S[2]
Δ[1,2,3][U@(Subscript[w, 1])]//S[2]//Simp
((Δ[1,2,3][U@(Subscript[a, 1])]//S[2]//Simp)/.(Subscript[t, _])->t)//Simp

U[w]**((U[c]+U[])**U[w])//Simp

(S[1]@U[(Subscript[w, 1])])//Simp
(S[1]@U[(Subscript[w, 1])])**(S[1]@U[(Subscript[w, 1])])//Simp
(S[1]@U[(Subscript[w, 1])])**(S[1]@U[(Subscript[w, 1])])**(S[1]@U[(Subscript[w, 1])])//Simp
(S[1]@U[(Subscript[w, 1])])**(S[1]@U[(Subscript[w, 1])])**(S[1]@U[(Subscript[w, 1])])**(S[1]@U[(Subscript[w, 1])])//Simp

(S[1]@U[(Subscript[a, 1])])//Simp
(S[1]@U[(Subscript[a, 1])])**(S[1]@U[(Subscript[a, 1])])//Simp
(S[1]@U[(Subscript[a, 1])])**(S[1]@U[(Subscript[a, 1])])**(S[1]@U[(Subscript[a, 1])])//Simp
(S[1]@U[(Subscript[a, 1])])**(S[1]@U[(Subscript[a, 1])])**(S[1]@U[(Subscript[a, 1])])**(S[1]@U[(Subscript[a, 1])])//Simp

(U[c]-4U[])**UU[(a^4)]-UU[(a^4),c]