# Generating “Penrose-style” drawings of surfaces

In The Road to Reality there are plots of surfaces that use a variable density of dots to suggest curvature. You can see some examples here and here.

I suppose they've been drawn by Penrose, but to me they look like something that could be quite easily generated algorithmically---say, starting from image of a surface of 3D object with lighting.

Some of my initial attempts at this below. First, for a sphere:

ImageAdd[#, ColorNegate@ImageEffect[#, {"SaltPepperNoise", 0.5}]] & [
Graphics3D[{GrayLevel[.25],
Specularity[White, 1], Sphere[]},
Lighting -> "Neutral",
Boxed -> False]
// Rasterize]


And for a more complex object:

Binarize@ImageAdd[#, ColorNegate@ImageEffect[#, {"SaltPepperNoise", 0.78}]] & [
Graphics3D[
{GrayLevel[.25], Specularity[White, 1], KnotData[{6, 2}, "ImageData"]},
Lighting -> "Neutral",
Boxed -> False]]


I'm decidedly inexperienced at using all of Mathematica's image processing functions, especially compared to others on this site! I've been reading the many answers to this related question to get ideas.

So I have two questions. Firstly, can some of you do better than I at generating these diagrams (I'm sure many can!), or perhaps point me in a fruitful direction?

Second, suppose I have a series of frames of surfaces that together make a smooth animation. As soon as I "Penrose-ify" them, I expect that the placements of the points in the frames will sort of "quiver" from frame to frame (if there is a random component in how they are placed), thereby breaking the continuity of the animation. How can one get around this?

I ask this question in hesitation after reading this on meta. I hope it will not be judged too similar to other questions or uninteresting. Personally I can see many semi-practical applications of automated ways to generate diagrams like these, e.g. for illustration purposes. Many thanks in advance.

-
Re: "can some of you do better than I at generating these diagrams" ... Better in what sense? –  belisarius Mar 13 '13 at 16:54
@belisarius Yes I was afraid of being asked that. I mean better in the sense of "more similar to the style seen in the book (e.g. in the Flickr images I linked to)". Of course, I expect since you are asking, that this is will not be precise enough! I can say what aspects of the style I'm having trouble replicating though. For instance, the combination of lighting and "salt-and-pepper" noise I am using doesn't get the quite the right density distribution of points. They should get much thicker at the edges, and be more sparse in the interior (at least for the sphere). –  JOwen Mar 13 '13 at 17:00
I think this should be alright as it would be considered fair use of the images. –  Szabolcs Mar 13 '13 at 17:30
The technique you discuss is properly called stippling. It was a very common technical illustration shading technique back in the days before most technical illustrations were produced by computer. –  m_goldberg Mar 13 '13 at 17:48

Here's a try:

g3 = Graphics3D[{Gray, Sphere[]}, Lighting -> "Neutral",
Boxed -> False]

img = ColorConvert[Rasterize[g3, "Image", ImageResolution -> 72],
"GrayLevel"]

edge = ColorNegate@EdgeDetect[img]

Manipulate[
dots = Image@
Map[RandomChoice[{#, 1 - #} -> {1, 0}] &,
ImageMultiply[dots, edge],
{c, 0, 2}, {g, 1, 3}
]


g3 = Graphics3D[{Gray, KnotData[{6, 2}, "ImageData"]},
Lighting -> "Neutral", Boxed -> False]


After manually finding nice c and g parameters, we can improve this a little bit by upscaling by a non-integer factor to make the dots look more natural and bigger. We can also dilate the edges accordingly. Using the knot image with a scaling factor of 3.3,

ImageMultiply[
ColorNegate@
Dilation[Thinning@
EdgeDetect@
ColorConvert[Rasterize[g3, "Image", ImageResolution -> 3.3 72],
"GrayLevel"], 1],
Binarize@ImageResize[
Image@Map[RandomChoice[{#, 1 - #} -> {1, 0}] &,
ImageData@ImageAdjust[img, {0, 1.1, 1.65}], {2}], Scaled[3.3]]]


-
Good solution. I notice only two minor differences between this and the original images. In the originals, the lighting is harsher (perhaps unrealistically), with large specular highlights and dark shadows. The outlines also vary in thickness due to hand movement and ink bleeding. –  Jon Purdy Mar 13 '13 at 18:16
+1 nicely done, really like these –  Vitaliy Kaurov Mar 13 '13 at 19:02
Fantastic. I am especially pleased that you have exposed parameters to tinker with here. –  JOwen Mar 13 '13 at 21:35
+1 nice ....... –  Mike Honeychurch Mar 13 '13 at 21:56
@JOwen You could argue that the parameters are weaknesses. I couldn't make a solution which automatically would work for any 3D object. What I do is that I keep increasing c (contrast) and g (gamma) manually until the bright parts are bright enough and the dark parts are dark enough. It would be more convenient if this could be done automatically, but I don't know hot to reliably automate it ... –  Szabolcs Mar 13 '13 at 22:01

The 2D versions a beautiful and what @Szabolcs did is very nice. I just wanted to add the 3D version. If you know parametric curves and surfaces you could something like this. You will not get nice point density changes where 3D light reflection happens. But you can rotate them in real 3D! For 2D you can rasterize them.

g = KnotData[{7, 2}, "SpaceCurve"];

Graphics3D[{PointSize[0],
Point[Table[g[t] + RandomReal[{-.4, .4}, 3], {t, 0, 2 Pi, .0001}]]},
Boxed -> False, SphericalRegion -> True, ViewAngle -> .3]


-
Thanks very much. The animation suffers from the quiver problem I mentioned in my question, but now that I see it, it actually looks like this isn't really noticeable, at least with many points as you have here. –  JOwen Mar 13 '13 at 21:38