How to do this Padovan spiral using Mathematica?Area of Generalized Koch SnowflakeUlam's Spiral with Opperman's diagonals (quarter-squares)How can I shorten this code to rotate a line segment around its center?How can this image (optical illusion) be created with Mathematica?Can anyone re-produce this result related to the spectrum of Riemann Zeta using error term generated from MangoldtLambda?Is it possible to draw this figure using Mathematica?How to create this spikey in Mathematica?Drawing a figure showing an $n$-gon and its direction into trianglesEllipse - Weyl's law - MathematicaPentagonal spiral in MathematicaHow to use the Mathematica
Cuban Primes
Is Precocious Apprentice enough for Mystic Theurge?
multiline equation inside a matrix that is a part of multiline equation
Is there a method to separate iron from mercury?
Why are lawsuits between the President and Congress not automatically sent to the Supreme Court
How does this piece of code determine array size without using sizeof( )?
What is this rubber on gear cables
Why does string strummed with finger sound different from the one strummed with pick?
Why is the A380’s with-reversers stopping distance the same as its no-reversers stopping distance?
How can I make dummy text (like lipsum) grey?
Is there any deeper thematic meaning to the white horse that Arya finds in The Bells (S08E05)?
Why is vowel phonology represented in a trapezoid instead of a square?
Why use a retrograde orbit?
Physically unpleasant work environment
How to handle professionally if colleagues has referred his relative and asking to take easy while taking interview
Would it be fair to use 1d30 (instead of rolling 2d20 and taking the higher die) for advantage rolls?
Five Powers of Fives Produce Unique Pandigital Number...Solve for X..Tell me Y
Pedaling at different gear ratios on flat terrain: what's the point?
Cycling to work - 30mile return
Why does Taylor’s series “work”?
Square spiral in Mathematica
Canadian citizen who is presently in litigation with a US-based company
What are the effects of eating many berries from the Goodberry spell per day?
Solenoid fastest possible release - for how long should reversed polarity be applied?
How to do this Padovan spiral using Mathematica?
Area of Generalized Koch SnowflakeUlam's Spiral with Opperman's diagonals (quarter-squares)How can I shorten this code to rotate a line segment around its center?How can this image (optical illusion) be created with Mathematica?Can anyone re-produce this result related to the spectrum of Riemann Zeta using error term generated from MangoldtLambda?Is it possible to draw this figure using Mathematica?How to create this spikey in Mathematica?Drawing a figure showing an $n$-gon and its direction into trianglesEllipse - Weyl's law - MathematicaPentagonal spiral in MathematicaHow to use the Mathematica
$begingroup$
how to do this unusual pendovan spriral? can anyone help me ?
graphics geometry number-theory education
$endgroup$
add a comment |
$begingroup$
how to do this unusual pendovan spriral? can anyone help me ?
graphics geometry number-theory education
$endgroup$
$begingroup$
What have you tried?
$endgroup$
– David G. Stork
May 5 at 3:16
3
$begingroup$
There is this very graphic as a demo in the Wolfram Demonstrations Project
$endgroup$
– ciao
May 5 at 8:07
add a comment |
$begingroup$
how to do this unusual pendovan spriral? can anyone help me ?
graphics geometry number-theory education
$endgroup$
how to do this unusual pendovan spriral? can anyone help me ?
graphics geometry number-theory education
graphics geometry number-theory education
edited May 5 at 17:06
C. E.
51.9k3101208
51.9k3101208
asked May 5 at 2:35
pigeonpigeon
461
461
$begingroup$
What have you tried?
$endgroup$
– David G. Stork
May 5 at 3:16
3
$begingroup$
There is this very graphic as a demo in the Wolfram Demonstrations Project
$endgroup$
– ciao
May 5 at 8:07
add a comment |
$begingroup$
What have you tried?
$endgroup$
– David G. Stork
May 5 at 3:16
3
$begingroup$
There is this very graphic as a demo in the Wolfram Demonstrations Project
$endgroup$
– ciao
May 5 at 8:07
$begingroup$
What have you tried?
$endgroup$
– David G. Stork
May 5 at 3:16
$begingroup$
What have you tried?
$endgroup$
– David G. Stork
May 5 at 3:16
3
3
$begingroup$
There is this very graphic as a demo in the Wolfram Demonstrations Project
$endgroup$
– ciao
May 5 at 8:07
$begingroup$
There is this very graphic as a demo in the Wolfram Demonstrations Project
$endgroup$
– ciao
May 5 at 8:07
add a comment |
3 Answers
3
active
oldest
votes
$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]
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).
$endgroup$
add a comment |
$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]
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]]
$endgroup$
add a comment |
$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]]]
$endgroup$
add a comment |
Your Answer
StackExchange.ready(function()
var channelOptions =
tags: "".split(" "),
id: "387"
;
initTagRenderer("".split(" "), "".split(" "), channelOptions);
StackExchange.using("externalEditor", function()
// Have to fire editor after snippets, if snippets enabled
if (StackExchange.settings.snippets.snippetsEnabled)
StackExchange.using("snippets", function()
createEditor();
);
else
createEditor();
);
function createEditor()
StackExchange.prepareEditor(
heartbeatType: 'answer',
autoActivateHeartbeat: false,
convertImagesToLinks: false,
noModals: true,
showLowRepImageUploadWarning: true,
reputationToPostImages: null,
bindNavPrevention: true,
postfix: "",
imageUploader:
brandingHtml: "Powered by u003ca class="icon-imgur-white" href="https://imgur.com/"u003eu003c/au003e",
contentPolicyHtml: "User contributions licensed under u003ca href="https://creativecommons.org/licenses/by-sa/3.0/"u003ecc by-sa 3.0 with attribution requiredu003c/au003e u003ca href="https://stackoverflow.com/legal/content-policy"u003e(content policy)u003c/au003e",
allowUrls: true
,
onDemand: true,
discardSelector: ".discard-answer"
,immediatelyShowMarkdownHelp:true
);
);
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function ()
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fmathematica.stackexchange.com%2fquestions%2f197697%2fhow-to-do-this-padovan-spiral-using-mathematica%23new-answer', 'question_page');
);
Post as a guest
Required, but never shown
3 Answers
3
active
oldest
votes
3 Answers
3
active
oldest
votes
active
oldest
votes
active
oldest
votes
$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]
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).
$endgroup$
add a comment |
$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]
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).
$endgroup$
add a comment |
$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]
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).
$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).
edited May 12 at 19:52
answered May 5 at 12:49
Carl LangeCarl Lange
6,38411547
6,38411547
add a comment |
add a comment |
$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]
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]]
$endgroup$
add a comment |
$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]
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]]
$endgroup$
add a comment |
$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]
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]]
$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]]
answered May 5 at 4:57
Bob HanlonBob Hanlon
62.5k33599
62.5k33599
add a comment |
add a comment |
$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]]]
$endgroup$
add a comment |
$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]]]
$endgroup$
add a comment |
$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]]]
$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]]]
edited May 5 at 12:07
answered May 5 at 11:22
MelaGoMelaGo
1,23517
1,23517
add a comment |
add a comment |
Thanks for contributing an answer to Mathematica Stack Exchange!
- Please be sure to answer the question. Provide details and share your research!
But avoid …
- Asking for help, clarification, or responding to other answers.
- Making statements based on opinion; back them up with references or personal experience.
Use MathJax to format equations. MathJax reference.
To learn more, see our tips on writing great answers.
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function ()
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fmathematica.stackexchange.com%2fquestions%2f197697%2fhow-to-do-this-padovan-spiral-using-mathematica%23new-answer', 'question_page');
);
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function ()
StackExchange.helpers.onClickDraftSave('#login-link');
);
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
$begingroup$
What have you tried?
$endgroup$
– David G. Stork
May 5 at 3:16
3
$begingroup$
There is this very graphic as a demo in the Wolfram Demonstrations Project
$endgroup$
– ciao
May 5 at 8:07