Pensieve header: A 4D algebra whose associated knot invariant is Alexander.

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

MT=(({{ , a, b, c, d}, {a, a, b, 0, 0}, {b, 0, 0, a, b}, {c, c, d, 0, 0}, {d, 0, 0, c, d}}));
ℰ_//(Subscript[m, i_,j_->k_]):=Expand[ℰ]/.Flatten@Table[(Subscript[MT[[α,1]], i])(Subscript[MT[[1,β]], j])->(MT[[α,β]]/.v:(a|b|c|d):>(Subscript[v, k])),{α,2,5},{β,2,5}];
(Subscript[η, i_]):=(Subscript[a, i])+(Subscript[d, i]);

KBasis[i_]:={(Subscript[a, i]),(Subscript[b, i]),(Subscript[c, i]),(Subscript[d, i])};
KBasis[i_,is__]:=Flatten@Outer[Times,KBasis[i],KBasis[is]]

(Subscript[R, i_,j_]):=(T^(-1/2))((Subscript[a, i]) (Subscript[a, j])+T (Subscript[a, i]) (Subscript[d, j])+(1-T) (Subscript[b, j]) (Subscript[c, i])+(Subscript[d, i]) (Subscript[a, j])-T (Subscript[d, i]) (Subscript[d, j]));
(Subscript[(OverBar[R]), i_,j_]):=(T^(1/2))((Subscript[a, i]) (Subscript[a, j])+(T^(-1))(Subscript[a, i]) (Subscript[d, j])+(1-(T^(-1))) (Subscript[b, j]) (Subscript[c, i])+(Subscript[d, i]) (Subscript[a, j])-(T^(-1))(Subscript[d, i]) (Subscript[d, j]));
(Subscript[C, i_]):=(T^(-1/2))((Subscript[a, i])-(Subscript[d, i])); (Subscript[(OverBar[C]), i_]):=(T^(1/2))((Subscript[a, i])-(Subscript[d, i]));

RVK and Z

RVK, rot, Z modified from 2016-09/OneSmidgen.nb. See also in AP/Projects/SL2Invariant/.

Some details of the code below are at http://drorbn.net/bbs/show?shot=Dror-160920-151350.jpg.

RVK::usage="RVK[xs, rots] represents a Rotational Virtual Knot with a list of n Xp/Xm crossings xs and a length 2n list of rotation numbers rots. Crossing sites are indexed 1 through 2n, and rots[[k]] is the rotation between site k-1 and site k. RVK is also a casting operator converting to the RVK presentation from other knot presentations.";

RVK[pd_PD]:=Module[{n,xs,x,rots,front={1},k},
n=Length@pd;rots=Table[0,{2n}];
xs=Cases[pd,x_X:>(Piecewise[{{Xp[x[[4]],x[[1]]], PositiveQ@x}, {Xm[x[[2]],x[[1]]], True}}])];
For[k=1,k<=2n,++k,
If[FreeQ[front,-k],
front=Flatten@Replace[front,k->(xs/.{
Xp[k,l_]|Xm[l_,k]:>{l+1,k+1,-l},
Xp[l_,k]|Xm[k,l_]:>(++rots[[l]];{-l,k+1,l+1}),
_Xp|_Xm:>{}
}), {1}],
Cases[front,k|-k]/.{k,-k}:>--rots[[k]];
]
];
RVK[xs,rots] ];
RVK[K_]:=RVK[PD[K]];

rvk=RVK[Knot[6,3]]

(Subscript[R, 1,2])

(Subscript[C, 1])

(Subscript[rot, i_])[n_]:=(Subscript[rot, i])[n]=(Piecewise[{{(Subscript[η, i]), n==0}, {(Subscript[C, $])(Subscript[rot, i])[n-1]// (Subscript[m, i,$->i]), n>0}, {(Subscript[(OverBar[C]), $])(Subscript[rot, i])[n+1]// (Subscript[m, i,$->i]), n<0}}])

(Subscript[rot, 1])[15]

z=Product[
{i,j}=List@@x;
(x/.{_Xp:>(Subscript[R, i,j]),_Xm:>(Subscript[(OverBar[R]), i,j])})(Subscript[rot, i-1/2])[rvk[[2,i]]](Subscript[rot, j-1/2])[rvk[[2,j]]] // (Subscript[m, i-1/2,i->i])//(Subscript[m, j-1/2,j->j]),
{x,rvk[[1]]}
]

Short[Expand[z],10]

{(6^6),Length[Expand[z]]}

Do[z=(Subscript[m, 1,i->1])[z],{i,2,12}];
Factor@z

Alexander[Knot[6,3]][T]

Z[K_] := Z[RVK@K];
Z[rvk_RVK] :=Module[{ζ,done,st,c, χ,i,j,k},
ζ=1; done={}; st=Range[2Length[rvk[[1]]]];
Do[
{i,j}=List@@c;
χ=c/.{_Xp:>(Subscript[R, i,j]),_Xm:>(Subscript[(OverBar[R]), i,j])};
Do[χ=((Subscript[rot, 0])[rvk[[2,k]]]χ)//(Subscript[m, 0,k->k]), {k,{i,j}}];
ζ*=χ;
Do[
If[MemberQ[done, k+1],ζ=ζ//(Subscript[m, k,k+1->k]); st=st/.k+1->k];
If[MemberQ[done, k-1],ζ=ζ//(Subscript[m, st[[k-1]],k->st[[k-1]]]); st=st/.k->st[[k-1]]],
{k,{i,j}}];
done=done⋃{i,j},
{c,rvk[[1]]}
];
Factor@ζ
]

K=Knot[8,17]; Factor@Alexander[K][T]
z=Z[K]

Timing@Table[Simplify[Alexander[K][T](Subscript[η, 1])==Z[K]],{K,AllKnots[{3,9}]}]

ZF[K_]:=Z@ThinPosition@K;

Timing@Union@Table[Simplify[Alexander[K][T](Subscript[η, 1])==ZF[K]],{K,AllKnots[{3,9}]}]

Timing@Union@Table[Simplify[Alexander[K][T](Subscript[η, 1])==ZF[K]],{K,AllKnots[{3,10}]}]

Timing[ZF[GST48]]

ZF/@RibbonKnots