Anamorphosis and reflection between a Conical Mirror and a Cylinder

Posted 3 years ago
4749 Views
|
|
5 Total Likes
| Catoptric or mirror anamorphoses are deformed images that can only be seen undeformed with the help of a mirror. Here, we experiment with a conical mirror surrounded by a vertical cylindrical surface. We want to compute points of a deformed (anamorphic) image on the cylinder's inner surface such that it is perceived by the viewer as an undeformed image when looking down in the cone shaped mirror. The above drawing shows the anamorphic setup: a conical mirror (radius r=1, height=h), surrounded by a cylindrical surface (radius R>r). The viewpoint V is along the vertical axis of the cylinder (at infinity relative to the size of the cone). A point S (xa,ya,za) on the cylinder's inner surface is reflected by the mirror at Q to the viewer's eye at V. The viewer perceives the point at I (xi,yi,0). The lines VQ and SQ form equal angles with the normal to the sphere at Q. The above animation demonstrates the relation between the point I traveling along a straight line while its anamorphic map follows a curve on the inner surface of the cylinder. We now write a function that expresses this geometric relationship: cone2Cylinder[imagePoint : {xi_, yi_}, coneHeight : h_, cylinderRadius : R_] := {(R xi)/Sqrt[xi^2 + yi^2], (R yi)/Sqrt[ xi^2 + yi^2], h - h Sqrt[ xi^2 + yi^2] + (-R + Sqrt[xi^2 + yi^2]) Cot[2 ArcTan[1/h]]} This function maps an image point to an anamorphic point. To test our function, we use again one of the logos generated by the Wolfram Demonstration "Character Rotation Patterns" by Chris Carlson.Which, after converting to a GraphicsComplex looks like this: ig = ImageGraphics[sun, 2, Method -> "Exact"]; lines = Normal[ig][[1, -1]] /. FilledCurve -> Identity; scaledLines = Map[#/948 - .5 &, lines, {6}] Graphics[{Thick, scaledLines}] We now compute the point coordinates of the lines in the GraphicsComplex to their anamorphic map {xa,ya,za} using the function cone2Cylinder. anaLines = Map[anaCone2Cylinder[#, 1.57, 1.15] &, scaledLines, {5}]; Graphics3D[{{Opacity[.2], White, Cylinder[{{0, 0, .3}, {0, 0, 1.2}}, 1.25]}, AbsoluteThickness, %}, Boxed -> False] We then convert the anamorphic 3D drawing to the 2 dimensional developed interior face of the cylinder as {ArcTan[xa,ya} , za}. This GIF illustrates the unfolding of the cylindrical image: developLineCoordinates = Flatten[Map[{ArcTan @@ Most[#], Last[#]} &, anaLines, {5}][[-1]], 1][[All, 1]]; lstPP = Partition[#, 2, 1] & /@ developLineCoordinates; DeleteCases[#, _?(EuclideanDistance @@ # > 1 &)] & /@ lstPP; Graphics[{AbsoluteThickness, Line /@ %}, FrameTicks -> None, Frame -> True, ImageSize -> 600] develop = Image[%]; After printing the cylinder development to the right size (52 cm by 14 cm), it is glued around a cardboard cylinder (radius 8 cm). A home made conical mirror (base radius 7 cm, height 12 cm) is put inside the cylinder at the center. The anamorphic image on the cylinder wall is reflected as the undeformed original by the conical mirror. Here is the result: (the center is hidden by a coin resting at the top of the cone since anamorphic maps of points close to the cone center are off at infinite height on the cylinder wall) Another application of the function is to use one of the many popular curves (".....-like curve" ) that can be extracted using Interpreter Interpreter["PopularCurve"]["bunny-like curve"]; bugsbunnyPrimitives = First@Cases[ First[ParametricPlot[ Entity["PopularCurve", "BunnyCurve"]["ParametricEquations"][ t], {t, 0, 30 \[Pi]}]] /. {x_?NumericQ, y_?NumericQ} :> {x - 85, y - 50}/800, _Line, \[Infinity]]; The anamorphic map is created by applying anaCone2Cylinder to the point coordinates: anaBunny = Map[anaCone2Cylinder[#, 1.755, 1.25] &, bugsbunnyPrimitives, {2}]; Animate[Graphics3D[ Rotate[{{Opacity[.2], White, Cylinder[{{0, 0, .25}, {0, 0, 1}}, 1.25]}, AbsoluteThickness, Red, anaBunny}, \[Phi], {0, 0, 1}], Boxed -> False], {\[Phi], 0, 2 \[Pi]}] This is the developed cylinder: developRules = {x_?NumericQ, y_?NumericQ, z_?NumericQ} :> {ArcTan[x, y], z}; developed = anaBunny /. developRules; DeleteCases[ Partition[developed[], 2, 1], _?(EuclideanDistance @@ # > 1 &)]; Graphics[{Red, AbsoluteThickness, Line /@ %}, FrameTicks -> None, Frame -> True] And the result, printed, glued inside a cylinder and using the same setup as in the previous example:  Answer - 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! Answer