Pensieve header: A program to enumerate w-knots.

SetDirectory["C:\\drorbn\\AcademicPensieve\\2015-03"]

A_List∖B_List := Complement[A,B];

Draw[w_wLDiag|w_wCDiag] := Module[{n,w1},
n=Length[w];
w1=Abs/@w;
Graphics[{
Line[{{0,0},{n+1,0}}],
Table[
{
Arrow[BezierCurve[{{w1[[j]]-0.5,0},{(w1[[j]]+j-0.5)/2, 0.5Abs[j-w1[[j]]+0.5]},{j,0}}]],
Text[If[w[[j]]>0, "+", "-"], {j,-0.1}],
Text[w1[[j]], {w1[[j]]-0.5,-0.1}]
},
{j,n}
]
}]
];
Draw[expr_] := expr /. w_wLDiag|w_wCDiag :> Draw[w]

Draw[wLDiag[3,1]]

AllLinearDiagrams[n_] := Flatten@Table[
wLDiag@@@Tuples[Range[k+1]⋃(-Range[k+1]), k],
{k,0,n}
]

AllLinearDiagrams[2]

wCDiag /: RotateLeft[w_wCDiag] := Module[{n},
n=Length[w];
wCDiag@@(RotateLeft[List@@w] /. j_Integer :> Which[
j==1, n,
j==-1, -n,
j>1, j-1,
j<-1, j+1
])
]

RotateLeft[wCDiag[-3,1,3,-2]]

RotateToMinimal[w_wCDiag]:= RotateToMinimal[w] = Module[
{bestw=w,rotatedw=RotateLeft[w]},
While[rotatedw=!=w,
bestw=First[Sort[{bestw,rotatedw}]];
rotatedw=RotateLeft[rotatedw]
];
bestw
];

wDiag[5,2,-1,-2] // RotateToMinimal

wCDiag[w_wLDiag] := Module[{n},
n=Length[w];
RotateToMinimal[wCDiag@@w /. {n+1 -> 1, -n-1->-1}]
]

AllCircularDiagrams[n_] := AllCircularDiagrams[n] = Union[RotateToMinimal/@ Flatten@Table[
wCDiag@@@Tuples[Range[k]⋃(-Range[k]), k],
{k,0,n}
]]

AllCircularDiagrams[2]

RemoveR1[w_wLDiag] := RemoveR1[w] = Module[{j,k=0},
Do[If[MemberQ[{j,j+1}, Abs[w[[j]]]], k=j], {j,Length[w]}];
If[k==0, w,
Delete[w,k] /. j_Integer  /; Abs[j]>k :> Sign[j](Abs[j]-1)
]
]

RemoveR1[wLDiag[-4,1,3,-4]]

RemoveR1 /@AllLinearDiagrams[2]

RemoveR1[wCDiag[]]=wCDiag[];
RemoveR1[w_wCDiag] := RemoveR1[w] = Module[{n,j,k=0},
n=Length[w];
Do[If[MemberQ[{j,j+1}, Abs[w[[j]]]], k=j], {j,n-1}];
If[k!=0,
Delete[w,k] /. j_Integer  /; Abs[j]>k :> Sign[j](Abs[j]-1),
(*else*) If[!MemberQ[{1,n}, Abs[Last[w]]],w,
Drop[w,-1] /. {n->1, -n->-1}]
]
]

RemoveR1 /@AllCircularDiagrams[2]

RemoveR1s[w_wLDiag|w_wCDiag] := RemoveR1s[w] = FixedPoint[RemoveR1, w]

RemoveR1s /@AllLinearDiagrams[2] // Union

RemoveR1s /@AllCircularDiagrams[4] // Union

RemoveR2[w_wLDiag] := RemoveR2[w] = Module[{j,k=0},
Do[If[w[[j]]+w[[j+1]]==0 && !MemberQ[Abs[List@@w],j+1], k=j], {j,Length[w]-1}];
If[k==0, w,
Delete[w,{{k}, {k+1}}] /. j_Integer  /; Abs[j]>k :> Sign[j](Abs[j]-2)
]
]

wLDiag[2,-2] // RemoveR2

RemoveR2 /@ AllLinearDiagrams[2]

AllLinearDiagrams[2]

Select[AllLinearDiagrams[2], (#=!= RemoveR2[#])&]

RemoveR2[w_wCDiag] /; Length[w]<2 := w;
RemoveR2[w_wCDiag] :=  RemoveR2[w] = Module[{n,j,k=0},
n=Length[w];
Do[If[w[[j]]+w[[j+1]]==0 && !MemberQ[Abs[List@@w],j+1], k=j], {j,n-1}];
If[k≠0,
Delete[w,{{k}, {k+1}}] /. j_Integer  /; Abs[j]>k :> Sign[j](Abs[j]-2) /. {n-1->1, 1-n->-1},
If[w[[1]]+w[[n]]==0 && !MemberQ[Abs[List@@w],1],
w[[2;;n-1]] /. j_Integer :> Sign[j](Abs[j]-1) /. {n-1->1, 1-n->-1},
(*else*) w
]
]
]

RemoveR12s[w_wLDiag|w_wCDiag] :=  RemoveR12s[w] = FixedPoint[RemoveR2[RemoveR1[#]]&, w]

Union[RemoveR12s /@ AllCircularDiagrams[4]] // Draw

RF[w_wCDiag] := RF[w] = RotateToMinimal[RemoveR12s[w]];
RF[w_wLDiag] := RemoveR12s[w];

Union[RF /@ AllCircularDiagrams[4]]//Draw

wLDiag /: Resolve[wLDiag[R3[top_,mid_,bot_,s1_,s2_,s3_], ts__]] := UndirectedEdge[
RF@ReplacePart[wLDiag@ts, {bot+(1-s3)/2->s2 s3 top,bot+(1+s3)/2->s1 s3(mid+1), mid->s2 top}],
RF@ReplacePart[wLDiag@ts, {bot+(1-s3)/2->s1 s3 mid,bot+(1+s3)/2->s2 s3 top, mid->s2 top}]
];
wCDiag /: Resolve[wCDiag[R3[top_,mid_,bot_,s1_,s2_,s3_], ts__]] := (RF[wCDiag[#]])& /@ Resolve[wLDiag[R3[top,mid,bot,s1,s2,s3],ts]]

Resolve@wLDiag[R3[4,6,1,1,1,1], 0,0,+1,-3,+4,0,+5,-7] // Draw

Resolve@wCDiag[R3[4,6,1,1,1,1], 0,0,+1,-3,+4,0,+5,-7] // Draw

AllLinearR3s[n_] /; n<3 := {};
AllLinearR3s[n_] := Flatten@Table[
Prepend[
ReplacePart[wLDiag@@Table[0,{n}],Thread[Range[n]∖{bot,bot+1,mid}->#]],
R3[top,mid,bot,s1,s2,s3]
]& /@ Tuples[Range[-n-1,n+1]∖{-bot-1,0,bot+1}, n-3],
{bot, Range[n-1]}, {mid, Range[n]∖{bot, bot+1}}, {top, Range[n+1]∖{bot+1}},
{s1,{-1,1}}, {s2,{-1,1}}, {s3,{-1,1}}
];
AllCircularR3s[n_] /; n<3 := {};
AllCircularR3s[n_] := Flatten@Table[
Prepend[
ReplacePart[wCDiag@@Table[0,{n}],Thread[Range[n]∖{1,2,mid}->#]],
R3[top,mid,1,s1,s2,s3]
]& /@ Tuples[Range[-n,n]∖{-2,0,2}, n-3],
{mid, Range[n]∖{1,2}}, {top, Range[n]∖{2}},
{s1,{-1,1}}, {s2,{-1,1}}, {s3,{-1,1}}
];

Union[RF/@AllLinearDiagrams[4]]

n=3;
vs=Union[RF/@AllLinearDiagrams[n]];
es=Union[Resolve/@AllLinearR3s[n]] /. Thread[vs->Range[Length@vs]];
g=Graph[Range[Length@vs],es]

ConnectedComponents[g]

vs[[Flatten@ConnectedComponents[g]]]

wCDiag /@ vs[[Flatten@ConnectedComponents[g]]] // Union

Timing[n=5;
vs=Union[RF/@AllCircularDiagrams[n]];
es=Union[Resolve/@AllCircularR3s[n] /. w_wLDiag :> RF[wCDiag[w]]] /. Thread[vs->Range[Length@vs]];
g=Graph[Range[Length@vs],es]
]

vs[[Flatten@ConnectedComponents[g]]] // Length

Select[vs[[Flatten@ConnectedComponents[g]]], Length[#]==3&] // Length

Timing[n=6;
vs=Union[RF/@AllCircularDiagrams[n]];
es=Union[Resolve/@AllCircularR3s[n]] /. Thread[vs->Range[Length@vs]];
g=Graph[Range[Length@vs],es]
]

Select[vs[[Flatten@ConnectedComponents[g]]], Length[#]==4&] // Length

cc=ConnectedComponents[g];
Subgraph[g,cc[[1]]]

Subgraph[g,cc[[2]]]

Subgraph[g,cc[[1000]]]

Length@cc[[1]]

vs[[#]]& /@ FindShortestPath[g,cc[[1,1]],cc[[1,4649]]] // Draw

Select[Table[
First@MinimalBy[vs[[#]]& /@ c, Length],
{c,cc}
], Length[#]==3&] // Draw

Select[Table[
First@MinimalBy[vs[[#]]& /@ c, Length],
{c,cc}
], Length[#]==3&]

Position[vs,wCDiag[3,-1,-2]//RF]

Position[cc,3]

Position[vs[[#]]& /@ cc[[2]], wCDiag[-3,1,2]]

cc[[2,2]]

vs[[4]]

FindShortestPath[g,3,4]

vs[[20]]//Draw

Select[Table[
First@MinimalBy[vs[[#]]& /@ c, Length],
{c,cc}
], Length[#]==4&] // Draw

(Subscript[wK, 6])[4] = Select[Table[
First@MinimalBy[vs[[#]]& /@ c, Length],
{c,cc}
], Length[#]==4&]

(Subscript[wK, 7])[4]={wCDiag[-4,-4,1,2],wCDiag[-4,-4,-1,3],wCDiag[3,1,1,2],wCDiag[-4,-4,-2,-3],wCDiag[-4,1,2,2],wCDiag[-4,-4,2,-3],wCDiag[-3,4,1,2],wCDiag[-4,1,1,-2],wCDiag[-4,-4,1,3],wCDiag[-4,-4,1,-2],wCDiag[-4,1,1,3],wCDiag[-4,4,2,-2],wCDiag[-3,1,-1,3],wCDiag[-4,4,-2,2],wCDiag[-4,1,-2,3],wCDiag[4,1,2,3],wCDiag[-4,-1,-2,-3],wCDiag[-3,-4,-1,-2],wCDiag[3,4,1,2]}