Message Boards Message Boards

Reflection and Anamorphism in a Hanging Conical Mirror

Posted 3 years ago

enter image description here

I took the chrome plated conical mirror used in my previous Wolfram Community contribution, suspended it upside down, and asked myself the (anamorphism) question : what should a (deformed) image look like to be reflected in this mirror as the (undeformed) original? We can use Mathematica to solve this problem!

enter image description here

1. Geometry of reflection in a hanging conical mirror enter image description here

An observer looking from a viewpoint at V in the direction of the cone, will see the point S reflected as the point I. Q is the intersection point of the view line VI with the cone. This function computes this intersection:

viewlineConeIntersection[{yi_, zi_}, {xv_, zv_}, h0_, h_] := 
 Module[{t1, t2}, 
  t1 = Sqrt[-h^2 xv^2 yi^2 + h0^2 (xv^2 + yi^2) + xv^2 zi^2 + 
     yi^2 zv^2 - 2 h0 (xv^2 zi + yi^2 zv)];
  t2 = 1/(h^2 (xv^2 + yi^2) - (zi - zv)^2);
  {t2 xv ((h0 - zi) (zi - zv) + h (h yi^2 + t1)), 
   t2 yi (h^2 xv^2 + (h0 - zv) (-zi + zv) - h t1), 
   t2 (-h0 (zi - zv)^2 + h^2 (xv^2 zi + yi^2 zv) + h (-zi + zv) t1)}]

With the help of viewlineConeIntersection, the following function computes the intersection of the reflection line IQ with the x-y plane. This intersection is the anamorphic map of I.

hangingConeAnamorphicMap[{yi_, zi_}, {xv_, zv_}, h0_, h_] := 
 Quiet[Module[{mirror, ptI, ptV, imageTriangle, vwLine, xq, yq, zq, 
    ptQ, xn, yn, zn, ptVr}, 
   mirror = Cone[{{0, 0, h0 + h}, {0, 0, h0}}, 1]; ptI = {0, yi, zi}; 
   ptV = {xv, 0, zv}; 
   imageTriangle = 
    Triangle[{{0, 0, h0}, {0, -1, h + h0 - .001}, {0, 1, 
       h + h0 - .001}}]; 
   If[! RegionMember[imageTriangle, {0, yi, zi}], {yi, zi} = 
     Rest[RegionNearest[imageTriangle, {0, yi, zi}]], {yi, zi}]; 
   vwLine = Line[{ptI, ptV}]; {xq, yq, zq} = 
    viewlineConeIntersection[{yi, zi}, {xv, zv}, h0, h]; 
   ptQ = {xq, yq, zq}; {xn, yn} = Normalize[{xq, yq}]; 
   zn = -Sin[ArcTan[1/h]]; 
   ptVr = ReflectionTransform[{xn, yn, zn}, ptQ][ptV]; 
   Solve[{{x, y, z} \[Element] HalfLine[{ptVr, ptQ}] && z == 0}, {x, 
      y, z}][[1, All, -1]]]]

This is the function in action as the pointS follows the anamorphic map of a reflected circle:

enter image description here

2. Preparing the images

It is clear that the points I all will have to belong to the triangular region Triangle[{{-1,51.98/30},{1,51.98/30},{0,0}}]. The following code computes the function range staring from its triangular domain.

Module[{xv = 5., zv = 3., r = 1, h = 51.98/30, h0 = .5, triangle, 
  circlePts, anaCirclePts, trianglePts, anaTrianglePts}, 
 triangle = Triangle[{{-h0 - .02, 0}, {-h0 - h, 1}, {-h0 - h, -1}}]; 
 trianglePts = 
  DeleteDuplicates[
   RegionNearest[triangle, 
     CirclePoints[{0, (h0 + h)/2}, 4, 1000]] /. {x_?NumericQ, 
      y_} :> {y, -x}]; 
 anaTrianglePts = 
  DeleteCases[
   ParallelMap[Most[hangingConeAnamorphicMap[#1, {xv, zv}, h0, h]] &, 
    trianglePts], {}]; 
 Grid[{Style[#, Bold, 14] & /@ {"Domain", "Range"}, {Rotate[
     Graphics[{HatchFilling[], FaceForm[LightGray], 
       EdgeForm[AbsoluteThickness[1.5]], triangle}, 
      PlotRange -> {{-4, 2}, {-2, 2}}, Axes -> True, 
      TicksStyle -> Small, ImageSize -> 400], -Pi/2], 
    Rotate[Graphics[{HatchFilling[], FaceForm[LightGray], 
       EdgeForm[AbsoluteThickness[1.5]], FaceForm[Lighter[Gray, .85]],
        Polygon[anaTrianglePts]}, 
      PlotRange -> {{-4, 2.5}, {-4.5, 4.5}}, Axes -> True, 
      TicksStyle -> Small, ImageSize -> 300], -Pi/2]}}]]

enter image description here

The reflection appearing in the inverted cone will maximum be triangular in shape or at least fit inside a triangle. In our case (we suspend the cone with its tip at .5 above the x-y plane), this is the triangle Triangle[{{-1,51.98/30},{1,51.98/30},{0,0}}]:

Graphics[{EdgeForm[Black], HatchFilling[], FaceForm[LightGray], 
  Triangle[{{-1, 51.98/30}, {1, 51.98/30}, {0, 0}}] /. {x_?NumericQ, 
     y_} :> {x, y + 0.5}}, Axes -> True, AxesOrigin -> {0, 0}]

enter image description here

In order to fit an image inside this triangle, we need a function that convert the image to a set of colored polygons that fit into the triangle (or other) region.

Module[{mandrill, irc},
 mandrill = ImageResize[ExampleData[{"TestImage", "Mandrill"}], 100];
 irc = imageRegionCrop[mandrill, 
   Region@Triangle[{{-.99, 1}, {.97, 1}, {-.01, -.97}}]];
 Graphics[{irc /. {x_?NumericQ, y_} :> {x, y + 1.5}, FaceForm[], 
   EdgeForm[Black], 
   Triangle[{{-.99, 1}, {.97, 1}, {-.01, -.97}}] /. {x_?NumericQ, 
      y_} :> {x, y + 1.5}}, Axes -> True, 
  AxesOrigin -> {0, 0} Axes -> True, AxesOrigin -> {0, 0}]]

enter image description here

3. 3D simulation in Mathematica

Now, we convert the triangular set of colored polygons into its anamorphic map with our function hangingConeAnamorphicMap. With Graphics3D, we can see a simulation of how the anamorphic image will look reflected in the hanging cone:

Module[{r = 1., h = 51.98/30, h0 = .5, xv = 5, zv = 3.5, mirrorCone, 
  ptV, imageTriangle, img, splitLogo, pixelPolys, anaPolys},
 mirrorCone = Cone[{{0, 0, h0 + h}, {0, 0, h0}}, r];
 ptV = {xv, 0, zv};
 imageTriangle = 
  Triangle[{{0, 0, h0}, {0, -r, h + h0}, {0, r, h + h0}}];
 img = ImageResize[ExampleData[{"TestImage", "Mandrill"}], 200]; 
 splitLogo = 
  imageRegionCrop[img, 
   Triangle[{{-1, 51.98/30/2.}, {1, 
      51.98/30/2.}, {0, -51.98/30/2.}}]]; 
 pixelPolys = splitLogo /. {x_?NumericQ, y_} :> {x, y + 1.5};
 anaPolys = 
  DeleteCases[
   MapAt[hangingConeAnamorphicMap[#, {5, 1.367}, .5, 51.98/30] &, 
     pixelPolys, {All, -1, All, All}] /. {x_?NumericQ, y_, z_} :> {x, 
      y}, {z == 0}, \[Infinity]];
 Graphics3D[{{LightGray, 
    InfinitePlane[{{0, 0, 0}, {1, 0, 0}, {0, 1, 0}}]},
   {Opacity[.35], LightGray, Specularity[1, 2], 
    mirrorCone}, {AbsoluteThickness[2], 
    Line[{{0, 0, h + h0 + 2}, {0, 0, h + h0}}], AbsolutePointSize[3], 
    Point[{0, 0, h + h0 + 22}]},
   {FaceForm[], EdgeForm[{Blue, AbsoluteThickness[.5]}], 
    imageTriangle},
   pixelPolys /. {y_, z_} :> {0, y, z},
   anaPolys /. {x_?NumericQ, y_} :> {x, y, 0.001}}]]

enter image description here

5. Real world testing

To test this in a real world setting, we need a printout of the anamorphic image...

Graphics[{{Thin, Circle[]}, anaPolys}]

enter image description here

...locate the printout under our hanging conical mirror....

enter image description here

...and see the result reflected as the original and undeformed image!

enter image description here

POSTED BY: Erik Mahieu
3 Replies
Posted 3 years ago

Cool~!

POSTED BY: Dusun Hwang

enter image description here -- you have earned Featured Contributor Badge enter image description here

Your exceptional post has been selected for our editorial column Staff Picks http://wolfr.am/StaffPicks and Your Profile is now distinguished by a Featured Contributor Badge and is displayed on the Featured Contributor Board. Thank you!

POSTED BY: Moderation Team

Fantastic! thanks for sharing!

POSTED BY: Sander Huisman
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract