17
|
13762 Views
|
4 Replies
|
21 Total Likes
View groups...
Share
GROUPS:

Reflection and Anamorphosis in a Spherical Mirror

Posted 5 years ago
 This contribution is an extension of my recent Wolfram Demonstration "Spherical Mirror Anamorphosis of Regular Polygons". Two questions can be asked when reflecting an object in a spherical (or other) mirror: Reflection: how does the (deformed) reflection in a mirror of an object outside the mirror look like? Anamorphism: how should a (deformed) object outside the mirror look like in order to be reflected in the mirror as the real object? In the spherical mirror centered at C, V is the observer's eye position, S is a (real) point outside the mirror and I is its perceived reflected point inside the mirror. One of the reflected light rays leaving S will meet the mirror at Q such that its reflection meets the eye at V. But the eye at V will now perceive the point S at I. This mirror setup can be used for the computation of both reflection and anamorphism and the points I and S form an "enantiomorphic" pair. To write the functions that map real points S into reflected points I and vice-versa, we use the law of reflection (ReflectionTransform and EuclideanDistance) sphericalAnamorphMap[imagePt : {xi_, yi_, zi_}] := Module[{solQ, pointQ, reflectionPt, solA}, (*intersection Q of viewline-sphere: Q*) solQ =(*find the intersection*) NSolve[{x, y, z} \[Element] HalfLine[{imagePt, {1*^6, 0, 0}}] && {x, y, z} \[Element] Sphere[], {x, y, z}]; pointQ = First[{x, y, z} /. solQ]; reflectionPt = ReflectionTransform[pointQ][{-1*^6, 0, 0}]; solA = First@ NSolve[EuclideanDistance[pointQ, t*(reflectionPt - pointQ) + pointQ ] == EuclideanDistance[imagePt, pointQ], t]; (-t*(reflectionPt - pointQ) + pointQ) /. solA] sphericalReflectionMap[reflectedPt : {xs_, ys_, zs_}] := Module[{plane, solQ, pointQ, solI}, plane = InfinitePlane[{{0, 0, 0}, {1*^6, 0, 0}, reflectedPt}]; solQ =(*find the intersection*) NSolve[{{x, y, z} \[Element] Sphere[], {x, y, z} \[Element] plane, VectorAngle[reflectedPt - {x, y, z}, {x, y, z}] == VectorAngle[{1*^6, 0, 0} - {x, y, z}, {x, y, z}]}, {x, y, z}]; pointQ = Last[{x, y, z} /. solQ]; solI = NSolve[{{x, y, z} \[Element] HalfLine[{{1*^6, 0, 0}, pointQ}], EuclideanDistance[{x, y, z}, pointQ] == EuclideanDistance[{xs, ys, zs}, pointQ]}, {x, y, z}]; First[{x, y, z} /. solI]]  This shows the two functions to be the inverse of one another: anamorphism as the inverse of reflection sphericalReflectionMap[sphericalAnamorphMap[{-0.12, -0.1582, -0.112}]]  {-0.12, -0.1582, -0.112} In the "anamorphism" to the left, we see a deformed, anamorphic curve that , when reflected in the mirror is observed as a perfect square. In the "reflection" to the right we see a perfect square reflected in a spherical mirror and observed as a deformed curve. The left graphics was created using the function sphericalAnamorphMap, the right one using the function sphericalReflectionMap . It is the first one that is computationally very interesting. It solves e.g. the question: compute a curve which, when reflected in a spherical mirror, will be perceived as a perfect square. The function sphericalAnamorphMap computes the anamorphic map of a single point. We can now make anamorphic objects as collections of points such as: polygons, polyhedra, graphics primitives and -complexes, tessellated objects from e.g ExampleData[{"Geometry3D",...] or from 3D scanned objects on the www. The following is a Manipulate that computes the spherical anamorphic map of some regular polygons and a circle. polygon[\[Theta]_, \[Theta]0_, r_, n_] :=(*parametric of a regular polygon*) r Cos[Pi/n] Sec[(2 ArcTan[Cot[(1/2) n (\[Theta] - \[Theta]0)]])/ n] {Cos[\[Theta]], Sin[\[Theta]]} Manipulate[Module[{polyPts, anamorphPts}, polyPts = ParallelMap[RotationMatrix[\[Alpha]100, {1, 0, 0}].# &, ParallelMap[RotationMatrix[\[Alpha]010, {0, 1, 0}].# &, ParallelMap[RotationMatrix[\[Alpha]001, {0, 0, 1}].# &, ParallelTable[ polygon[t, .001, r, n], {t, 0, 2 \[Pi], \[Pi]/24}] /. {x_?NumericQ, y_?NumericQ} -> {0, x, y}]]] /. {x_?NumericQ, y_?NumericQ, z_?NumericQ} -> {x + dx, y, z}; anamorphPts = Map[sphericalAnamorphMap, polyPts]; Graphics3D[{ {Gray, Opacity[.35], InfinitePlane[{{0, 0, -2}, {0, 1, -2}, {1, 0, -2}}]}, {(*full sphere*){Opacity[.1], Lighter[Orange, .75], Sphere[]}, (*spherical mirror*) Style[Sphere[], Specularity[White, 25], Blue, Opacity[.3], ClipPlanes -> InfinitePlane[{{0, 0, 0}, {0, 1, 0}, {0, 0, 1}}]]}, (*view cone base*){Opacity[.4], EdgeForm@AbsoluteThickness[2], Cylinder[{{0, 0, 0}, {-.01, 0, 0}}, 1]}, {Red, Tube[polyPts, .025], Tube[anamorphPts, .05]}}, Boxed -> False, PlotRange -> {{-1.5, 4}, {-2, 2}, {-2, 2}}, ViewPoint -> Dynamic@vwp]], "Geometry", {{r, .7, "Circumradius"}, .25, .988, .01, ImageSize -> Small}, {{n, 4}, {3, 4, 5, 6, 51 -> "circle"}, SetterBar, Appearance -> "Horizontal" -> {1, 5}}, Delimiter, "Rotate around", {{\[Alpha]001, .01, "z-axis"}, -\[Pi], \[Pi], ImageSize -> Small}, {{\[Alpha]010, .01, "y-axis"}, -\[Pi], \[Pi], ImageSize -> Small}, {{\[Alpha]100, .01, "x-axis"}, -\[Pi], \[Pi], ImageSize -> Small}, Delimiter, "Move front/back", {{dx, -.4}, -1, 1, .01, ImageSize -> Small}, Delimiter, "View direction", {{vwp, {1.3, -2.4, 2}, ""}, {{1, -100, 2} -> "sideways", Right -> "in front", {0, -.05, 100} -> "from top", {1.3, -2.4, 2} -> "default"}, SetterBar, Appearance -> "Horizontal" -> {2, 2}}, TrackedSymbols :> True, SynchronousUpdating -> False]  If we rotate the reflection of a circle around the z-axis (right) or the y-axis (left) and track the anamorphic image, we get this GIF: We can now extend our anamorphic imaging to 3D with polyhedron frames: Manipulate[ Module[{vertices, edges, polyPts, rotatedPts, anamorphPts}, vertices = r*PolyhedronData[pHedron, "Vertices"] // N; edges = PolyhedronData[pHedron, "Edges"]; polyPts = ParallelTable[(1 - t) #[[1]] + t #[[2]], {t, 0, 1, .2}] & /@ (Part[vertices, #] & /@ edges); rotatedPts = ParallelMap[RotationMatrix[\[Alpha]100, {1, 0, 0}].# &, ParallelMap[RotationMatrix[\[Alpha]010, {0, 1, 0}].# &, ParallelMap[RotationMatrix[\[Alpha]001, {0, 0, 1}].# &, r*polyPts, {2}], {2}], {2}] /. {x_?NumericQ, y_?NumericQ, z_?NumericQ} -> {x + dx, y, z}; (*anamorphic map of rotated points*) anamorphPts = Map[sphericalAnamorphMap, rotatedPts, {2}]; Graphics3D[{{Gray, Opacity[.25], InfinitePlane[{{0, 0, -2}, {0, 1, -2}, {1, 0, -2}}]}, {(*full sphere*){Opacity[.1], Lighter[Orange, .6], Sphere[]}, (*spherical mirror*) Style[Sphere[], Specularity[White, 25], Gray, Opacity[.4], ClipPlanes -> InfinitePlane[{{0, 0, 0}, {0, 1, 0}, {0, 0, 1}}]]}, {Red, Tube[#, .02] & /@ rotatedPts, Tube[anamorphPts, .035]}}, Lighting -> {{"Ambient", GrayLevel[0.25]}, {"Directional", White, ImageScaled[{1, 1, 1}]}}, Axes -> False, Boxed -> False, PlotRange -> {{-1.25, 4}, {-2, 2}, {-2, 2}}]], "Polyhedron", {{pHedron, "Dodecahedron", ""}, {"Cube", "Dodecahedron", "Icosahedron", "RhombicHexecontahedron"}, SetterBar, Appearance -> "Horizontal" -> {4, 1}}, {{r, .65, "Circumradius"}, .25, .988, .01, ImageSize -> Small}, Delimiter, "Rotate around", {{\[Alpha]001, .1, "z-axis"}, -\[Pi], \[Pi], ImageSize -> Small}, {{\[Alpha]010, .01, "y-axis"}, -\[Pi], \[Pi], ImageSize -> Small}, {{\[Alpha]100, .01, "x-axis"}, -\[Pi], \[Pi], ImageSize -> Small}, Delimiter, "Move front/back", {{dx, -.40}, -1, 1, .01, ImageSize -> Small}, Delimiter, SynchronousUpdating -> False]  If we rotate the reflection of the cube frame around the z - axis (right) or the y - axis (left) and track the anamorphic image, we get this GIF : We can also do this for the RhombicHexecontahedron or spikey! (here rotated around the z-axis) As I did for the cylindrical mirror anamorphosis on my community contribution: Anamorphosis of 3D-Objects & 3D Printing, the mesh of the "Utah Teapot" can also be used after appropriate scaling. getAndRescale[example_String] := Module[{data, ranges, maxRange, temp1, temp2}, data = ExampleData[{"Geometry3D", example}, "PolygonObjects"]; ranges = MinMax@Flatten[data[[All, 1]], 1][[All, #]] & /@ Range[3]; maxRange = MaximalBy[Most@ranges, Abs[Subtract @@ #] &]; temp1 = MapAt[Rescale[#, First@maxRange, {-1, 1}] &, data, {All, 1, All, 1}]; MapAt[Rescale[#, Last@ranges, {0, 2*Subtract @@ ranges[[3]]/Subtract @@ ranges[[1]]}] &, temp1, {All, 1, All, 3}]] Module[{\[Phi], pts, pts0, offset, ri, data, anaData}, offset = 1/5; ri = Sqrt[1 - offset^2]; \[Phi] = ArcTan[5, 2.5]; (*clippane anchors*) pts0 = {{offset, 0, 0}, {offset, ri, 0}, {offset, 0, ri}}; pts = RotationMatrix[-\[Phi], {0, 1, 0}].# & /@ pts0; data = getAndRescale[ "UtahTeapot"] /. {x_?NumericQ, y_?NumericQ, z_?NumericQ} -> .7 {y - .65, x, z - .5}; anaData = ParallelMap[(*adapted function sphericalAnamorphMap3D in s"pikey \ gor ptnting.nb" attached*) sphericalAnamorphMap3D[#, {5, 2.5}] &, data, {3}]; Graphics3D[{ {Gray, Opacity[.25], InfinitePlane[{{0, 0, -1}, {0, 1, -1}, {1, 0, -1}}]}, {(*spherical mirror*) Style[Sphere[], Specularity[White, 25], Gray, Opacity[.24], ClipPlanes -> InfinitePlane[pts]]}, {FaceForm[Lighter[Orange, .85]], EdgeForm[{Thin, Black}], data, FaceForm[Lighter[Orange, .65]], anaData}, Opacity[.25]}, Boxed -> False]]  These are two perpendicular views of the teapot reflection and its corresponding anamorphic image. I printed the the right teapot on iMaterialise (STL file "utahTeapot.stl" attached). teapot = Graphics3D[anaData]; Printout3D[teapot, "utahTeapot.stl", TargetUnits -> "Centimeters", RegionSize -> 7.25]; Printout3D[teapot, "IMaterialise", TargetUnits -> "Centimeters", RegionSize -> 7.25]  This is a photo of the printed anamorphic teapot reflected in a 7cm diameter reflective Christmas ball. Enjoy 3D spherical anamorphism printing. Attachments:
4 Replies
Sort By:
Posted 2 years ago
 Hello Erik, I am very curious about your project, and was wondering if we could communicate over pm for some questions that I have? Thank you.
Posted 5 years ago
 Thanks Frederick for your interest and nice compliment! Here is an article that might interest you (unfortunately in French but with a lot of drawings, code and formulas...) "Images dans un miroir sphérique" by Henri BouasseHe treats about reflection in a sphere. It is clear from this article that the math and coding of reflection is way more complicated than anamorphism. Something I also realized during my "experiments".This is one of his examples and he explains the math and geometry of reflection of spheres, cylinders, cubes, etc. in a special mirror.
Posted 5 years ago
 Erik's Anamorphic Reflections Seasons (2D and 3D, cylindrical and sphere) are much more exciting and certainly more productive than "The Game of Thrones".Something is similar. I printed a 3D spikey model ?top image?a few months before. Later one of my friends took a photo with a crystal ball ?bottom image?. Its interesting to compare the result of spherical lens and spherical mirror. And notice their difference. It's interesting to modeling a spherical lens with Mathematica. Later it's possible to combine mirrors and lens to build more complex optical system.
Posted 5 years ago
 - Congratulations! This post is now a Staff Pick as distinguished by a badge on your profile! Thank you, keep it coming, and consider contributing your work to the The Notebook Archive!