Pensieve header: Full testing of all functions.

Startup

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

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

Utilities

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

Testing

Block[{$k=1}, {
am->(Subscript[am, i,j->k]),bm->(Subscript[bm, i,j->k]),dm->(Subscript[dm, i,j->k]),R->(Subscript[R, i,j]),(OverBar[R])->(Subscript[(OverBar[R]), i,j]),P->(Subscript[P, i,j]),aS->(Subscript[aS, i]),(OverBar[aS])->(Subscript[(OverBar[aS]), i]),bS->(Subscript[bS, i]),(OverBar[bS])->(Subscript[(OverBar[bS]), i]),dS->(Subscript[dS, i]),aΔ->(Subscript[aΔ, i->j,k]),bΔ->(Subscript[bΔ, i->j,k]),dΔ->(Subscript[dΔ, i->j,k]),C->(Subscript[C, i]),(OverBar[C])->(Subscript[(OverBar[C]), i]),Kink->(Subscript[Kink, i]),(OverBar[Kink])->(Subscript[(OverBar[Kink]), i]),b2t->(Subscript[b2t, i]),t2b->(Subscript[t2b, i])
}] // Column

Check that on the generators this agrees with our conventions in the handout:

Timing@{{"[a,x]"->(((Subscript[𝔼, {}->{1,2}])[0,0,(Subscript[a, 2])(Subscript[x, 1])]//(Subscript[am, 1,2->1]))[3]-((Subscript[𝔼, {}->{1,2}])[0,0,(Subscript[a, 1])(Subscript[x, 2])]//(Subscript[am, 1,2->1]))[3]),
"[b,y]"->(((Subscript[𝔼, {}->{1,2}])[0,0,(Subscript[y, 2])(Subscript[b, 1])]//(Subscript[bm, 1,2->1]))[3]-((Subscript[𝔼, {}->{1,2}])[0,0,(Subscript[y, 1])(Subscript[b, 2])]//(Subscript[bm, 1,2->1]))[3])}/.(Subscript[z_, 1])->z,
{"Δ[y]"->Last[(Subscript[𝔼, {}->{1}])[0,0,(Subscript[y, 1])]~(Subscript[B, 1])~(Subscript[bΔ, 1->1,2])],
"Δ[b]"->Last[(Subscript[𝔼, {}->{1}])[0,0,(Subscript[b, 1])]~(Subscript[B, 1])~(Subscript[bΔ, 1->1,2])],
"Δ[a]"->Last[(Subscript[𝔼, {}->{1}])[0,0,(Subscript[a, 1])]~(Subscript[B, 1])~(Subscript[aΔ, 1->1,2])],
"Δ[x]"->Last[(Subscript[𝔼, {}->{1}])[0,0,(Subscript[x, 1])]~(Subscript[B, 1])~(Subscript[aΔ, 1->1,2])]},
{
"S(a)"->(((Subscript[𝔼, {}->{1}])[0,0,(Subscript[a, 1])]~(Subscript[B, 1])~(Subscript[aS, 1]))[3]),
"S(x)"->(((Subscript[𝔼, {}->{1}])[0,0,(Subscript[x, 1])]~(Subscript[B, 1])~(Subscript[aS, 1]))[3]),
"S(b)"->(((Subscript[𝔼, {}->{1}])[0,0,(Subscript[b, 1])]~(Subscript[B, 1])~(Subscript[bS, 1]))[3]),
"S(y)"->(((Subscript[𝔼, {}->{1}])[0,0,(Subscript[y, 1])]~(Subscript[B, 1])~(Subscript[bS, 1]))[3])
}/.(Subscript[z_, 1])->z}

Hopf algebra axioms on both sides separately.

Associativity of am and bm:

Timing@Block[{$k=3},
HL/@{((Subscript[am, 1,2->1])//(Subscript[am, 1,3->1]))≡((Subscript[am, 2,3->2])//(Subscript[am, 1,2->1])),((Subscript[bm, 1,2->1])//(Subscript[bm, 1,3->1]))≡((Subscript[bm, 2,3->2])//(Subscript[bm, 1,2->1]))}
]

R and P are inverses:

Timing@Block[{$k=3},{(Subscript[R, i,j]),(Subscript[P, i,k]),HL[((Subscript[R, i,j])//(Subscript[P, i,k]))≡(Subscript[aσ, k->j])]}]

as and (OverBar[aS]) are inverses, bs and (OverBar[bS]) are inverses:

Timing[HL/@{((Subscript[(OverBar[aS]), 1])//(Subscript[aS, 1]))≡(Subscript[aσ, 1->1]), ((Subscript[(OverBar[bS]), 1])//(Subscript[bS, 1]))≡(Subscript[bσ, 1->1])}]

(co)-associativity on both sides

Timing[HL /@ {((Subscript[aΔ, 1->1,2])//(Subscript[aΔ, 2->2,3]))≡((Subscript[aΔ, 1->1,3])//(Subscript[aΔ, 1->1,2])),((Subscript[bΔ, 1->1,2])//(Subscript[bΔ, 2->2,3]))≡((Subscript[bΔ, 1->1,3])//(Subscript[bΔ, 1->1,2])),((Subscript[am, 1,2->1])//(Subscript[am, 1,3->1]))≡((Subscript[am, 2,3->2])//(Subscript[am, 1,2->1])),((Subscript[bm, 1,2->1])//(Subscript[bm, 1,3->1]))≡((Subscript[bm, 2,3->2])//(Subscript[bm, 1,2->1]))}]

Δ is an algebra morphism

Timing[HL /@ {((Subscript[am, 1,2->1])//(Subscript[aΔ, 1->1,2]))≡(((Subscript[aΔ, 1->1,3])(Subscript[aΔ, 2->2,4]))//((Subscript[am, 3,4->2])(Subscript[am, 1,2->1]))),
((Subscript[bm, 1,2->1])//(Subscript[bΔ, 1->1,2]))≡(((Subscript[bΔ, 1->1,3])(Subscript[bΔ, 2->2,4]))//((Subscript[bm, 3,4->2])(Subscript[bm, 1,2->1])))}]

An explicit formula for (Subscript[aS, i])

Timing@Block[{$k=4}, HL[(Subscript[aS, i])≡((Subscript[(Subscript[𝔼, {i}->{i,j}])[-(Subscript[α, i])(Subscript[a, j]),-(Subscript[ξ, i])(Subscript[x, i]),
Sum[Expand[(((E^((Subscript[ξ, i]) (Subscript[x, i])))(((-ℏ γ ϵ))^k))/((2^k)k!))Nest[Expand[(Subscript[x, i]^2)(∂_({(Subscript[x, i]),2}))#]&, (E^(-(Subscript[ξ, i]) (E^(ℏ ϵ (Subscript[a, i])))(Subscript[x, i]))),k]], {k,0,$k}]], $k])//(Subscript[am, i,j->i]))]]

S is convolution inverse of id

Timing[HL[#≡(Subscript[sϵ, 1])(Subscript[sη, 1])]& /@ {
((Subscript[aΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[aS, 1]))~(Subscript[B, 1,2])~(Subscript[am, 1,2->1]),((Subscript[aΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[aS, 2]))~(Subscript[B, 1,2])~(Subscript[am, 1,2->1]), ((Subscript[bΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[bS, 1]))~(Subscript[B, 1,2])~(Subscript[bm, 1,2->1]),((Subscript[bΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[bS, 2]))~(Subscript[B, 1,2])~(Subscript[bm, 1,2->1])}]

But not with the opposite product:

Timing[Short[#≡(Subscript[sϵ, 1])(Subscript[sη, 1])]& /@ {
((Subscript[aΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[aS, 1]))~(Subscript[B, 1,2])~(Subscript[am, 2,1->1]),((Subscript[aΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[aS, 2]))~(Subscript[B, 1,2])~(Subscript[am, 2,1->1]), ((Subscript[bΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[bS, 1]))~(Subscript[B, 1,2])~(Subscript[bm, 2,1->1]),((Subscript[bΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[bS, 2]))~(Subscript[B, 1,2])~(Subscript[bm, 2,1->1])}]

S is an algebra anti-(co)morphism

Timing[HL/@{(Subscript[am, 1,2->1])~(Subscript[B, 1])~(Subscript[aS, 1])≡((Subscript[aS, 1])(Subscript[aS, 2]))~(Subscript[B, 1,2])~(Subscript[am, 2,1->1]),(Subscript[bm, 1,2->1])~(Subscript[B, 1])~(Subscript[bS, 1])≡((Subscript[bS, 1])(Subscript[bS, 2]))~(Subscript[B, 1,2])~(Subscript[bm, 2,1->1]), (Subscript[aS, 1])~(Subscript[B, 1])~(Subscript[aΔ, 1->1,2])≡(Subscript[aΔ, 1->2,1])~(Subscript[B, 1,2])~((Subscript[aS, 1])(Subscript[aS, 2])),(Subscript[bS, 1])~(Subscript[B, 1])~(Subscript[bΔ, 1->1,2])≡(Subscript[bΔ, 1->2,1])~(Subscript[B, 1,2])~((Subscript[bS, 1])(Subscript[bS, 2]))}]

Pairing axioms

Timing[HL/@{((Subscript[bm, 1,2->1]) (Subscript[𝔼, {3}->{3}])[(Subscript[α, 3])(Subscript[a, 3]),(Subscript[ξ, 3])(Subscript[x, 3]),1])~(Subscript[B, 1,3])~(Subscript[P, 1,3])≡( (Subscript[𝔼, {1}->{1}])[(Subscript[β, 1])(Subscript[b, 1]),(Subscript[η, 1])(Subscript[y, 1]),1](Subscript[𝔼, {2}->{2}])[(Subscript[β, 2])(Subscript[b, 2]),(Subscript[η, 2])(Subscript[y, 2]),1](Subscript[aΔ, 3->4,5]))~(Subscript[B, 1,4])~(Subscript[P, 1,4])~(Subscript[B, 2,5])~(Subscript[P, 2,5]),((Subscript[bΔ, 1->1,2]) (Subscript[𝔼, {3}->{3}])[(Subscript[α, 3])(Subscript[a, 3]),(Subscript[ξ, 3])(Subscript[x, 3]),1](Subscript[𝔼, {4}->{4}])[(Subscript[α, 4])(Subscript[a, 4]),(Subscript[ξ, 4])(Subscript[x, 4]),1])~(Subscript[B, 1,3])~(Subscript[P, 1,3])~(Subscript[B, 2,4])~(Subscript[P, 2,4])≡( (Subscript[𝔼, {1}->{1}])[(Subscript[β, 1])(Subscript[b, 1]),(Subscript[η, 1])(Subscript[y, 1]),1](Subscript[am, 3,4->3]))~(Subscript[B, 1,3])~(Subscript[P, 1,3]) }]

Timing[HL/@{(((Subscript[bS, 1])(Subscript[aσ, 2->2]))//(Subscript[P, 1,2]))≡(((Subscript[bσ, 1->1])(Subscript[aS, 2]))//(Subscript[P, 1,2])),
((Subscript[(OverBar[bS]), 1])(Subscript[aσ, 2->2]))~(Subscript[B, 1,2])~(Subscript[P, 1,2])≡((Subscript[bσ, 1->1])(Subscript[(OverBar[aS]), 2]))~(Subscript[B, 1,2])~(Subscript[P, 1,2])}]

Tests for the double.

Check the double formulas on the generators agree with SL2Portfolio.pdf:

Timing@{{
"[a,y]"-> (((Subscript[𝔼, {}->{1,2}])[0,0,(Subscript[y, 2])(Subscript[a, 1])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[3]-((Subscript[𝔼, {}->{1,2}])[0,0,(Subscript[y, 1])(Subscript[a, 2])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[3]),
"[b,x]"   ->(((Subscript[𝔼, {}->{1,2}])[0,0,(Subscript[x, 2])(Subscript[b, 1])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[3]-((Subscript[𝔼, {}->{1,2}])[0,0,(Subscript[x, 1])(Subscript[b, 2])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[3]),"xy-qyx"->(((Subscript[𝔼, {}->{1,2}])[0,0,(Subscript[x, 1])(Subscript[y, 2])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[3]-(1+ϵ)((Subscript[𝔼, {}->{1,2}])[0,0,(Subscript[y, 1])(Subscript[x, 2])]~(Subscript[B, 1,2])~(Subscript[dm, 1,2->1]))[3])
}/.{(Subscript[z_, 1])->z}//Expand//Factor,
{
"Δ(a)"->(((Subscript[𝔼, {}->{1}])[0,0,(Subscript[a, 1])]~(Subscript[B, 1])~(Subscript[dΔ, 1->1,2]))[3]),
"Δ(x)"->(((Subscript[𝔼, {}->{1}])[0,0,(Subscript[x, 1])]~(Subscript[B, 1])~(Subscript[dΔ, 1->1,2]))[3]),
"Δ(b)"->(((Subscript[𝔼, {}->{1}])[0,0,(Subscript[b, 1])]~(Subscript[B, 1])~(Subscript[dΔ, 1->1,2]))[3]),
"Δ(y)"->(((Subscript[𝔼, {}->{1}])[0,0,(Subscript[y, 1])]~(Subscript[B, 1])~(Subscript[dΔ, 1->1,2]))[3])
}//Simplify,
{
"S(a)"->(((Subscript[𝔼, {}->{1}])[0,0,(Subscript[a, 1])]~(Subscript[B, 1])~(Subscript[dS, 1]))[3]),
"S(x)"->(((Subscript[𝔼, {}->{1}])[0,0,(Subscript[x, 1])]~(Subscript[B, 1])~(Subscript[dS, 1]))[3]),
"S(b)"->(((Subscript[𝔼, {}->{1}])[0,0,(Subscript[b, 1])]~(Subscript[B, 1])~(Subscript[dS, 1]))[3]),
"S(y)"->(((Subscript[𝔼, {}->{1}])[0,0,(Subscript[y, 1])]~(Subscript[B, 1])~(Subscript[dS, 1]))[3])
}/.{(Subscript[z_, 1])->z}//Simplify
}

{HL[((Subscript[𝔼, {1,2}->{1,2}])[(Subscript[α, 1])(Subscript[a, 1])+(Subscript[α, 2])(Subscript[a, 2]),(Subscript[ξ, 1])(Subscript[x, 1])+(Subscript[ξ, 2])(Subscript[x, 2]),1]//(Subscript[dm, 1,2->1]))≡(Subscript[am, 1,2->1])],HL[((Subscript[𝔼, {1,2}->{1,2}])[(Subscript[β, 1])(Subscript[b, 1])+(Subscript[β, 2])(Subscript[b, 2]),(Subscript[η, 1])(Subscript[y, 1])+(Subscript[η, 2])(Subscript[y, 2]),1]//(Subscript[dm, 1,2->1]))≡(Subscript[bm, 1,2->1])]}

(co)-associativity

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

Δ is an algebra morphism

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

dS and (OverBar[dS]) are inverses:

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

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

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

dS is convolution inverse of id

Timing[HL[#≡(Subscript[dϵ, 1])(Subscript[dη, 1])]& /@ {((Subscript[dΔ, 1->1,2])//(Subscript[dS, 1]))//(Subscript[dm, 1,2->1]),((Subscript[dΔ, 1->1,2])//(Subscript[dS, 2]))//(Subscript[dm, 1,2->1])}]

dS is a (co)-algebra anti-morphism

Timing[HL/@Expand/@{((Subscript[dm, 1,2->1])//(Subscript[dS, 1]))≡(((Subscript[dS, 1])(Subscript[dS, 2]))//(Subscript[dm, 2,1->1])),((Subscript[dS, 1])//(Subscript[dΔ, 1->1,2]))≡((Subscript[dΔ, 1->2,1])//((Subscript[dS, 1])(Subscript[dS, 2])))}]

Quasi-triangular axiom 1:

Timing[HL/@{((Subscript[R, 1,3])//(Subscript[dΔ, 1->1,2]))≡(((Subscript[R, 1,4])(Subscript[R, 2,3]))//(Subscript[dm, 3,4->3])), ((Subscript[R, 1,2])//(Subscript[dΔ, 2->2,3]))≡(((Subscript[R, 1,2])(Subscript[R, 4,3]))//(Subscript[dm, 1,4->1]))}]

Quasi-triangular axiom 2:

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

The Drinfel’d element inverse property, ((Subscript[u, 1])(Subscript[(OverBar[u]), 2]))//(Subscript[dm, 1,2->1])≡(Subscript[dϵ, i]):

Timing@HL[(((Subscript[R, 1,2])~(Subscript[B, 1])~(Subscript[dS, 1])~(Subscript[B, 1,2])~(Subscript[dm, 2,1->i]))((Subscript[R, 1,2])~(Subscript[B, 2])~(Subscript[dS, 2])~(Subscript[B, 2])~(Subscript[dS, 2])~(Subscript[B, 1,2])~(Subscript[dm, 2,1->j])))~(Subscript[B, i,j])~(Subscript[dm, i,j->i])≡(Subscript[dη, i])]

The ribbon element v satisfies (v^2)=S(u)u. The spinner C=(uv^(-1)). It is convenient to compute z=S(u)(u^(-1)) which is something easy.

Timing@Block[{$k=2},((((Subscript[R, 1,2])~(Subscript[B, 1])~(Subscript[dS, 1])~(Subscript[B, 1,2])~(Subscript[dm, 2,1->i]))~(Subscript[B, i])~(Subscript[dS, i]))((Subscript[R, 1,2])~(Subscript[B, 2])~(Subscript[dS, 2])~(Subscript[B, 2])~(Subscript[dS, 2])~(Subscript[B, 1,2])~(Subscript[dm, 2,1->j])))~(Subscript[B, i,j])~(Subscript[dm, i,j->i])]

Timing@Block[{$k=2},HL/@{(((Subscript[C, i])(Subscript[(OverBar[C]), j]))//(Subscript[dm, i,j->i]))≡(Subscript[dη, i]),(((Subscript[(OverBar[C]), i])(Subscript[(OverBar[C]), j]))//(Subscript[dm, i,j->i]))≡((((Subscript[R, 1,2])//(Subscript[dS, 1])//(Subscript[dm, 2,1->i]))//(Subscript[dS, i]))((Subscript[R, 1,2])//(Subscript[dS, 2])//(Subscript[dS, 2])//(Subscript[dm, 2,1->j]))//(Subscript[dm, i,j->i]))}]

Timing@Block[{$k=2},HL/@{((Subscript[C, i])(Subscript[(OverBar[C]), j]))~(Subscript[B, i,j])~(Subscript[dm, i,j->i])≡(Subscript[𝔼, {}->{i}])[0,0,1],((Subscript[(OverBar[C]), i])(Subscript[(OverBar[C]), j]))~(Subscript[B, i,j])~(Subscript[dm, i,j->i])≡((((Subscript[R, 1,2])~(Subscript[B, 1])~(Subscript[dS, 1])~(Subscript[B, 1,2])~(Subscript[dm, 2,1->i]))~(Subscript[B, i])~(Subscript[dS, i]))((Subscript[R, 1,2])~(Subscript[B, 2])~(Subscript[dS, 2])~(Subscript[B, 2])~(Subscript[dS, 2])~(Subscript[B, 1,2])~(Subscript[dm, 2,1->j])))~(Subscript[B, i,j])~(Subscript[dm, i,j->i])}]

Reidemeister 2:

Timing[HL[#≡(Subscript[dη, 1])(Subscript[dη, 2])]&/@{((Subscript[(OverBar[R]), 1,2])(Subscript[R, 3,4]))//((Subscript[dm, 1,3->1])(Subscript[dm, 2,4->2])),((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4]))//((Subscript[dm, 1,3->1])(Subscript[dm, 2,4->2]))}]

Cyclic Reidemeister 2:

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

Reidemeister 3:

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]))]

Relations between the four kinks:

Timing[HL/@{(Subscript[Kink, i])≡(((Subscript[R, 3,1])(Subscript[C, 2]))//(Subscript[dm, 1,2->1])//(Subscript[dm, 1,3->i])),(Subscript[(OverBar[Kink]), j])≡(((Subscript[(OverBar[R]), 3,1])(Subscript[(OverBar[C]), 2]))//(Subscript[dm, 1,2->1])//(Subscript[dm, 1,3->j])),(((Subscript[Kink, i]) (Subscript[(OverBar[Kink]), j]))//(Subscript[dm, i,j->1]))≡(Subscript[dη, 1])}]

The Trefoil

Timing@Block[{$k=1},
Z31=(Subscript[R, 1,5])(Subscript[R, 6,2])(Subscript[R, 3,7])(Subscript[(OverBar[C]), 4])(Subscript[(OverBar[Kink]), 8])(Subscript[(OverBar[Kink]), 9])(Subscript[(OverBar[Kink]), 10]);
Do[Z31=Z31//(Subscript[dm, 1,r->1]),{r,2,10}];
{Simplify/@Z31, Simplify/@(Z31~(Subscript[B, 1])~(Subscript[b2t, 1]) /. (Subscript[T, 1])->T)}]

b2t, t2b, knot tensors.

HL[((Subscript[b2t, i])//(Subscript[t2b, i]))≡(Subscript[dσ, i->i])]

(Subscript[t2b, i])//(Subscript[b2t, i])

Reidemeister 2:

Timing[HL[#≡(Subscript[dη, 1])(Subscript[dη, 2])]&/@{((Subscript[(OverBar[kR]), 1,2])(Subscript[kR, 3,4]))//((Subscript[km, 1,3->1])(Subscript[km, 2,4->2])),((Subscript[kR, 1,2])(Subscript[(OverBar[kR]), 3,4]))//((Subscript[km, 1,3->1])(Subscript[km, 2,4->2]))}]

Cyclic Reidemeister 2:

Timing@HL[(((Subscript[kR, 1,4])(Subscript[(OverBar[kR]), 5,2])(Subscript[(OverBar[kC]), 3]))//(Subscript[km, 2,4->2])//(Subscript[km, 1,3->1])//(Subscript[km, 1,5->1]))≡(Subscript[(OverBar[kC]), 1])(Subscript[dη, 2])]

Reidemeister 3:

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

Relations between the four kinks:

Timing[HL/@{(Subscript[kKink, i])≡(((Subscript[kR, 3,1])(Subscript[kC, 2]))//(Subscript[km, 1,2->1])//(Subscript[km, 1,3->i])),(Subscript[(OverBar[kKink]), j])≡(((Subscript[(OverBar[kR]), 3,1])(Subscript[(OverBar[kC]), 2]))//(Subscript[km, 1,2->1])//(Subscript[km, 1,3->j])),(((Subscript[kKink, i]) (Subscript[(OverBar[kKink]), j]))//(Subscript[km, i,j->1]))≡(Subscript[dη, 1])}]

The Trefoil

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

Timing@Block[{$k=1},
Z31=(Subscript[kR, 1,5])(Subscript[kR, 6,2])(Subscript[kR, 3,7])(Subscript[(OverBar[kC]), 4])(Subscript[(OverBar[kKink]), 8])(Subscript[(OverBar[kKink]), 9])(Subscript[(OverBar[kKink]), 10]);
Do[Z31=Z31~(Subscript[B, 1,r])~(Subscript[km, 1,r->1]),{r,2,10}];
Simplify/@Z31]

CU

Associativity of CU:

Timing@Block[{$k=3},HL[((Subscript[cm, 1,2->1])//(Subscript[cm, 1,3->1]))≡((Subscript[cm, 2,3->2])//(Subscript[cm, 1,2->1]))]]

Associativity, co-associativity, and Δ is an algebra morphism:

Timing@Block[{$k=3},HL /@ {((Subscript[cm, 1,2->1])//(Subscript[cm, 1,3->1]))≡((Subscript[cm, 2,3->2])//(Subscript[cm, 1,2->1])),
((Subscript[cΔ, 1->1,2])//(Subscript[cΔ, 2->2,3]))≡((Subscript[cΔ, 1->1,3])//(Subscript[cΔ, 1->1,2])),
((Subscript[cm, 1,2->1])//(Subscript[cΔ, 1->1,2]))≡(((Subscript[cΔ, 1->1,3])(Subscript[cΔ, 2->2,4]))//((Subscript[cm, 3,4->2])(Subscript[cm, 1,2->1])))}]

S is convolution inverse of id:

Timing@Block[{$k=3},HL[#≡(Subscript[cϵ, 1])(Subscript[cη, 1])]& /@ {
((Subscript[cΔ, 1->1,2])~(Subscript[B, 1])~(Subscript[cS, 1]))~(Subscript[B, 1,2])~(Subscript[cm, 1,2->1]),((Subscript[cΔ, 1->1,2])~(Subscript[B, 2])~(Subscript[cS, 2]))~(Subscript[B, 1,2])~(Subscript[cm, 1,2->1])}]

S is an algebra anti-(co)morphism

Timing@Block[{$k=3},HL/@{(Subscript[cm, 1,2->1])~(Subscript[B, 1])~(Subscript[cS, 1])≡((Subscript[cS, 1])(Subscript[cS, 2]))~(Subscript[B, 1,2])~(Subscript[cm, 2,1->1]), (Subscript[cS, 1])~(Subscript[B, 1])~(Subscript[cΔ, 1->1,2])≡(Subscript[cΔ, 1->2,1])~(Subscript[B, 1,2])~((Subscript[cS, 1])(Subscript[cS, 2]))}]

Classical is the ℏ->0 limit of quantum:

ClassicalLimit[f_]:=Normal@Series[Normal[f]/.U2l,{ℏ,0,0}]//.l2U;
(*ClassicalLimit[f_]:=Limit[Normal[f]/.U2l,ℏ->0]//.l2U;*)
Timing[HL/@Simplify/@
{(Subscript[cm, 1,2->3])≡ClassicalLimit/@(Subscript[dm, 1,2->3]),((Subscript[cΔ, 1->2,3])/.(Subscript[τ, 1])->0)≡ClassicalLimit/@(Subscript[dΔ, 1->2,3]),(Subscript[cS, 1])≡ClassicalLimit/@(Subscript[dS, 1])}]

EndProfile[];

PrintProfile[]