Random knot on six vertices - MathOverflow most recent 30 from http://mathoverflow.net 2013-05-22T06:18:49Z http://mathoverflow.net/feeds/question/54919 http://www.creativecommons.org/licenses/by-nc/2.5/rdf http://mathoverflow.net/questions/54919/random-knot-on-six-vertices Random knot on six vertices David Hansen 2011-02-09T19:51:38Z 2011-02-10T11:12:40Z <p>This question is inspired by Joseph O'Rourke's <a href="http://mathoverflow.net/questions/54412/" rel="nofollow">beautiful question</a> 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 <a href="http://www.colab.sfu.ca/KnotPlot/sticknumbers/" rel="nofollow">known results</a> 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?</p> http://mathoverflow.net/questions/54919/random-knot-on-six-vertices/54967#54967 Answer by Joseph O'Rourke for Random knot on six vertices Joseph O'Rourke 2011-02-10T00:35:14Z 2011-02-10T00:35:14Z <p>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: <em>zero</em> trefoils, <em>ten</em> unknots. <br /> <img src="http://cs.smith.edu/~orourke/MathOverflow/Random6Knots.jpg" alt="Random Knots"></p> http://mathoverflow.net/questions/54919/random-knot-on-six-vertices/55008#55008 Answer by villemoes for Random knot on six vertices villemoes 2011-02-10T10:14:30Z 2011-02-10T10:14:30Z <p>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 <a href="http://rasmusvillemoes.dk/files/trefoil.zip" rel="nofollow">http://rasmusvillemoes.dk/files/trefoil.zip</a>, 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.</p> http://mathoverflow.net/questions/54919/random-knot-on-six-vertices/55011#55011 Answer by aorq for Random knot on six vertices aorq 2011-02-10T10:45:40Z 2011-02-10T11:12:40Z <p>I wrote a program in Mathematica to sample knots from this distribution and test what proportion are the trefoil knot.</p> <p>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 <a href="http://en.wikipedia.org/wiki/Fary%E2%80%93Milnor_theorem" rel="nofollow">Fary-Milnor theorem</a>: 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.</p> <p>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.</p> <p>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 <a href="http://en.wikipedia.org/wiki/Tricolorability" rel="nofollow">tricolorable</a>. 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.)</p> <p>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:</p> <p><img src="http://i.imgur.com/YvI93.png" alt="An HSV-colored trefoil"></p> <p>The code follows. As usual, beware of bugs.</p> <pre><code>(* 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 &lt;= halfintersecthelper[a, b, c, d] &lt;= 1 intersect[a_, b_, c_, d_] := halfintersect[a, b, c, d] &amp;&amp; halfintersect[c, d, a, b] nintshelper[cknot3_, frame_] := Module[{cknot2 = (project[#1, frame] &amp;) /@ cknot3}, Table[If[Abs[i - j] &gt; 1 &amp;&amp; Abs[i - j] != 5 &amp;&amp; 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]] &amp;) /@ Union[Select[Flatten[nintshelper[cknot3, frame], 1], #1[[3]] != 0 &amp;]] 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]] &gt; 0 (* Can this knot be tricolored? *) vars[seq_] := x /@ Range@Length@seq domains[xs_] := And @@ (#1 == 0 || #1 == 1 || #1 == 2 &amp;) /@ 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]] &amp;) /@ seq] overname[seq_, n_] := x@First@Flatten[Position[seq, {+1, n}, {1}, Heads -&gt; False]] undername1[seq_, n_] := x@First@Flatten[Position[seq, {-1, n}, {1}, Heads -&gt; False]] undername2[seq_, n_] := x[1 + Mod[First@Flatten[Position[seq, {-1, n}, {1}, Heads -&gt; False]], Length[seq]]] overunder[seq_, n_] := Mod[overname[seq, n] + undername1[seq, n] + undername2[seq, n], 3] == 0 overunders[seq_] := And @@ (overunder[seq, #1] &amp;) /@ names@seq conditions[seq_] := domains[vars@seq] &amp;&amp; overs@seq &amp;&amp; overunders@seq &amp;&amp; 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 &lt;= trials, i++, k = close[randknot[]]; (* Angles *) pgood = If[curvature[k] &gt;= 4 Pi, 0, -1]; (* Projections *) projn = 20; projj = 0; For[j = 1, j &lt;= nframes &amp;&amp; pgood == 0, j++, crossings = nints[k, frames[[j]] ]; ncrossings = Length@crossings/2; If[ncrossings &lt; 3, pgood = -1]; If[ncrossings &lt; projn, projn = ncrossings; projj = j]; ]; If[pgood == 0, crossings = nints[k, frames[[projj]]]; pgood = If[tricolor@crossings != {}, +1, -1];]; (* Record *) If[pgood == +1 &amp;&amp; count == 0, testk = k; testf = frames[[projj]]]; If[pgood == +1, count++]; ]; overalltrials += trials; overallcount += count; ] overallcount overalltrials overallcount / overalltrials * 100. (* Draw a trefoil knot found by the random trials *) nints[testk, testf] // MatrixForm pk = Map[project[#, testf] &amp;, testk ] Graphics3D[{Thickness[0.02], Opacity[1], Specularity[White, 50], Line[testk, VertexColors -&gt; {Red, Yellow, Green, Cyan, Blue, Purple, Red}]}, Axes -&gt; False, PlotRange -&gt; All, Boxed -&gt; False] </code></pre>