# Drawing a square root spiral

Here is a start. I'm looking for a nice way to draw it.

Graphics[{EdgeForm[Black], White,
Polygon @ {{0, 0}, {-1, 0},
Sqrt[2] {Cos[#], Sin[#]} &[Pi - (ArcCot[1])]},
Polygon @ {{0, 0}, Sqrt[2] {Cos[#], Sin[#]} &[Pi - (ArcCot[1])],
Sqrt[3] {Cos[#], Sin[#]} &[Pi - (ArcCot[1] + ArcCot[Sqrt[2]])]},
Polygon @ {{0, 0},
Sqrt[3] {Cos[#], Sin[#]} &[Pi - (ArcCot[1] + ArcCot[Sqrt[2]])],
Sqrt[4] {Cos[#], Sin[#]} &[
Pi - (ArcCot[1] + ArcCot[Sqrt[2]] + ArcCot[Sqrt[3]])]}}]

• Something like this: ParametricPlot[Sqrt[t] {Cos[t], Sin[t]}, {t, 1, 10}]?
– rm -rf
Commented Nov 30, 2014 at 15:39
• related: 40283
– Kuba
Commented Nov 30, 2014 at 15:51

With labels

k = 1; angles = NestList[# - ArcTan[1./Sqrt[k++]] &, Pi, 15];

pts = Table[Sqrt[n]*
{Cos[angles[[n]]], Sin[angles[[n]]]},
{n, 15}];

Graphics[{
Line[pts],
Line[{{0, 0}, #}] & /@ pts,
k = 2; Text["1", Sqrt[k++] {Cos[#], Sin[#]}] & /@
Mean /@ Most@Partition[angles, 2, 1],
k = 1; Text[ToString[Sqrt[ToString[k]], TraditionalForm],
.6 Sqrt[k++] {Cos[#], Sin[#]}] & /@
Mean /@ Partition[angles, 2, 1]}]


• That is a beautiful result! +1 Commented Dec 1, 2014 at 5:03
• This is actually the most correct and "right on the money" answer to the question, but the other answer adds its own qualities, and (deservedly) attracts more attention... Commented Dec 1, 2014 at 6:26

One way to approach is to calculate the basic triangle (with sides of lengths Sqrt[n], Sqrt[n+1] and 1) and then rotate it the correct amount so that they all fit together.

sumAng[n_] := Sum[ArcTan[1/Sqrt[i]], {i, 1, n}];
poly[n_] := {{0, 0}, {Sqrt[n + 1], 0}, {Sqrt[n + 1], 1}};
Graphics[Table[Rotate[{Opacity[1], Hue[RandomReal[]], Polygon[poly[i]]},
sumAng[i], {0, 0}], {i, 0, 10}]]


Lowering the opacity (to 0.5) and increasing the number of triangles (to 40) yields:

and here are 100 terms plotted with a slightly more organized Hue function:

Graphics[Table[Rotate[{Opacity[0.5], Hue[i/40], Polygon[poly[i]]},
sumAng[i], {0, 0}], {i, 0, 100}]]


And here's what happens when you get the angles wrong: (this version effectively uses sumAng[n_] := RandomReal[{0, 2 n}];)

If you prefer more orderly disorganization,

sumAng[n_] := Sum[ArcTan[1/Sqrt[i] + i], {i, 1, n}];


• Work of art! Truly outstanding solution for color! As if it was from a book on usage of colors in data visualization by Tufte or similar... Also, is there any chance you post the code for the case "angles gone wrong"? Commented Dec 1, 2014 at 6:20
• @Adrian -- I've updated with a couple of variations (and code). Commented Dec 1, 2014 at 14:01

I've decided to be a bit ornery and render the spiral of Theodorus in an anticlockwise fashion for this answer, for reasons I'll explain later.

The following is similar to what Michael did in his answer to a related question:

polys = NestList[With[{hyp = Delete[#[[1]], 2]},
Polygon[Append[hyp, Last[hyp] - Normalize[Cross[Subtract @@ hyp]]]]] &,
Polygon[N[{{0, 0}, {1, 0}, {1, 1}}, 20]], 15];

Graphics[{Directive[EdgeForm[Black], FaceForm[None]], polys}]


If labels are wanted,

Graphics[{Directive[EdgeForm[Black], FaceForm[None]], polys,
polys /. Polygon[pts_] :> Text["1", 1.1 Mean[Rest[pts]]],
Append[MapIndexed[Text[DisplayForm[SqrtBox[ToString[First[#2]]]],
Mean[First[#1]]] &, polys],
Text[DisplayForm[SqrtBox["17"]], Mean[Delete[polys[[-1, 1]], 2]],
{-3, -1}]]}]


## Extra credit

(You don't need to read the rest if you're not interested in special functions.)

Philip Davis, in his book, considered the problem of continuously interpolating the points of the spiral of Theodorus, when treated as points in the complex plane. (This is similar to the problem of continuously interpolating $n!$, for which the gamma function $\Gamma(z+1)$ is a particular solution.) With some help from Walter Gautschi, he was able to derive the required function $T(\alpha)$. Here is a Mathematica implementation:

TheodorusT[α_?NumericQ] := 1 /; α == 0;

TheodorusT[α_?NumericQ] := With[{β = FractionalPart[α]}, If[β == 0, 1, TheodorusT[β]]
Product[1 + I/Sqrt[β + j], {j, 1, IntegerPart[α]}]] /;
α >= 1 && Precision[α] < ∞

TheodorusT[α_?NumericQ] := With[{f = Sqrt[1 + α]}, f/(I + f) TheodorusT[1 + α]] /;
-1 <= α < 0 && Precision[α] < ∞;

TheodorusT[α_?NumericQ] := With[{f = Sqrt[-α - 1]}, (f + I)/(f - I) TheodorusT[-α - 2]] /;
α < -1 && Precision[α] < ∞;

TheodorusT[α_?NumericQ] :=
Sqrt[1 + α] Exp[I NIntegrate[DawsonF[Sqrt[t]]/(Exp[t] - 1) (1 - Exp[-α t])/t, {t, 0, ∞},
Method -> "DoubleExponential",
WorkingPrecision -> Precision[α]]/Sqrt[π]] /;
0 < α < 1 && Precision[α] < ∞


Here's a plot:

ParametricPlot[Through[{Re, Im}[TheodorusT[α]]], {α, -1, 19}, Axes -> None, Frame -> True]


Display with the discrete version:

Show[%, Graphics[{Directive[EdgeForm[Black], FaceForm[None]], polys}]]


Finally, here's the extended spiral:

ParametricPlot[Through[{Re, Im}[TheodorusT[α]]], {α, -18, 19}, Axes -> None, Frame -> True]


Another natural solution is to use AnglePath.

pts = AnglePath[{-1, 0}, Prepend[-ArcTan[1./Sqrt[Range[13]]], Pi/2.]];
Graphics[{Line[pts], Line[{{0, 0}, #}] & /@ pts}]


Verify:

Sqrt[Rationalize[Plus @@@ (pts^2)]]

(* {1, Sqrt[2], Sqrt[3], 2, Sqrt[5], Sqrt[6], Sqrt[7], 2 Sqrt[2], 3,
Sqrt[10], Sqrt[11], 2 Sqrt[3], Sqrt[13], Sqrt[14], Sqrt[15]} *)

• Heh, I'd thought of this solution too after trying to re-implement AnglePath[], but forgot to post here. The angle list can be slightly simplified: AnglePath[{-1., 0.}, Prepend[-ArcCot[Sqrt[Range[13]]], π/2]]. Commented Oct 23, 2015 at 2:06
• The angle list can be slightly simplified: AnglePath[{-1,0}, ArcCot[-Sqrt@Range[0.,13]]] Commented Jun 11, 2020 at 13:20
Clear["*"];
ang[n_] := Sum[ArcCot@Sqrt@i, {i, n}];
p[n_] := Sqrt[n + 1] {Cos@ang[n], Sin@ang[n]}
poly[n_] := {{0, 0}, p[n], p[n + 1]};
Graphics[Table[{Hue[i/16], EdgeForm@Hue[i/16], Polygon@poly[i]}, {i, 0, 15}]]


point = AnglePath[{1, 0},
Prepend[ArcTan /@ (1/Sqrt[Range[1, 16]]), 90 \[Degree]]];
Graphics[{Line@point[[;; -2]], Line[{{0, 0}, #} & /@ point[[;; -2]]],
Table[Text[Sqrt[ToString@i],
5/7 point[[i]] + 0.15 (point[[i + 1]] - point[[i]])], {i, 17}]},
PlotRange -> {-4.2, 2}]
`