# Finding right triangles in random points

a guest
Apr 5th, 2017
221
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