[GIF] Recursive Complete Graph

Posted 9 months ago
1975 Views
|
4 Replies
|
9 Total Likes
|
 The rule is simple: Start with n-points in any arbitrary configuration. Connect every point to every other point with a line. Draw a point where any new intersections occur. These intersections become your initial set of points for the next iteration. Repeat the process. I only took it 3 iterations because render time blows up, but it looks like it approaches a particular figure as # of iterations -> infinity. We may suspect that different sets of initial points yield a converging image, while others do not converge. Much like a geometric series. Here is a closer look at the 3rd iteration:We could also keep the points from previous iterations, yielding something more like this:The code is not super clean, did a lot of manual stuff. pts0 = N[CirclePoints[6]]; lines = Subsets[pts2, {2}]; threshold = 0.0000000001; lul = {}; Monitor[ Do[ p = Quiet[ Position[lul, t_ /; (RegionDistance[InfiniteLine[lines[[i]]], t[[1]]] < threshold && RegionDistance[InfiniteLine[lines[[i]]], t[[2]]] < threshold)]]; Quiet[If[MatchQ[p, {}], AppendTo[lul, lines[[i]]], Set[lul, ReplacePart[lul, p[[1]][[1]] -> Flatten[MaximalBy[{lines[[i]], lul[[p[[1]][[1]]]]}, EuclideanDistance[#[[1]], #[[2]]] &, 1], 1]]]]] Clear[p]; , {i, 1, Length[lines]}] , {i, Length[lul]}] longestUniqueLines=lul; intersectionpoints = Monitor[ DeleteDuplicates[ Flatten[ Table[ If[MatchQ[ RegionIntersection[Line[longestUniqueLines[[i]]], Line[longestUniqueLines[[ j]]]], _EmptyRegion] \[Or] (RegionDistance[ Line[longestUniqueLines[[i]]], longestUniqueLines[[j]][[1]]] < threshold) \[Or] (RegionDistance[Line[longestUniqueLines[[i]]], longestUniqueLines[[j]][[2]]] < threshold) \[Or] (RegionDistance[Line[longestUniqueLines[[j]]], longestUniqueLines[[i]][[1]]] < threshold) \[Or] (RegionDistance[Line[longestUniqueLines[[j]]], longestUniqueLines[[i]][[2]]] < threshold) , Nothing, Flatten[RegionIntersection[Line[longestUniqueLines[[i]]], Line[longestUniqueLines[[j]]]][[1]]] ], {i, Length[longestUniqueLines]}, {j, Delete[Range[Length[longestUniqueLines]], Table[{q}, {q, i}]]}] , 1] , Abs[#1[[1]] - #2[[1]]] < threshold \[And] Abs[#1[[2]] - #2[[2]]] < threshold &]; , {i, j}] 
4 Replies
Sort By:
Posted 9 months ago
 Excellent! Any statistics on the number of crossings/points after n iterations?
Posted 9 months ago
 Yes, those would be interesting sequences. For this example, the number of points at each iteration is: 6, 13, 288, ??But due to it's symmetry, some intersections are shared. For 6 random initial points, the number of intersections will vary depending on the position of the points. But the maximum number appears to be: 6, 15, 774, ??For 5 random initial points, the maximum number appears to be: 5, 5, 5, 5, ....For 7 random initial points, the maximum number appears to be: 7, 35, ?? ....It is worth noting that 5 is the lowest number of initial points which will actually create a continuing pattern (just a star within a star within a star, forever). Anything less will fizzle out at the 2nd iteration. 6 is the lowest number which creates a rich pattern. If we keep points from previous iterations, 5 is lowest number which will create a rich pattern. The sequence for this one is: 5, 10, 26, 741, ?? (That's for 5 equally-spaced circle points as our initial points. For 5 random points, the sequence is different)Also worth noting that we are only in 2d here. Would be interesting to explore limit cases as the number of points and number of dimensions -> infinity.Also, fun speculation: once we apply deep learning / neural networks to deep math, we might be able to accurately "guess" the next iteration without having to perform every calculation. Attachments: