Pensieve header: The R-matrix cR for the classical algebra, plus x and y scattering for cR.

Startup

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\FullDoPeGDO"];
Once["<< KnotTheory`"];
<<"../Profile/Profile.m";
<<"Engine.m";
<<"Objects.m";
<<"KT.m";
$k=0; γ=1;
HL[ℰ_] := Style[ℰ, Background -> If[TrueQ@ℰ,,]];

Timing@HL[((Subscript[R, 1,2])(Subscript[R, 6,3])(Subscript[R, 4,5])//(Subscript[dm, 1,6->1])(Subscript[dm, 2,4->2])(Subscript[dm, 3,5->3]) )≡((Subscript[R, 2,3])(Subscript[R, 1,4])(Subscript[R, 5,6])//(Subscript[dm, 1,5->1])(Subscript[dm, 2,6->2])(Subscript[dm, 3,4->3]))]

Timing@HL[((Subscript[R, 1,2])(Subscript[R, 6,3])(Subscript[R, 4,5])//(Subscript[cm, 1,6->1])(Subscript[cm, 2,4->2])(Subscript[cm, 3,5->3]) )≡((Subscript[R, 2,3])(Subscript[R, 1,4])(Subscript[R, 5,6])//(Subscript[cm, 1,5->1])(Subscript[cm, 2,6->2])(Subscript[cm, 3,4->3]))]

(Subscript[R, i,j])

(Subscript[cR, i_,j_]):=(Subscript[𝔼, {}->{i,j}])[ℏ (Subscript[a, j]) (Subscript[b, i])+ (((Subscript[B, i])-1)/(-(Subscript[b, i])))(Subscript[x, j]) (Subscript[y, i])]

Timing@HL[((Subscript[cR, 1,2])(Subscript[cR, 6,3])(Subscript[cR, 4,5])//(Subscript[cm, 1,6->1])(Subscript[cm, 2,4->2])(Subscript[cm, 3,5->3]) )≡((Subscript[cR, 2,3])(Subscript[cR, 1,4])(Subscript[cR, 5,6])//(Subscript[cm, 1,5->1])(Subscript[cm, 2,6->2])(Subscript[cm, 3,4->3]))]

(Subscript[𝔼, {}->{1,2}])[λ (Subscript[x, 1])](Subscript[cR, i,j])//(Subscript[cm, 1,i->1])(Subscript[cm, 2,j->2])

x scattering:

lhs=Coefficient[(Subscript[𝔼, {}->{i,j}])[λ (Subscript[x, i])](Subscript[cR, i1,j1])//(Subscript[cm, i,i1->i])(Subscript[cm, j,j1->j])//First,λ]
rhs=Coefficient[(Subscript[𝔼, {}->{i,j}])[λ ((Subscript[x, i])+(1-(Subscript[B, i]))(Subscript[x, j]))](Subscript[cR, i1,j1])//(Subscript[cm, i1,i->i])(Subscript[cm, j1,j->j])//First,λ]
HL[lhs==rhs]

lhs=Coefficient[(Subscript[𝔼, {}->{i,j}])[λ (Subscript[x, j])](Subscript[cR, i1,j1])//(Subscript[cm, i,i1->i])(Subscript[cm, j,j1->j])//First,λ]
rhs=Coefficient[(Subscript[𝔼, {}->{i,j}])[λ (Subscript[B, i])(Subscript[x, j])](Subscript[cR, i1,j1])//(Subscript[cm, i1,i->i])(Subscript[cm, j1,j->j])//First,λ]
HL[lhs==rhs]

y scattering:

lhs=Coefficient[(Subscript[𝔼, {}->{i,j}])[λ (Subscript[y, i])](Subscript[cR, i1,j1])//(Subscript[cm, i,i1->i])(Subscript[cm, j,j1->j])//First,λ]
rhs=Coefficient[(Subscript[𝔼, {}->{i,j}])[λ (Subscript[y, i])](Subscript[cR, i1,j1])//(Subscript[cm, i1,i->i])(Subscript[cm, j1,j->j])//First,λ]
HL[lhs==rhs]

lhs=Coefficient[(Subscript[𝔼, {}->{i,j}])[λ (Subscript[y, j])](Subscript[cR, i1,j1])//(Subscript[cm, i,i1->i])(Subscript[cm, j,j1->j])//First,λ]
rhs=Coefficient[(Subscript[𝔼, {}->{i,j}])[λ (μ (Subscript[y, i])+(Subscript[B, i]^(-1))(Subscript[y, j]))](Subscript[cR, i1,j1])//(Subscript[cm, i1,i->i])(Subscript[cm, j1,j->j])//First,λ]/.μ->((Subscript[b, j])/(Subscript[b, i])) (1-(Subscript[B, i]^(-1)))
HL[Simplify[lhs==rhs]]

Verifying YB:

(Subscript[ℛ, i_,j_])[ℰ_]:=Expand[ℰ/.{
(Subscript[x, i])->(Subscript[x, i])+(1-(Subscript[B, i]))(Subscript[x, j]),
(Subscript[x, j])->(Subscript[B, i])(Subscript[x, j]),
(Subscript[y, i])->(Subscript[y, i]),
(Subscript[y, j])->((Subscript[b, j])/(Subscript[b, i])) (1-(Subscript[B, i]^(-1)))(Subscript[y, i])+(Subscript[B, i]^(-1))(Subscript[y, j])
}]

lhs={(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3]),(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[y, 3])}//(Subscript[ℛ, 1,2])//(Subscript[ℛ, 1,3])//(Subscript[ℛ, 2,3])
rhs={(Subscript[x, 1]),(Subscript[x, 2]),(Subscript[x, 3]),(Subscript[y, 1]),(Subscript[y, 2]),(Subscript[y, 3])}//(Subscript[ℛ, 2,3])//(Subscript[ℛ, 1,3])//(Subscript[ℛ, 1,2])
HL[lhs==rhs]