Startup

SetDirectory["C:\\drorbn\\AcademicPensieve\\Projects\\SL2Portfolio2"];
<< KnotTheory`;
<<"../Profile/Profile.m";
<<"Engine-Speedy.m";
<<"Objects.m";
<<"KT.m";
BeginProfile[];
PopupWindow[Button["Show Profile Monitor"],Dynamic[PrintProfile[], UpdateInterval->3, TrackedSymbols->{}]]

$k=2; (*ℏ=γ=1;*)

HL[ℰ_] := Style[ℰ, Background -> If[TrueQ@ℰ,,]];

The q ops

Define[(Subscript[qσ, i->j])=(Subscript[𝔼, {i}->{i}])[(Subscript[α, i])(Subscript[a, j])+(Subscript[η, i])(Subscript[y, j])+(Subscript[ξ, i])(Subscript[x, j])]]; (Subscript[qσ, i->j])

Define[(Subscript[det, i])=(Subscript[𝔼, {i}->{i}])[(Subscript[α, i])(Subscript[a, i])+(Subscript[η, i])(Subscript[y, i])+(Subscript[ξ, i])(Subscript[x, i])]]; (Subscript[det, i])

Define[(Subscript[qϵ, i])=(Subscript[dϵ, i])//(Subscript[b2t, i])//(Subscript[det, i])]; (Subscript[qϵ, i])
Define[(Subscript[qη, i])=(Subscript[det, i])//(Subscript[t2b, i])//(Subscript[dη, i])]; (Subscript[qη, i])

Define[(Subscript[qm, i,j->k])=((Subscript[det, i])(Subscript[det, j]))//((Subscript[t2b, i])(Subscript[t2b, j]))//(Subscript[dm, i,j->k])//(Subscript[b2t, k])//(Subscript[det, k])]; (Subscript[qm, i,j->k])

Define[(Subscript[qΔ, i->j,k])=(Subscript[det, i])//(Subscript[t2b, i])//(Subscript[dΔ, i->j,k])//((Subscript[b2t, j])(Subscript[b2t, k]))//((Subscript[det, j])(Subscript[det, k]))]; (Subscript[qΔ, i->j,k])

Define[(Subscript[qS, i])=(Subscript[det, i])//(Subscript[t2b, i])//(Subscript[dS, i])//(Subscript[b2t, i])//(Subscript[det, i])]; (Subscript[qS, i])
Define[(Subscript[(OverBar[qS]), i])=(Subscript[det, i])//(Subscript[t2b, i])//(Subscript[(OverBar[dS]), i])//(Subscript[b2t, i])//(Subscript[det, i])]; (Subscript[(OverBar[qS]), i])

Define[(Subscript[qR, i,j])=(Subscript[R, i,j])//((Subscript[b2t, i])(Subscript[b2t, j]))//((Subscript[det, i])(Subscript[det, j]))]; (Subscript[qR, i,j])
Define[(Subscript[(OverBar[qR]), i,j])=(Subscript[(OverBar[R]), i,j])//((Subscript[b2t, i])(Subscript[b2t, j]))//((Subscript[det, i])(Subscript[det, j]))]; (Subscript[(OverBar[qR]), i,j])
Define[(Subscript[qC, i])=(Subscript[C, i])//(Subscript[b2t, i])//(Subscript[det, i])]; (Subscript[qC, i])
Define[(Subscript[(OverBar[qC]), i])=(Subscript[(OverBar[C]), i])//(Subscript[b2t, i])//(Subscript[det, i])]; (Subscript[(OverBar[qC]), i])
Define[(Subscript[qKink, i])=(Subscript[Kink, i])//(Subscript[b2t, i])//(Subscript[det, i])]; (Subscript[qKink, i])
Define[(Subscript[(OverBar[qKink]), i])=(Subscript[(OverBar[Kink]), i])//(Subscript[b2t, i])//(Subscript[det, i])]; (Subscript[(OverBar[qKink]), i])

Testing

(co)-associativity

Timing[HL/@{((Subscript[qΔ, 1->1,2])//(Subscript[qΔ, 2->2,3]))≡((Subscript[qΔ, 1->1,3])//(Subscript[qΔ, 1->1,2])),((Subscript[qm, 1,2->1])//(Subscript[qm, 1,3->1]))≡((Subscript[qm, 2,3->2])//(Subscript[qm, 1,2->1]))}]

Δ is an algebra morphism

Timing@HL[((Subscript[qm, 1,2->1])//(Subscript[qΔ, 1->1,2]))≡(((Subscript[qΔ, 1->1,3])(Subscript[qΔ, 2->2,4]))//((Subscript[qm, 3,4->2])(Subscript[qm, 1,2->1])))]

qS and (OverBar[qS]) are inverses:

Timing@HL[((Subscript[(OverBar[qS]), 1])//(Subscript[qS, 1]))≡(Subscript[qσ, 1->1])]

(Subscript[S, 2]) inverts R, but not (Subscript[S, 1]):

Timing@{((Subscript[qR, 1,2])//(Subscript[qS, 1]))≡(Subscript[(OverBar[qR]), 1,2]), HL[((Subscript[qR, 1,2])//(Subscript[qS, 2]))≡(Subscript[(OverBar[qR]), 1,2])]}

qS is convolution inverse of id

Timing[HL[#≡(Subscript[qϵ, 1])(Subscript[qη, 1])]& /@ {((Subscript[qΔ, 1->1,2])//(Subscript[qS, 1]))//(Subscript[qm, 1,2->1]),((Subscript[qΔ, 1->1,2])//(Subscript[qS, 2]))//(Subscript[qm, 1,2->1])}]

qS is a (co)-algebra anti-morphism

Timing[HL/@Expand/@{((Subscript[qm, 1,2->1])//(Subscript[qS, 1]))≡(((Subscript[qS, 1])(Subscript[qS, 2]))//(Subscript[qm, 2,1->1])),((Subscript[qS, 1])//(Subscript[qΔ, 1->1,2]))≡((Subscript[qΔ, 1->2,1])//((Subscript[qS, 1])(Subscript[qS, 2])))}]

Quasi-triangular axiom 1:

Timing@HL[((Subscript[qR, 1,2])//(Subscript[qΔ, 1->1,3]))≡(((Subscript[qR, 1,4])(Subscript[qR, 3,2]))//(Subscript[qm, 2,4->2]))]

Timing@Block[{$k=2},HL/@{(((Subscript[qC, i])(Subscript[(OverBar[qC]), j]))//(Subscript[qm, i,j->i]))≡(Subscript[qϵ, i]),(((Subscript[(OverBar[qC]), i])(Subscript[(OverBar[qC]), j]))//(Subscript[qm, i,j->i]))≡((((Subscript[qR, 1,2])//(Subscript[qS, 1])//(Subscript[qm, 2,1->i]))//(Subscript[qS, i]))((Subscript[qR, 1,2])//(Subscript[qS, 2])//(Subscript[qS, 2])//(Subscript[qm, 2,1->j]))//(Subscript[qm, i,j->i]))}]

The Trefoil

Timing@Block[{$k=4},
Z31=(Subscript[qR, 1,5])(Subscript[qR, 6,2])(Subscript[qR, 3,7])(Subscript[(OverBar[qC]), 4])(Subscript[(OverBar[qKink]), 8])(Subscript[(OverBar[qKink]), 9])(Subscript[(OverBar[qKink]), 10]);
Do[Z31=Z31//(Subscript[qm, 1,r->1]),{r,2,10}];
{Simplify/@Z31}]