3
$\begingroup$

This question already has an answer here:

I found this picture on the net.

enter image description here

How can I reproduce it in Mathematica?

$\endgroup$

marked as duplicate by Michael E2, Bob Hanlon, Sjoerd C. de Vries, Oleksandr R., m_goldberg Jun 14 '15 at 13:59

This question has been asked before and already has an answer. If those answers do not fully address your question, please ask a new question.

  • 6
    $\begingroup$ Have you attempted to make this yourself? Do so, post code if you have problems or questions. $\endgroup$ – ciao Mar 23 '15 at 5:20
  • $\begingroup$ This should get you started: (13894715) -- if you run into trouble let us know. $\endgroup$ – Mr.Wizard Mar 23 '15 at 6:49
  • $\begingroup$ @Rahul I totally agree as I have seen that post before too! $\endgroup$ – Chen Stats Yu Apr 24 '15 at 23:30
21
+500
$\begingroup$

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]

enter image description here

$\endgroup$
  • $\begingroup$ Lol- before I scrolled down to see name, knew this was your work just from the image... +1 $\endgroup$ – ciao Mar 24 '15 at 1:16
  • $\begingroup$ @rasher I guess I am predictable but play is both instructive and therapeutic :) $\endgroup$ – ubpdqn Mar 29 '15 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$ – ubpdqn Apr 3 '15 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$ – ciao Apr 3 '15 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$ – ubpdqn Apr 3 '15 at 1:45
13
$\begingroup$

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

enter image description here

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["http://i.stack.imgur.com/jYcLD.png"]]], Last], -100]]
$\endgroup$
  • $\begingroup$ I really wish that MMA had the ability to set font size in graphics coordinate units.... $\endgroup$ – 2012rcampion Apr 25 '15 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$ – ubpdqn Apr 25 '15 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$ – 2012rcampion Apr 25 '15 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}$, so di[_, 0.5, 0.5] is pretty close to the original. $\endgroup$ – 2012rcampion Apr 25 '15 at 14:25
  • $\begingroup$ nice stealing from the OP's colour palette ! $\endgroup$ – chris Jun 14 '15 at 14:01
7
$\begingroup$

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]
$\endgroup$
  • $\begingroup$ nice...always can do better...did not realise was duplicate $\endgroup$ – ubpdqn Mar 23 '15 at 13:08
6
$\begingroup$

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

Mathematica graphics

$\endgroup$
  • $\begingroup$ Wow! The use of Cross is very clever, and GraphicsComplex is a nice touch to keep it clean. $\endgroup$ – 2012rcampion Apr 25 '15 at 22:41

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