# How can I recreate Trott's Riemann Surface plot in Mathematica?

In reading Michael Trott's Visualization of Riemann Surfaces of Algebraic Functions, he has:

ParametricPlot3D[{r Cos[φ], r Sin[φ], Sqrt[r] Sin[φ/2],
SurfaceColor[Hue[φ/(4 π)]]}, {r, 0, 1}, {φ, 0, 4 π},
PlotPoints -> {20, 60}, Boxed -> False, Axes -> False]


How would you do this coloring now in Mathematica 9 ?

-

Natively in V9, you can do the following:

ParametricPlot3D[{r Cos[phi], r Sin[phi], Sqrt[r] Sin[phi/2]}, {r, 0, 1},
{phi, 0, 4 Pi}, PlotPoints -> {20, 60}, Boxed -> False, Axes -> False,
ColorFunction -> (Hue[#5/(4 Pi)] &), ColorFunctionScaling -> False]


Alternatively, you can always use the exact code using the V5 emulator:

<<Version5Graphics
ParametricPlot3D[{r Cos[phi], r Sin[phi], Sqrt[r] Sin[phi/2],
SurfaceColor[Hue[phi/(4 Pi)]]}, {r, 0, 1}, {phi, 0, 4 Pi},
PlotPoints -> {20, 60}, Boxed -> False, Axes -> False]


Of course, the graphics aren't quite as nice. You can go back to the newer style graphics as follows:

<<Version6Graphics

-

As of Version 6, SurfaceColor has been superseded by Specularity and Glow.

One could specify the variables explicitly like here :

ParametricPlot3D[{ r Cos[φ], r Sin[φ], Sqrt[r] Sin[φ/2]}, {r, 0, 1}, {φ, 0, 4 π},
ColorFunction -> Function[{x, y, z, r, φ, θ},
{Specularity[#], Glow[#]}& @ Hue[Rescale[φ, {0, 1}]]],
PlotPoints -> {20, 60}, Boxed -> False, Axes -> False]


or adding a more thrilling variation of ColorFunction (singularity when r -> 0) :

ParametricPlot3D[{ r Cos[φ], r Sin[φ], Sqrt[r] Sin[φ/2]}, {r, 0, 1}, {φ, 0, 4 π},
ColorFunction -> Function[{x, y, z, r, φ, θ},
{Specularity[#], Glow[#]}& @ Hue[ Rescale[ φ/r, {0, 1}]]],
PlotPoints -> {20, 60}, Boxed -> False, Axes -> False]


-
I think you're missing an argument. It should be Function[{x, y, z, r, φ}, ...]. – Rahul Dec 28 '12 at 22:58
Yes, I improved the arguments. Thanks. – Artes Dec 28 '12 at 23:16

...and now, for something that takes a bit of the old, and a bit of the new:

ColoredMakePolygons[vl_List] := Module[{msh = Map[Most, vl, {2}], cols, dims},
cols = Map[First[Cases[Last[#], _?ColorQ, {0, Infinity}]] &, vl, {2}];
cols = Map[If[Head[#] === GrayLevel, #, ColorConvert[#, RGBColor]] &,
cols, {2}];
dims = Most[Dimensions[msh]];
GraphicsComplex[Apply[Join, msh], Polygon[Flatten[Apply[
Join[Reverse[#1], #2] &,
Partition[Partition[Range[Times @@ dims], Last[dims]],
{2, 2}, {1, 1}], {2}], 1]],
VertexColors -> Apply[Join, cols]]] /;
ArrayDepth[vl] == 3 && Last[Dimensions[vl]] == 4

With[{m = 21, n = 61},
Graphics3D[ColoredMakePolygons[
N @ Table[{r Cos[φ], r Sin[φ], Sqrt[r] Sin[φ/2], Hue[φ/(4 π)]},
{r, 0, 1, 1/(m - 1)}, {φ, 0, 4 π, 4 π/(n - 1)}]],
Boxed -> False, Lighting -> "Neutral"]]


-