How to do this Padovan spiral using Mathematica?

Question

How to do this unusual Padovan spiral? Can anyone help me?

Answer 1

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

Answer 2

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

Answer 3

THIS IS AN EXTENDED COMMENT RATHER THAN AN ANSWER

As a start, you can find the size of the $n$-th 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 in terms of Root objects. To convert to radicals, use 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]]

Answer 4

I'm a little late, but this can be done very simply with FoldList[], with no need for fancy stuff like GeometricScene[]:

padovan = DifferenceRoot[Function[{y, n}, {y[n] == y[n - 2] + y[n - 3],
                                           y[0] == 1, y[1] == 1, y[2] == 1}]];

With[{n = 11}, 
     Graphics[{EdgeForm[Black], 
               Riffle[FoldList[With[{c = #[[1, 1, 3]],
                                     h = Normalize[#[[1, 1, 2]] - #[[1, 1, 3]]]},
                                    {Polygon[{c, c + #2 h,
                                              c + #2 h/2 + Sqrt[3] #2 Cross[h]/2}], 
                                     Text[Style[IntegerString[#2], Bold, 12], 
                                          c + #2 h/2 + #2 Cross[h]/(2 Sqrt[3])]}] &,
                               {Polygon[{{1/2, Sqrt[3]/2}, {0, 0}, {1, 0}} // N], 
                                Text[Style["1", Bold, 12], {1/2, 1/(2 Sqrt[3])} // N]}, 
                               padovan[Range[n]]], 
                      FaceForm /@ {White, RGBColor["#BBDFE3"]}, {1, -2, 2}]}]]

Of course, you can extend this; here e.g. is what you get for n = 18:

Answer 5

A simple method(天一):

l = AnglePath[{{1/2, Sqrt[3]/2}, 0}, 
  Transpose@{{1, 1, 1, 2, 2, 3, 4, 5, 7, 9, 12, 16}, 
    Table[-Pi/3, 12]}]; {Line /@ 
   Transpose[{l, Table[{0, 0}, 4]~Join~(l[[1 ;; -5]])}], 
  Line[l]} // Graphics