Pensieve header: The WG Algebra: testing, knots, optimization.

Loading Knot Data

Once[<<KnotTheory`]

AllKnots[{3,5}]

PD/@AllKnots[{3,5}]

Defining a Group

DeclareGroup[(Subscript[S, k_])]:=Module[{α,β,e,γs},
Clear[G,n,g,ι,m,inv];
G=PermutationCycles/@(Permutations@Range@k);
n=Length[G];
Do[g[α]=e=G[[α]]; ι[e]=α,{α,n} ];
m[]=ι[Cycles[{}]];
Do[m[α,β]=ι[g[α]~PermutationProduct~g[β]],{α,n},{β,n} ];
m[α_]:=α; m[α_,β_,γs__]:=m[m[α,β],γs];
Do[inv[α]=ι[InversePermutation[g[α]]],{α,n}]
]

g[3]

k=3; Range@k

Permutations@Range@k

Permutations[{j,l,a}]

PermutationCycles/@(Permutations@Range@k)

PermutationCycles/@Permutations[{j,l,a}]

DeclareGroup[(Subscript[S, k_])]:=Module[{α,β,e,γs},
Clear[G,n,g,ι,m,inv];
G=PermutationCycles/@(Permutations@Range@k);
n=Length[G];
Do[g[α]=e=G[[α]]; ι[e]=α,{α,n} ];
m[]=ι[Cycles[{}]];
Do[m[α,β]=ι[g[α]~PermutationProduct~g[β]],{α,n},{β,n} ];
m[α_]:=α; m[α_,β_,γs__]:=m[m[α,β],γs];
Do[inv[α]=ι[InversePermutation[g[α]]],{α,n}]
]

G=PermutationCycles/@(Permutations@Range@k)

n=Length[G]

?ι

Do[g[α]=e=G[[α]]; ι[e]=α,{α,n} ]

?ι

DeclareGroup[(Subscript[S, k_])]:=Module[{α,β,e,γs},
Clear[G,n,g,ι,m,inv];
G=PermutationCycles/@(Permutations@Range@k);
n=Length[G];
Do[g[α]=e=G[[α]]; ι[e]=α,{α,n} ];
m[]=ι[Cycles[{}]];
Do[m[α,β]=ι[g[α]~PermutationProduct~g[β]],{α,n},{β,n} ];
m[α_]:=α; m[α_,β_,γs__]:=m[m[α,β],γs];
Do[inv[α]=ι[InversePermutation[g[α]]],{α,n}]
]

?m

Do[m[α,β]=ι[g[α]~PermutationProduct~g[β]],{α,n},{β,n} ]

?m

DeclareGroup[(Subscript[S, k_])]:=Module[{α,β,e,γs},
Clear[G,n,g,ι,m,inv];
G=PermutationCycles/@(Permutations@Range@k);
n=Length[G];
Do[g[α]=e=G[[α]]; ι[e]=α,{α,n} ];
m[]=ι[Cycles[{}]];
Do[m[α,β]=ι[g[α]~PermutationProduct~g[β]],{α,n},{β,n} ];
m[α_]:=α; m[α_,β_,γs__]:=m[m[α,β],γs];
Do[inv[α]=ι[InversePermutation[g[α]]],{α,n}]
]

m[inv[3],2,3]

DeclareGroup[(Subscript[S, 3])]

m[inv[3],2,3]

G

Table[m[i,j],{i,n},{j,n}]//MatrixForm

Defining WG

Basis[]={1};
Basis[i_,is___]:=Flatten@Table[(Subscript[W, i])[α,β]Basis[is],{α,n},{β,n}]

Basis[]

Basis[j]

Basis[1,2]//Short

(Subscript[m, i_,j_->k_])[ℰ_]:=Expand[ℰ]/.(Subscript[W, i])[α_,β_](Subscript[W, j])[γ_,δ_]:>If[m[α,β]==m[β,γ],(Subscript[W, k])[α,m[β,δ]],0];
(Subscript[η, i_])[ℰ_]:=Expand[ℰ Sum[(Subscript[W, i])[α,m[]], {α,n}]];

(Subscript[Δ, i_->j_,k_])[ℰ_]:=Expand[ℰ/.(Subscript[W, i])[α_,β_]:>Sum[(Subscript[W, j])[γ,β](Subscript[W, k])[m[α,inv[γ]],β],{γ,n}]];
(Subscript[ε, i_])[ℰ_]:=Expand[ℰ/.(Subscript[W, i])[α_,β_]:>If[α==m[],1,0]];

(Subscript[S, i_])[ℰ_]:=Expand[ℰ/.(Subscript[W, i])[α_,β_]:>(Subscript[W, i])[m[inv[β],inv[α],β], inv[β]]];

(Subscript[R, i_,j_]):=Sum[(Subscript[W, i])[α,m[]](Subscript[W, j])[β,α], {α,n}, {β,n}];
(Subscript[(OverBar[R]), i_,j_]):=Sum[(Subscript[W, i])[α,m[]](Subscript[W, j])[β,inv@α], {α,n}, {β,n}];

Testing the Axioms of an IHOP+R

m is associative:

b=Basis[1,2,3]; (b//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))==(b//(Subscript[m, 2,3->2])//(Subscript[m, 1,2->1]))

b=Basis[1,2,3]

b=RandomChoice[Basis[1,2,3]]

(b//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))

(b//(Subscript[m, 2,3->2])//(Subscript[m, 1,2->1]))

b=Basis[1,2,3]

(b//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1]))

η is a unit:

b=Basis[1]; (b//(Subscript[η, 2])//(Subscript[m, 1,2->1]))==b==(b//(Subscript[η, 2])//(Subscript[m, 2,1->1]))

Δ is co-associative:

b=Basis[1]; (b //(Subscript[Δ, 1->1,2])//(Subscript[Δ, 2->2,3]))==(b//(Subscript[Δ, 1->1,3])//(Subscript[Δ, 1->1,2]))

ε is a co-unit:

b=Basis[1]; (b//(Subscript[Δ, 1->1,2])//(Subscript[ε, 2]))==b==(b//(Subscript[Δ, 1->2,1])//(Subscript[ε, 2]))

ε is an algebra morphism:

b=Basis[1,2]; (b//(Subscript[ε, 1])//(Subscript[ε, 2]))==(b//(Subscript[m, 1,2->1])//(Subscript[ε, 1]))

m is an algebra morphism:

b=Basis[1,3]; (b //(Subscript[Δ, 1->1,2])//(Subscript[Δ, 3->3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))==(b//(Subscript[m, 1,3->1])//(Subscript[Δ, 1->1,2]))

S is an algebra anti-morphism:

b=Basis[1,2]; (b//(Subscript[m, 1,2->1])//(Subscript[S, 1]))==(b//(Subscript[S, 1])//(Subscript[S, 2])//(Subscript[m, 2,1->1]))

S is a co-algebra anti-morphism:

b=Basis[1]; (b//(Subscript[S, 1])//(Subscript[Δ, 1->1,2]))==(b//(Subscript[Δ, 1->2,1])//(Subscript[S, 1])//(Subscript[S, 2]))

S is a convolution inverse of the identity:

b=Basis[1]; (b //(Subscript[Δ, 1->1,2])//(Subscript[S, 2])//(Subscript[m, 1,2->1]))==(b//(Subscript[ε, 1])//(Subscript[η, 1]))==(b //(Subscript[Δ, 1->1,2])//(Subscript[S, 1])//(Subscript[m, 1,2->1]))

S is involutive:

b=Basis[1]; (b//(Subscript[S, 1])//(Subscript[S, 1]))==b

Reidemeister 2:

((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))==(1//(Subscript[η, 1])//(Subscript[η, 2]))==((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 4,2->2]))

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,4])(Subscript[R, 5,6])//(Subscript[m, 1,5->1])//(Subscript[m, 2,6->2])//(Subscript[m, 3,4->3]))

Compatibility of R and (Δ,m):

{((Subscript[R, 1,3])//(Subscript[Δ, 1->1,2]) )==( (Subscript[R, 2,3])(Subscript[R, 1,4])//(Subscript[m, 3,4->3])), ((Subscript[R, 1,2])//(Subscript[Δ, 2->2,3]) )==( (Subscript[R, 0,2])(Subscript[R, 1,3])//(Subscript[m, 0,1->1]))}

Compatibility of R and ε:

{((Subscript[R, 1,2])//(Subscript[ε, 1]))==(1//(Subscript[η, 2])),((Subscript[R, 1,2])//(Subscript[ε, 2]))==(1//(Subscript[η, 1]))}

Compatibility of R and S:

((Subscript[R, 1,2])//(Subscript[S, 1]))==(Subscript[(OverBar[R]), 1,2])==((Subscript[R, 1,2])//(Subscript[S, 2]))

Does R1 hold?

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

The forgotten relation, R1’:

(Expand[(Subscript[R, 1,2])(Subscript[(OverBar[R]), 4,3])]//(Subscript[m, 1,2->1])//(Subscript[m, 1,3->1])//(Subscript[m, 1,4->1]))==(1//(Subscript[η, 1]))

Computing the Knot Invariant for (Subscript[S, 3])

??PositiveQ

Z1[K_]:=Z1[PD[K]];
Z1[pd_PD]:=Module[{z},
z=Expand[Times@@pd/.x:X[i_,j_,k_,l_]:>If[PositiveQ@x, (Subscript[R, l,i]),(Subscript[(OverBar[R]), j,i])]];
Do[z=z//(Subscript[m, 1,k->1]),{k,2,2Length@pd}];
z]

tab1=Table[K->Echo[Timing[Z1[K]]], {K,AllKnots[{3,5}]}]

Edge-vertex convention: an oriented edge carries the same label as the vertex ending it.

Z2[K_]:=Z2[PD@K];
Z2[pd_PD]:=Module[{z,done,st,c,mn,k},
z=1; done={};st=Range[2Length@pd];
Do[
z*=c/.X[i_,j_,_,l_]:>If[PositiveQ@c,mn={i,l}; (Subscript[R, l,i]),mn={i,j};(Subscript[(OverBar[R]), j,i])];
Do[
If[MemberQ[done, k+1],z=z//(Subscript[m, k,k+1->k]); st=st/.k+1->k];
If[MemberQ[done, k-1],z=z//(Subscript[m, st[[k-1]],k->st[[k-1]]]); st=st/.k->st[[k-1]]],
{k,mn}];
done=done⋃mn,
{c,List@@pd}];
z ]

tab2=Table[K->Echo[Timing[Z2[K]]], {K,AllKnots[{3,6}]}]

ThinPosition[K_]:=Module[{todo,done,pd,c},
todo=List@@PD@K; done={}; pd=PD[];
While[todo=!={},
AppendTo[pd,c=RandomChoice@MaximalBy[todo, Length[done⋂List@@#]&]];
todo=DeleteCases[todo, c];
done=done⋃List@@c];
pd
]

Z3[K_]:=Z2@ThinPosition@K;

tab3=Table[K->Echo[Timing[Z3[K]]], {K,AllKnots[{3,7}]}]

Computing the Knot Invariant for (Subscript[S, 4])

DeclareGroup[(Subscript[S, 4])];
Table[m[i,j],{i,n},{j,n}]//MatrixForm

Table[K->Echo[Timing[Z3[K]]], {K,AllKnots[{3,7}]}]

Computing the knot invariant for (Subscript[S, 4]) by summing over conjugacy classes

DeclareGroup[(Subscript[S, 4])];

ConjugacyClasses:=Module[{sea=Range@n,ccs={},cc},
While[Length@sea>0,
cc=Union[Table[m[inv[α],First@sea,α], {α,n}]];
AppendTo[ccs,cc];
sea=Complement[sea,cc];
]; ccs]

CC=ConjugacyClasses

(* $CIS is a Conjugation Invariant Set *)
(Subscript[R, i_,j_]):=Sum[(Subscript[W, i])[α,1](Subscript[W, j])[β,α], {α,$CIS}, {β,$CIS}];
(Subscript[(OverBar[R]), i_,j_]):=Sum[(Subscript[W, i])[α,1](Subscript[W, j])[β,inv@α], {α,$CIS}, {β,$CIS}];
(Subscript[η, i_])[ℰ_]:=Expand@Sum[ℰ (Subscript[W, i])[α,1], {α,$CIS}];

Reidemeister 2:

Table[
((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 2,4->2]))==(1//(Subscript[η, 1])//(Subscript[η, 2]))==((Subscript[R, 1,2])(Subscript[(OverBar[R]), 3,4])//(Subscript[m, 1,3->1])//(Subscript[m, 4,2->2])),
{$CIS, CC} ]

Reidemeister 3:

Table[
((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,4])(Subscript[R, 5,6])//(Subscript[m, 1,5->1])//(Subscript[m, 2,6->2])//(Subscript[m, 3,4->3])),
{$CIS, CC} ]

Z4[K_]:=Z4[PD@K];
Z4[pd_PD]:=Sum[
Module[{z,done,st,c,mn,k},
z=1; done={};st=Range[2Length@pd];
Do[
z*=c/.X[i_,j_,_,l_]:>If[PositiveQ@c,mn={i,l}; (Subscript[R, l,i]),mn={i,j};(Subscript[(OverBar[R]), j,i])];
Do[
If[MemberQ[done, k+1],z=z//(Subscript[m, k,k+1->k]); st=st/.k+1->k];
If[MemberQ[done, k-1],z=z//(Subscript[m, st[[k-1]],k->st[[k-1]]]); st=st/.k->st[[k-1]]],
{k,mn}];
done=done⋃mn,
{c,List@@pd}];
z ],
{$CIS, CC} ];
Z5[K_]:=Z4@ThinPosition@K;

Table[K->Echo[Timing[Z5[K]]], {K,AllKnots[{3,7}]}]

Computing the knot invariant for (Subscript[S, 5]) by summing over conjugacy classes

DeclareGroup[(Subscript[S, 5])];
CC=ConjugacyClasses

Table[K->Echo[Timing[Z5[K]]], {K,AllKnots[{3,7}]}]

Conclusion

A very elegant theory which we implemented cleanly and were able to improve dramatically.

Overall, a great failure.