I'm trying to create a version of Alberti's window, a figure that represents the projection of a three-dimensional figure onto a two-dimensional plane.

Here are my steps:

1) Create the three-dimensional figure:

myDodecahedronFigure = 
   PolyhedronData["Dodecahedron", "Faces", "Polygon"]}]

2) Extract the vertices and create a line from each to the center of projection (at {10,0,0}):

myVertices = N@PolyhedronData["Dodecahedron", "Vertices"];

myProjectionLines = (Line[{{10, 0, 0}, #}] & /@ myVertices);

3) Put them together with the plane of projection (at x = 6):

 Graphics3D[{Red, myProjectionLines, 
   PointSize[0.01], Point[myVertices],
   Opacity[0.5], Yellow, 
   Polygon[{{6, -2, -2}, {6, -2, 2}, {6, 2, 2}, 
            {6, 2, -2}, {6, -2, -2}}]}],
 ImageSize -> 600

enter image description here

I would like to render the projections of the (red) points and the (blue) edges onto the projection plane.


I have two component problems:

a) I want to include only the points and edges that are visible from the center of projection. (I don't want to hand-select such points.)

b) I want a natural and simple way to render lines and points on the projection plane. (Alas Projection merely projects a vector onto another vector, so that doesn't seem of much help.)


We can get the lines connected to vertices visible from vp using the approach from this answer by aardvark2012 and the intersections of those lines with the plane using RegionIntersection:

vp = {10, 0, 0};
poly = Polygon[{{6, -2, -2}, {6, -2, 2}, {6, 2, 2}, {6, 2, -2}, {6, -2, -2}}];

rd = RegionDifference[ConvexHullMesh[Prepend[myVertices, vp]], ConvexHullMesh[myVertices]];

lines2 = Select[myProjectionLines, 
   MemberQ[Intersection[MeshCoordinates[rd], myVertices], #[[1,2]]]&];

pointsonpoly = RegionIntersection[poly, #]& /@ lines2;

Graphics3D[{PointSize[0.01], Red, Point[myVertices],
   Green, pointsonpoly,   
   Purple, lines2, 
   Opacity[0.5], Yellow, poly,  
   myDodecahedronFigure[[1]]}, ImageSize -> 600]

enter image description here

  • 1
    $\begingroup$ You constantly amaze me. Who else knows this much about Mathematica?? ($\checkmark$) $\endgroup$ – David G. Stork Aug 15 '19 at 21:52
  • $\begingroup$ Thank you @David for the kind words and the accept. $\endgroup$ – kglr Aug 15 '19 at 21:56
  • $\begingroup$ @kglr Very impressive way for a "hidden line algorithm" ! I tried your code in MMAv11.0.1 but the RegionDifference isn't evaluated .What could be the reason? Thanks! $\endgroup$ – Ulrich Neumann Aug 16 '19 at 6:29
  • $\begingroup$ @UlrichNeumann, thank you. I don't have access to v11. Apparently v11.2 updates to RegionDifference fixed whatever was broken. $\endgroup$ – kglr Aug 16 '19 at 6:40
  • $\begingroup$ @kglr Thanks, I have to think about a major update... $\endgroup$ – Ulrich Neumann Aug 16 '19 at 6:43

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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