49
$\begingroup$

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]

output of the above code

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

output of the above code

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.

Improve this question
$\endgroup$
5
  • $\begingroup$ Re: "can some of you do better than I at generating these diagrams" ... Better in what sense? $\endgroup$
    – Dr. belisarius
    Mar 13, 2013 at 16:54
  • $\begingroup$ @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). $\endgroup$
    – JOwen
    Mar 13, 2013 at 17:00
  • $\begingroup$ I think this should be alright as it would be considered fair use of the images. $\endgroup$
    – Szabolcs
    Mar 13, 2013 at 17:30
  • 6
    $\begingroup$ 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. $\endgroup$
    – m_goldberg
    Mar 13, 2013 at 17:48
  • 4
    $\begingroup$ There is now a good answer on the official WRI blog. $\endgroup$
    – C. E.
    May 6, 2016 at 19:05

3 Answers 3

Reset to default
63
$\begingroup$

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}] &, 
    ImageData@ImageAdjust[img, {0, c, g}], {2}];
 ImageMultiply[dots, edge],
 {c, 0, 2}, {g, 1, 3}
 ]

Mathematica graphics

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

Mathematica graphics

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

Improve this answer
$\endgroup$
3
  • 1
    $\begingroup$ 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. $\endgroup$
    – Jon Purdy
    Mar 13, 2013 at 18:16
  • $\begingroup$ Fantastic. I am especially pleased that you have exposed parameters to tinker with here. $\endgroup$
    – JOwen
    Mar 13, 2013 at 21:35
  • 1
    $\begingroup$ @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 how to reliably automate it ... $\endgroup$
    – Szabolcs
    Mar 13, 2013 at 22:01
13
$\begingroup$

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]

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ 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. $\endgroup$
    – JOwen
    Mar 13, 2013 at 21:38
7
$\begingroup$

Since Mathematica 12.1 this can be done with the built-in function StippleShading:

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

enter image description here

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

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