Generating stippled (Penrose-style) drawings of surfaces

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


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


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