# Random knot on six vertices

This question is inspired by Joseph O'Rourke's beautiful question on random knots. Choose an random ordered 6-tuple of points on the unit sphere in $\mathbf{R}^3$, and form a knot by connecting successive pairs of points in the 6-tuple by sticks (see the picture at Joseph's question). By known results on stick numbers, the resulting knot will either be the unknot or the trefoil knot. What is the probability of producing one or the other?

-

I wrote a program in Mathematica to sample knots from this distribution and test what proportion are the trefoil knot.

In order to tell if a given knot is the unknot or the trefoil, the program first checks the total curvature of the knot and applies the Fary-Milnor theorem: if the curvature is less than $4 \pi$, then it's the unknot. Half the time, this test identifies the unknot. I think it should be possible to compute the exact probability of the curvature being too small.

Next, the program projects the knot onto 100 random planes. If any of these projections has less than 3 crossings, then we are again considering the unknot. This test eliminates all but ~1% of cases.

Finally, if we're still not done, the program takes the projection with the least number of crossings and checks if the resulting knot diagram is tricolorable. Usually this diagram has three crossings and this test might be a bit of a sledgehammer, but this test completely distinguishes the unknot from the trefoil. (I don't use this test first because my implementation is very slow.)

In a test run of 10,000 random knots, 68 knots were determined to be the trefoil. The computation took about 12 minutes. Here's one of the trefoils it found:

The code follows. As usual, beware of bugs.

(* Random points, projections, those sorts of things *)
randsph[] := Normalize@Table[RandomVariate@NormalDistribution[], {3}]
randknot[] := Table[randsph[], {6}]
close[x_] := Join[x, {First[x]}]
project[ x_, frame_ ] := Flatten[frame[[2 ;; 3]] . Transpose[ {x} ]]
framify[x_] := Orthogonalize@{x, randsph[], randsph[]}
rotate[{x_, y_}] := {-y, x}
halfintersecthelper[a_, b_, c_,
d_] := (a - c) . rotate[b - a] / ((d - c) . rotate[b - a])
halfintersect[a_, b_, c_, d_] :=
0 <= halfintersecthelper[a, b, c, d] <= 1
intersect[a_, b_, c_, d_] :=
halfintersect[a, b, c, d] && halfintersect[c, d, a, b]
nintshelper[cknot3_, frame_] :=
Module[{cknot2 = (project[#1, frame] &) /@ cknot3},
Table[If[Abs[i - j] > 1 && Abs[i - j] != 5 &&
intersect[cknot2[[i]], cknot2[[i + 1]], cknot2[[j]],
cknot2[[j + 1]]], {i,
halfintersecthelper[cknot2[[j]], cknot2[[j + 1]], cknot2[[i]],
cknot2[[i + 1]]],
If[over[cknot3[[i]], cknot3[[i + 1]], cknot3[[j]],
cknot3[[j + 1]], frame], +1, -1], {Min[i, j], Max[i, j]}}, {0,
0, 0, 0}], {i, 1, 6}, {j, 1, 6}]]
nints[cknot3_, frame_] := (#1[[3 ;; 4]] &) /@
Union[Select[Flatten[nintshelper[cknot3, frame], 1], #1[[3]] != 0 &]]
curvature[cknot3_] :=
Total@Table[
VectorAngle[cknot3[[i + 1]] - cknot3[[i]],
cknot3[[1 + Mod[i + 1, 6]]] - cknot3[[i + 1]]], {i, 1, 6}]
overhelper[a_, b_, c_, d_] := (b - a)\[Cross](d - c)
over[a_, b_, c_, d_, frame_] :=
overhelper[a, b, c, d].(c - a) overhelper[a, b, c, d].frame[[1]] > 0

(* Can this knot be tricolored? *)
vars[seq_] := x /@ Range@Length@seq
domains[xs_] := And @@ (#1 == 0 || #1 == 1 || #1 == 2 &) /@ xs
nonconstant[seq_] := !
And @@ Table[x[i] == x[i + 1], {i, 1, Length[seq] - 1}]
overs[seq_] :=
And @@ Module[{n = Length[seq]},
Table[If[seq[[i, 1]] == +1, x[i] == x[1 + Mod[i, n]], True], {i, 1,
n}]]
names[seq_] := Union[(#1[[2]] &) /@ seq]
overname[seq_, n_] :=
x@First@Flatten[Position[seq, {+1, n}, {1}, Heads -> False]]
undername1[seq_, n_] :=
x@First@Flatten[Position[seq, {-1, n}, {1}, Heads -> False]]
undername2[seq_, n_] :=
x[1 + Mod[First@Flatten[Position[seq, {-1, n}, {1}, Heads -> False]],
Length[seq]]]
overunder[seq_, n_] :=
Mod[overname[seq, n] + undername1[seq, n] + undername2[seq, n],
3] == 0
overunders[seq_] := And @@ (overunder[seq, #1] &) /@ names@seq
conditions[seq_] :=
domains[vars@seq] && overs@seq && overunders@seq && nonconstant@seq
tricolor[seq_] := FindInstance[conditions@seq, vars@seq]

(* Init *)
overalltrials = 0;
overallcount = 0;

(* Random trials! *)
First@
Timing@Module[{trials = 10000, nframes = 100, count = 0, frames, i,
j, k, crossings, ncrossings, pgood, projn, projj},
frames = framify /@ Table[randsph[], {nframes}];
For[i = 1, i <= trials, i++,
k = close[randknot[]];
(* Angles *)
pgood = If[curvature[k] >= 4 Pi, 0, -1];
(* Projections *)
projn = 20;
projj = 0;
For[j = 1, j <= nframes && pgood == 0, j++,
crossings = nints[k, frames[[j]] ];
ncrossings = Length@crossings/2;
If[ncrossings < 3, pgood = -1];
If[ncrossings < projn, projn = ncrossings; projj = j];
];
If[pgood == 0, crossings = nints[k, frames[[projj]]];
pgood = If[tricolor@crossings != {}, +1, -1];];
(* Record *)
If[pgood == +1 && count == 0, testk = k;
testf = frames[[projj]]];
If[pgood == +1, count++];
];
overalltrials += trials;
overallcount += count;
]
overallcount
overalltrials
overallcount / overalltrials * 100.

nints[testk, testf] // MatrixForm
pk = Map[project[#, testf] &, testk ]
Graphics3D[{Thickness[0.02], Opacity[1], Specularity[White, 50],
Line[testk, VertexColors -> {Red, Yellow, Green, Cyan, Blue, Purple,
Red}]}, Axes -> False, PlotRange -> All, Boxed -> False]

-
Fun fact: the expected total curvature is exactly $4\pi$! –  aorq Feb 10 '11 at 12:15
Bravo! $\mbox{}$ –  Joseph O'Rourke Feb 10 '11 at 15:32
Wow, thanks very much! This is wonderful data. –  David Hansen Feb 10 '11 at 18:25

I like the specificity of this question! Just by hand (I don't have this automated), I generated ten random examples, and simply rotated the sphere to an orientation from which I could see whether the hexagon forms the unknot. Although the images below may not be convincing, it is not difficult to make this determination visually at full resolution. The result for these ten random trials: zero trefoils, ten unknots.

-
Interesting! How many trials would you be willing to do? :P –  David Hansen Feb 10 '11 at 0:59
If you will teach my classes tomorrow ... :-) –  Joseph O'Rourke Feb 10 '11 at 1:07

I hacked a small metapost script which generates planar projections of random diagrams. It's far from perfect, but after dismissing a couple of hundred examples, I would be extremely surprised if the probability of getting a trefoil is anything but 0. You can download 1000 examples from http://rasmusvillemoes.dk/files/trefoil.zip, along with the (ugly) metapost code. I didn't put a lot of effort into the logic behind drawing/removing parts of strands near intersections, but the information in the .txt files can help resolve ambiguities. The two lines "Along segment 1: // (-1, 0.4816) [3]" means that roughly halfway along segment number 1, we meet segment 3 and pass under it. (The first part of strand 0 is colored red; this determines the order uniquely.) I suppose one could trivially sort these lines according to the time (second) coordinate, and then look for alternating signs, but I don't know if a 6-stick diagram of the trefoil is necessarily alternating.

-
I don't think the probability of a trefoil can be zero, because (a) one can build a trefoil out of six segments, and (b) there are neighborhoods on the sphere surface around each of the six vertices where the hexagon remains a trefoil. So there must be a positive-volume portion of the configuration space that includes trefoils. –  Joseph O'Rourke Feb 10 '11 at 11:00
@Joseph: Thanks. It seems so obvious now. I guess that will teach me not to make conjectures in the middle of the night based on very little numerical evidence... –  villemoes Feb 10 '11 at 18:22
I really like your pictures. The trefoil knots in your collection are numbered 538, 649, and 887. It's hard to see on the latter two, but 538 is clear. –  aorq Feb 11 '11 at 13:34