I found this picture on the net.
How can I reproduce it in Mathematica?
$\begingroup$
$\endgroup$
3
-
6$\begingroup$ Have you attempted to make this yourself? Do so, post code if you have problems or questions. $\endgroup$– ciaoMar 23, 2015 at 5:20
-
$\begingroup$ This should get you started: (13894715) -- if you run into trouble let us know. $\endgroup$– Mr.WizardMar 23, 2015 at 6:49
-
$\begingroup$ @Rahul I totally agree as I have seen that post before too! $\endgroup$– Chen Stats YuApr 24, 2015 at 23:30
Add a comment
|
4 Answers
$\begingroup$
$\endgroup$
5
I appreciate that attempts should be the minimum standard. As this does not resemble the desired result, perhaps it can be a starting point. I look forward to OP attempt and other answers.
f[n_, d_] := Module[{r = Range@n, a},
a = Sqrt[#]/d & /@ r;
MapThread[#1 {-Cos[#2], -Sin[#2]} &, {Sqrt[r], a}]]
di[n_, d_, rad_] := Module[{fu, pt, grad, pg},
fu = f[n, d];
pt = MapIndexed[{White, EdgeForm[Black], Disk[#1, rad],
Text[Style[Sqrt[ToString[First@#2]], Black], #1]} &, fu];
grad = Reverse[{{0, 0}, ##} & @@@ Partition[fu, 2, 1]];
pg = MapIndexed[{Hue[First@#2/n], EdgeForm[Black], Polygon@#1} &,
grad];
Graphics[Join[pg, pt]]
]
After some play:
di[87, 0.4, 0.5]
-
$\begingroup$ Lol- before I scrolled down to see name, knew this was your work just from the image... +1 $\endgroup$– ciaoMar 24, 2015 at 1:16
-
$\begingroup$ @rasher I guess I am predictable but play is both instructive and therapeutic :) $\endgroup$– ubpdqnMar 29, 2015 at 3:27
-
$\begingroup$ @rasher thanks for your good humor and sorry if my 'tropic thunder' extension of commentary was more than the lame participation I intended it to be :) $\endgroup$– ubpdqnApr 3, 2015 at 1:36
-
$\begingroup$ Huh? I thought it hilarious! And the reason I knew this post was you is the quality of the graphic - I'd +1 again if I could... $\endgroup$– ciaoApr 3, 2015 at 1:42
-
$\begingroup$ @rasher...just feeling sorry for myself...working ten days straight starting to warp my head...I really enjoy the delights of MSE and the creativity and humor just wanted reality check...so thanks...back to salt mines $\endgroup$– ubpdqnApr 3, 2015 at 1:45
$\begingroup$
$\endgroup$
6
I tried to do this without looking at the previous answers... let me know if I accidentally plagiarized!
With[{n = 87},
Module[{radii = Sqrt[Range[n]], angles, coords},
angles = Accumulate @ Most[ArcCot[radii]] ~Prepend~ 0;
coords = radii * Transpose @ Through[{Cos, Sin}[angles]];
Graphics[{
EdgeForm[Black],
Reverse @ MapIndexed[{
FaceForm @ Blend[{White, RGBColor[.6, .7, 0], RGBColor[0, .2, 0]}, First@#2/n],
Polygon[#1 ~Append~ {0, 0}]
} &, Partition[coords, 2, 1]
],
FaceForm[White],
MapIndexed[{
Disk[#1, 1/3],
Text[Sqrt[ToString @ First[#2]], #1]
} &, coords
]
}, ImageSize -> Full]
]
]
I only spent about 15 minutes on this, but I think that this and the original have the correct angles, and that ubpdqn's is wrong...
P.S. I got my colors from:
Graphics3D[{RGBColor @@ #, Point@#} & /@
First /@ Take[
SortBy[Tally[
Join @@ ImageData[
Import["https://i.stack.imgur.com/jYcLD.png"]]], Last], -100]]
-
$\begingroup$ I really wish that MMA had the ability to set font size in graphics coordinate units.... $\endgroup$ Apr 25, 2015 at 3:10
-
$\begingroup$ This does indeed match the question and probably should be accepted answer +1 and I should have thought a little better than I did wrt angles...so nice accumulation :) $\endgroup$– ubpdqnApr 25, 2015 at 3:35
-
$\begingroup$ @ubpdqn The point of the diagram is that each of the triangles is a right triangle. If a given triangle has a length $\sqrt{n}$ leg and a length $1$ leg, the hypotenuse is $\sqrt{\sqrt{n}^2+1^2}=\sqrt{n+1}$. The angle of each triangle is $\tan\theta=1/\sqrt{n}$, so $\theta=\text{arccot}\sqrt{n}$. $\endgroup$ Apr 25, 2015 at 14:16
-
$\begingroup$ @ubpdqn You did guess the form of the angle correctly though: see
Series[Integrate[ArcCot[Sqrt[m]], {m, 0, n}, Assumptions -> n > 1], {n, \[Infinity], 0}]. The angle is about equal to $2\sqrt{n}$, sodi[_, 0.5, 0.5]is pretty close to the original. $\endgroup$ Apr 25, 2015 at 14:25 -
$\begingroup$ nice stealing from the OP's colour palette ! $\endgroup$– chrisJun 14, 2015 at 14:01
$\begingroup$
$\endgroup$
1
A mild refactoring of ubpdqn's code:
f[n_, d_] := #*Map[{-Cos[#], -Sin[#]} &, #/d] & @ Sqrt @ Range @ n
di[n_, d_, rad_] :=
Module[{fu, pt, grad, pg},
fu = f[n, d];
pt = MapIndexed[{Disk[#, rad], Sqrt[HoldForm @@ #2] ~Style~ Black ~Text~ #} &, fu];
grad = Reverse[{{0, 0}, ##} & @@@ Partition[fu, 2, 1]];
pg = MapIndexed[{Hue[#2/n], Polygon @ #} &, grad];
Graphics[{EdgeForm[Black], pg, White, pt}]
]
di[87, 0.4, 0.5]
answered Mar 23, 2015 at 12:45
-
$\begingroup$ nice...always can do better...did not realise was duplicate $\endgroup$– ubpdqnMar 23, 2015 at 13:08
$\begingroup$
$\endgroup$
1
I nest the right turns with # + Normalize@Cross[#] &. Since 2012rcampion has rather solved the coloring, here's a version using a close match from one of Mathematica's gradients.
cf = Lighter[ColorData["AvocadoColors", 1. - #], (1. - #)^8] &;
With[{npts = 87},
Graphics[
GraphicsComplex[
NestList[# + Normalize@Cross[#] &, {1., 0.}, npts - 1] ~Append~ {0., 0.},
{EdgeForm[Thin],
Table[{cf[i/npts], Polygon[{i, i + 1, npts + 1}]}, {i, npts - 1, 1, -1}],
Table[{White, Disk[i, 1/3], Black, Text[HoldForm[Sqrt[#]] &@i, i]}, {i, npts}]}
],
BaseStyle -> {FontSize -> Scaled[0.1/Sqrt[npts]]}
]
]
answered Apr 25, 2015 at 21:25
-
1$\begingroup$ Wow! The use of
Crossis very clever, andGraphicsComplexis a nice touch to keep it clean. $\endgroup$ Apr 25, 2015 at 22:41