Pensieve header: The category GDO and the Heisenberg algebra. Based on AlexanderFromHeisenberg.nb at pensieve://Talks/LearningSeminarOnCategorification-2006/.

SetDirectory["C:\\drorbn\\AcademicPensieve\\Classes\\21-1350-KnotTheory"];
<< Common.m

A hack to fix how Expand acts on Series:

Unprotect[SeriesData];
SeriesData/:Expand[sd_SeriesData]:=MapAt[Expand,sd,3];
Protect[SeriesData];

{(SuperStar[p]),(SuperStar[x]),(SuperStar[π]),(SuperStar[ξ])}={π,ξ,p,x}; (SuperStar[((Subscript[u_, i_]))]):=(Subscript[((SuperStar[u])), i]); (SuperStar[l_List]):=(SuperStar[#])& /@ l;

((Subscript[𝔾, A1_->B1_])[L1_]//(Subscript[𝔾, A2_->B2_])[L2_])/; ((SuperStar[B1])===A2):=Module[{b,r,x,ξ},
r=Expand[(L1/.Table[x->b[x],{x,B1}])(L2/.Table[ξ->b[ξ],{ξ,A2}])];
Do[r=r /. ((b[x])^(p_.))((b[(SuperStar[x])])^(p_.)) ->p! /.b[x|(SuperStar[x])]->0, {x,B1}];
(Subscript[𝔾, A1->B2])[r]
]

(Subscript[𝔾, {(Subscript[ξ, 1])}->{(Subscript[x, 1])}])[1+(Subscript[ξ, 1])(Subscript[x, 1])+(Subscript[ξ, 1]^2)(Subscript[x, 1]^2)]//(Subscript[𝔾, {(Subscript[ξ, 1])}->{(Subscript[x, 2])}])[1+(Subscript[ξ, 1])(Subscript[x, 2])+(Subscript[ξ, 1]^2)(Subscript[x, 2]^2)]

(Subscript[𝔼, s1_])[ωQ1__]≡(Subscript[𝔼, s2_])[ωQ2__]:=s1===s2∧Simplify[{ωQ1}=={ωQ2}]

(Subscript[𝔼, A1_->B1_])[ω1_,Q1_](Subscript[𝔼, A2_->B2_])[ω2_,Q2_]^:=(Subscript[𝔼, A1⋃A2->B1⋃B2])[ω1 ω2,Q1+Q2]

CF=ExpandNumerator@*ExpandDenominator@*PowerExpand@*Factor;

((Subscript[𝔼, A1_->B1_])[ω1_,Q1_]//(Subscript[𝔼, A2_->B2_])[ω2_,Q2_])/; ((SuperStar[B1])===A2):=Module[{i,j,E1,F1,G1,E2,F2,G2,I,M=Table},
I=IdentityMatrix@Length@B1;
E1=M[(∂_(i,j))Q1,{i,A1},{j,B1}]; E2=M[(∂_(i,j))Q2,{i,A2},{j,B2}];
F1=M[(∂_(i,j))Q1,{i,A1},{j,A1}]; F2=M[(∂_(i,j))Q2,{i,A2},{j,A2}];
G1=M[(∂_(i,j))Q1,{i,B1},{j,B1}]; G2=M[(∂_(i,j))Q2,{i,B2},{j,B2}];
(Subscript[𝔼, A1->B2])[CF[ω1 ω2 ((Det[I-F2.G1])^(-1/2))],CF@Plus[
If[A1==={}∨B2==={},0,A1.E1.Inverse[I-F2.G1].E2.B2],
If[A1==={},0,(1/2)A1.(F1+E1.F2.Inverse[I-G1.F2].(E1^\[Transpose])).A1],
If[B2==={},0,(1/2)B2.(G2+(E2^\[Transpose]).G1.Inverse[I-F2.G1].E2).B2]]]]

(Subscript[Random𝔼, A_->B_])[r_]:=Module[{ri},
ri:=RandomInteger[{-r,r}];
(Subscript[𝔼, Table[(Subscript[ξ, i]),{i,A}]->Table[(Subscript[x, j]),{j,B}]])[
ri,
Sum[ri ℏ (Subscript[ξ, i])(Subscript[ξ, j]),{i,A},{j,A}]+Sum[ri ℏ (Subscript[ξ, i])(Subscript[x, j]),{i,A},{j,B}]+Sum[ri ℏ (Subscript[x, i])(Subscript[x, j]),{i,B},{j,B}]
]]

E1=(Subscript[Random𝔼, {1,2}->{1,2,3,4}])[5]

E2=(Subscript[Random𝔼, {1,2,3,4}->{1,2,3}])[5]

E1//E2

𝔼Series[(Subscript[𝔼, s_])[ω_,Q_],d_]:=(Subscript[𝔾, s])[Expand@Series[ω Exp[Q],{ℏ,0,d}]]

𝔼Series[E1,1]

𝔼Series[E2,1]

𝔼Series[E1,1]//𝔼Series[E2,1]

𝔼Series[E1//E2,1]

𝔼Series[E1//E2,5]==(𝔼Series[E1,5]//𝔼Series[E2,5])

A_∖B_:=Complement[A,B];
((Subscript[𝔼, A1_->B1_])[ω1_,Q1_]//(Subscript[𝔼, A2_->B2_])[ω2_,Q2_])/; ((SuperStar[B1])=!=A2):=(Subscript[𝔼, A1⋃(A2∖(SuperStar[B1]))->B1⋃(SuperStar[A2])])[ω1,Q1+Sum[(SuperStar[ζ])ζ,{ζ,A2∖(SuperStar[B1])}]]//(Subscript[𝔼, (SuperStar[B1])⋃A2->B2⋃(B1∖(SuperStar[A2]))])[ω2,Q2+Sum[(SuperStar[z])z,{z,B1∖(SuperStar[A2])}]]

A proof of the formula for R is at http://drorbn.net/cat20.

(Subscript[R, i_,j_]):=(Subscript[𝔼, {}->{(Subscript[p, i]),(Subscript[x, i]),(Subscript[p, j]),(Subscript[x, j])}])[(T^(1/2)),(1-T)(Subscript[p, j])(Subscript[x, j])+(T-1)(Subscript[p, i])(Subscript[x, j])];
(Subscript[(OverBar[R]), i_,j_]):=(Subscript[𝔼, {}->{(Subscript[p, i]),(Subscript[x, i]),(Subscript[p, j]),(Subscript[x, j])}])[(T^(-1/2)),(1-(T^(-1)))(Subscript[p, j])(Subscript[x, j])+((T^(-1))-1)(Subscript[p, i])(Subscript[x, j])];
(Subscript[C, i_]):=(Subscript[𝔼, {}->{(Subscript[p, i]),(Subscript[x, i])}])[(T^(1/2)),0]; (Subscript[(OverBar[C]), i_]):=(Subscript[𝔼, {}->{(Subscript[p, i]),(Subscript[x, i])}])[(T^(-1/2)),0];

(Subscript[η, i_]):=(Subscript[𝔼, {}->{(Subscript[p, i]),(Subscript[x, i])}])[1,0]

(Subscript[m, i_,j_->k_]):=(Subscript[𝔼, {(Subscript[π, i]),(Subscript[ξ, i]),(Subscript[π, j]),(Subscript[ξ, j])}->{(Subscript[p, k]),(Subscript[x, k])}])[1,-(Subscript[ξ, i])(Subscript[π, j])+((Subscript[π, i])+(Subscript[π, j]))(Subscript[p, k])+((Subscript[ξ, i])+(Subscript[ξ, j]))(Subscript[x, k])]

Reidemeister 3

((Subscript[R, 1,2])(Subscript[R, 4,3])(Subscript[R, 5,6])//(Subscript[m, 1,4->1])(Subscript[m, 2,5->2])(Subscript[m, 3,6->3]))≡((Subscript[R, 2,3])(Subscript[R, 1,6])(Subscript[R, 4,5])//(Subscript[m, 1,4->1])(Subscript[m, 2,5->2])(Subscript[m, 3,6->3]))

Reidemeister 2

{((Subscript[(OverBar[R]), 1,2])(Subscript[R, 3,4])//(Subscript[m, 1,3->1])(Subscript[m, 2,4->2]))≡(Subscript[η, 1])(Subscript[η, 2]),
((Subscript[R, 1,4])(Subscript[(OverBar[R]), 5,2])(Subscript[(OverBar[C]), 3])//(Subscript[m, 2,4->2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,5->1]))≡(Subscript[(OverBar[C]), 1])(Subscript[η, 2])}

Reidemeister 1’s

{((Subscript[(OverBar[C]), 2])(Subscript[R, 1,3])//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))≡(Subscript[η, 1]), ((Subscript[(OverBar[C]), 2])(Subscript[(OverBar[R]), 3,1])//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))≡(Subscript[η, 1]),
((Subscript[C, 2])(Subscript[(OverBar[R]), 1,3])//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))≡(Subscript[η, 1]),((Subscript[C, 2])(Subscript[R, 3,1])//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))≡(Subscript[η, 1])}

The “First Tangle”

Factor/@(z=(Subscript[R, 1,6])(Subscript[(OverBar[C]), 3])(Subscript[(OverBar[R]), 7,4])(Subscript[(OverBar[R]), 5,2])//(Subscript[m, 1,3->1])//(Subscript[m, 1,4->1])//(Subscript[m, 1,5->1])//(Subscript[m, 1,6->1])//(Subscript[m, 2,7->2]))

ZF[Knot[4,1]]

Alexander[Knot[4,1]][T]

Timing@Table[Simplify[Alexander[K][T]ZF[K][[1]]],{K,AllKnots[{3,9}]}]

Timing@ZF[GST48]