6
$\begingroup$

enter image description here

how to do this unusual pendovan spriral? can anyone help me ?

$\endgroup$
17
$\begingroup$

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]

enter image description here

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

enter image description here

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).

enter image description here

$\endgroup$
6
$\begingroup$

** 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]

enter image description here

The result is expressed as Root objects. To convert to radicals with ToRadicals,

f2[n_] = f[n] // ToRadicals // Simplify

enter image description here

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}]

enter image description here

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]]

enter image description here

$\endgroup$
6
$\begingroup$

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]}]]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.