3
$\begingroup$

I found this picture on the net.

enter image description here

How can I reproduce it in Mathematica?

$\endgroup$
3
  • 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$ 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$
5
  • $\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$
6
  • $\begingroup$ I really wish that MMA had the ability to set font size in graphics coordinate units.... $\endgroup$ 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$ 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$ 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$
1
  • $\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$
1
  • 1
    $\begingroup$ Wow! The use of Cross is very clever, and GraphicsComplex is a nice touch to keep it clean. $\endgroup$ Apr 25 '15 at 22:41

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