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}
]
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]]]
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]
Since Mathematica 12.1 this can be done with the built-in function StippleShading
:
Graphics3D[{StippleShading[], KnotData[{6, 2}, "ImageData"]},
Lighting -> "Neutral", Boxed -> False]