how to do this unusual pendovan spriral? can anyone help me ?
$\begingroup$
$\endgroup$
-
$\begingroup$ What have you tried? $\endgroup$ – David G. Stork May 5 '19 at 3:16
-
3$\begingroup$ There is this very graphic as a demo in the Wolfram Demonstrations Project $\endgroup$ – ciao May 5 '19 at 8:07
$\begingroup$
$\endgroup$
You can do this rather nicely with GeometricScene.
scene = GeometricScene[
{a, b, c, d, e, f, g, h, i, j, k, l, m, n},
{RegularPolygon[{a, b, c}], RegularPolygon[{b, d, c}],
RegularPolygon[{b, e, d}],
RegularPolygon[{a, f, e}], RegularPolygon[{f, g, e}],
RegularPolygon[{g, h, d}],
RegularPolygon[{c, h, i}],
RegularPolygon[{a, i, j}],
RegularPolygon[{f, j, k}],
RegularPolygon[{k, l, g}],
RegularPolygon[{l, m, h}],
RegularPolygon[{m, n, i}],
GeometricAssertion[{{a, b, c}, {b, d, c}, {b, e, d}, {a, f, e}, {f,
g, e}, {g, h, d}, {c, h, i}, {a, i, j}, {f, j, k}, {k, l,
g}, {l, m, h}, {m, n, i}}, "Clockwise"]
}
]
RandomInstance[scene]
We can use Style to colour the triangles:
GeometricScene[{a, b, c, d, e, f, g, h, i, j, k, l, m, n},
{Style[RegularPolygon[{a, b, c}], White],
Style[RegularPolygon[{b, d, c}], LightBlue],
Style[RegularPolygon[{b, e, d}], White],
Style[RegularPolygon[{a, f, e}], LightBlue],
Style[RegularPolygon[{f, g, e}], White],
Style[RegularPolygon[{g, h, d}], LightBlue],
Style[RegularPolygon[{c, h, i}], White],
Style[RegularPolygon[{a, i, j}], LightBlue],
Style[RegularPolygon[{f, j, k}], White],
Style[RegularPolygon[{k, l, g}], LightBlue],
Style[RegularPolygon[{l, m, h}], White],
Style[RegularPolygon[{m, n, i}], LightBlue],
GeometricAssertion[{{a, b, c}, {b, d, c}, {b, e, d}, {a, f, e}, {f,
g, e}, {g, h, d}, {c, h, i}, {a, i, j}, {f, j, k}, {k, l,
g}, {l, m, h}, {m, n, i}}, "Clockwise"]
}
] // RandomInstance
Now, because this is a full geometric solver, we can assign the Area of each triangle to a variable, and set the area of the smallest triangles (the centre pieces) to 1, and we can see that the area of each subsequent triangle is the square of its spiral position:
scene = GeometricScene[{{a, b, c, d, e, f, g, h, i, j, k, l, m,
n}, {ar1, ar2, ar3, ar4, ar5, ar7, ar9, ar12, ar16}},
{Area@RegularPolygon[{a, b, c}] == Area@RegularPolygon[{b, d, c}] ==
Area@RegularPolygon[{b, e, d}] == ar1 == 1,
Area@RegularPolygon[{a, f, e}] == Area@RegularPolygon[{f, g, e}] ==
ar2,
Area@RegularPolygon[{g, h, d}] == ar3,
Area@RegularPolygon[{c, h, i}] == ar4,
Area@RegularPolygon[{a, i, j}] == ar5,
Area@RegularPolygon[{f, j, k}] == ar7,
Area@RegularPolygon[{k, l, g}] == ar9,
Area@RegularPolygon[{l, m, h}] == ar12,
Area@RegularPolygon[{m, n, i}] == ar16,
GeometricAssertion[{{a, b, c}, {b, d, c}, {b, e, d}, {a, f, e}, {f,
g, e}, {g, h, d}, {c, h, i}, {a, i, j}, {f, j, k}, {k, l,
g}, {l, m, h}, {m, n, i}}, "Clockwise"]
}
]
inst = RandomInstance[scene]
inst["Quantities"][[13 ;; 21]]
{ar1 -> 1., ar2 -> 4., ar3 -> -9., ar4 -> 16., ar5 -> 25., ar7 -> -49., ar9 -> 81., ar12 -> 144., ar16 -> 256.}
(I am assuming that the negative values occur because the origin is the first point of the centre triangle, but I haven't tested.)
If we are patient enough, we can use FindGeometricConjectures to find out more interesting conjectures about our scene - for instance, that 3 sets of lines are necessarily parallel (each side of each triangle).
-
1$\begingroup$ I like this approach very much, and am very enthusiastic about MMA12's new synthetic geometry tools (which it should be noted are in experimental release in MMA 12.0.0 and 12.0.1). I'm going to have to study the conclusions generated for this scene carefully; I've noted that as the complexity of the scene increases, FindGeometricConjectures often fails to notice regular polygons, then perpendicular and parallel relationships, among other oddities. Synthetic geometry is a really good way to push the bulk of the computational effort on the computer, with the human providing an abstract scene. $\endgroup$ – Bert Sierra Dec 15 '19 at 3:24
$\begingroup$
$\endgroup$
** THIS IS AN EXTENDED COMMENT RATHER THAN AN ANSWER **
As a start, you can find the size of the nth triangle using FindSequenceFunction
seq = {1, 1, 1, 2, 2, 3, 4, 5, 7, 9, 12, 16};
f[n_] = FindSequenceFunction[seq, n]
The result is expressed as Root objects. To convert to radicals with ToRadicals,
f2[n_] = f[n] // ToRadicals // Simplify
seq2 = f /@ Range[16] // RootReduce
(* {1, 1, 1, 2, 2, 3, 4, 5, 7, 9, 12, 16, 21, 28, 37, 49} *)
seq2 == f2 /@ Range[16] // FullSimplify
(* True *)
As expected, both forms give the same result. Plotting,
DiscretePlot[f[n], {n, 1, 16}]
Alternatively, using RSolve
f3[n_] = a[n] /.
RSolve[{a[n] == a[n - 2] + a[n - 3], a[1] == 1, a[2] == 1, a[3] == 1},
a[n], n][[1]]
$\begingroup$
$\endgroup$
Below is my (not quite right) attempt. However, now that we've seen the Wolfram demo link, I think that their code will be more helpful.
nextTriangle[oppositept_, firstedge_] := Module[{f = firstedge, p},
p = {{(f[[1, 1]] + f[[2, 1]] + Sqrt[3.] (f[[1, 2]] - f[[2, 2]]))/2,
(f[[1, 2]] + f[[2, 2]] - Sqrt[3.] (f[[1, 1]] - f[[2, 1]]))/2},
{(f[[1, 1]] + f[[2, 1]] - Sqrt[3.] (f[[1, 2]] - f[[2, 2]]))/2,
(f[[1, 2]] + f[[2, 2]] + Sqrt[3.] (f[[1, 1]] - f[[2, 1]]))/2}};
{firstedge[[1]], firstedge[[2]],
Chop[First[Sort[p, EuclideanDistance[#1, oppositept] > EuclideanDistance[#2, oppositept] &]]]}
]
n = 12;
triangles = {{{0, Sqrt[3.]}, {-1, 0}, {1, 0}}};
Do[{
t = Last[triangles];
nextedge = t[[{1, 3}]];
edgefit = Fit[nextedge, {1, x}, x];
allpts = Flatten[triangles, 1];
colinearpos = Boole[Chop[edgefit /. x -> #[[1]]] == #[[2]] & /@ allpts];
colinearpts = Cases[Transpose[{allpts, colinearpos}], {x_, 1} -> x];
line = {First[Sort[colinearpts, EuclideanDistance[#1, t[[3]]] > EuclideanDistance[#2, t[[3]]] &]], t[[3]]};
nextt = nextTriangle[t[[2]], line];
AppendTo[triangles, nextt];
}, {i, 1, n - 1}]
Graphics[Table[{If[EvenQ[n], LightBlue, White], EdgeForm[Thin],
Polygon[triangles[[n]]]}, {n, 1, Length[triangles]}]]
