Guest User

Finding right triangles in random points

a guest
Apr 5th, 2017
158
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. n = 12; (* How many points *)
  2. pts = Table[RandomReal[], {n}, {2}];
  3. Show[
  4. Graphics[{Red, PointSize[0.01], Point[pts]}],
  5. ImageSize -> 8*72, PlotRange -> {{0, 1}, {0, 1}}, Frame -> True,
  6. FrameTicks -> False
  7. ]
  8.  
  9. \[Theta]min = 89.0; (* Range of angles to be considered "right" (in \
  10. degrees) *)
  11. \[Theta]max = 91.0;
  12. RightAngles = {};
  13. Do[(
  14. ptA = pts[[i]];
  15. ptB = pts[[j]];
  16. ptC = pts[[k]];
  17.  
  18. a = Norm[ptB - ptC];
  19. b = Norm[ptA - ptC];
  20. c = Norm[ptA - ptB];
  21.  
  22. AngleA = 180/\[Pi] ArcCos[(b^2 + c^2 - a^2)/(2 b c)];
  23. If[\[Theta]min <=
  24. AngleA <= \[Theta]max, (AppendTo[RightAngles, {ptA, ptB, ptC}];
  25. Continue[];)];
  26. AngleB = 180/\[Pi] ArcCos[(a^2 + c^2 - b^2)/(2 a c)];
  27. If[\[Theta]min <=
  28. AngleB <= \[Theta]max, (AppendTo[RightAngles, {ptA, ptB, ptC}];
  29. Continue[];)];
  30. AngleC = 180/\[Pi] ArcCos[(a^2 + b^2 - c^2)/(2 a b)];
  31. If[\[Theta]min <= AngleC <= \[Theta]max,
  32. AppendTo[RightAngles, {ptA, ptB, ptC}]];
  33. ), {i, 1, n - 2}, {j, i + 1, n - 1}, {k, j + 1, n}]
  34.  
  35. RightAngles (* Print the list of triples of vertices that form \
  36. "right-ish" triangles *)
  37. RightAngles // Length (* And how many there are *)
  38.  
  39. (* Show the "right" triangles overlaid over the random points *)
  40. Show[
  41. Graphics[{Red, PointSize[0.02], Point[pts]}],
  42. Table[Graphics[{Thick, Hue[i/Length[RightAngles]],
  43. Line[{RightAngles[[i, 1]], RightAngles[[i, 2]],
  44. RightAngles[[i, 3]], RightAngles[[i, 1]]}]}], {i, 1,
  45. Length[RightAngles]}],
  46. ImageSize -> 8*72, Frame -> True, FrameTicks -> False,
  47. PlotRange -> {{0, 1}, {0, 1}}
  48. ]
  49.  
  50. (* Create the list of unique side lengths in this set of triangles *)
  51.  
  52.  
  53. lengths = {};
  54. Do[(
  55. AppendTo[lengths, Norm[RightAngles[[i, 1]] - RightAngles[[i, 2]]]];
  56. AppendTo[lengths, Norm[RightAngles[[i, 1]] - RightAngles[[i, 3]]]];
  57. AppendTo[lengths, Norm[RightAngles[[i, 2]] - RightAngles[[i, 3]]]];
  58. ), {i, 1, Length[RightAngles]}];
  59. lengths = Union[lengths, lengths];
  60.  
  61. (* Here is a set of "special" numbers to search for in ratios of \
  62. these lengths, along with their reciprocals *)
  63. nums = {\[Pi], E, EulerGamma, GoldenRatio, Sqrt[2], Sqrt[3], Sqrt[5],
  64. Sqrt[6], Sqrt[7], Sqrt[8], Sqrt[10]};
  65.  
  66. (* Make a list of of side length ratios that "match" the above set of \
  67. special numbers *)
  68. f = 0.01; (* What fractional deviation from the "special" numbers is \
  69. acceptable *)
  70. Specials = {};
  71. Do[(
  72. r = lengths[[i]]/lengths[[j]];
  73. Do[(
  74. x = nums[[k]];
  75. If[Abs[(r - x)/x] <= f,
  76. AppendTo[
  77. Specials, {lengths[[i]], lengths[[j]], r, x, Abs[(r - x)/x]}]];
  78. If[Abs[(r - (1/x))/(1/x)] <= f,
  79. AppendTo[
  80. Specials, {lengths[[i]], lengths[[j]], r, 1/x,
  81. Abs[(r - (1/x))/(1/x)]}]];
  82. ), {k, 1, Length[nums]}]
  83. ), {i, 1, Length[lengths]}, {j, 1, Length[lengths]}];
  84.  
  85. Specials (* Print the list of "special" side length relationships and \
  86. how accurate they are *)
  87. Specials // Length
RAW Paste Data