Message Boards Message Boards

GROUPS:

Return of Christmas ball: reflection on spherical mirror

Posted 1 year ago
3213 Views
|
5 Replies
|
8 Total Likes
|

enter image description here

Curved mirrors are exciting because of their interesting deformations. But geometrically perfect curved mirrors are not easy to come by. Cylindrical mirrors can be hand made relatively simple with reflective film but conical mirrors require machining or 3D printing and chemical chrome plating. Luckily, we have spherical mirrors and around Christmas, they are everywhere! I bought a new set of these and used Mathematica to study some new features of reflection and anamorphosis.

I made two functions for a convex sphere-shaped mirror with radius 1 (here called a "spherical mirror") and a viewpoint at infinity. The relatively small size of the mirror compared to the view distance simplifies the functions considerably:

  1. a function for reflection: sphericreflectionMap[{x,y},h] will find the (virtual) reflection R of the point S {x,y,h} located in the plane z=h

  2. a function for its inverse: sphericAnamorphosisMap[{y,z},h] will compute the coordinates of a point S in the plane z=h reflecting as point R{0,y,z}.

enter image description here

Applying the law of reflection: a point S on a plane z=h emits a light ray reflected by the mirror at Q and the eye at V observes the point as R. n is the normal to the sphere at Q and the angles SQN and VQn are equal.

sphericReflectionMap[{xs_, ys_}, h_ : 1] := 
 Quiet[Module[{ptC = {0, 0, 0}, plane, ptQ, solI, xv = 1000000}, 
   plane = InfinitePlane[{ptC, {xv, 0, 0}, {xs, ys, h}}]; 
   ReplacePart[
    First[{x, y, z} /. 
      NSolve[{{x, y, z} \[Element] Sphere[], {x, y, z} \[Element] 
         plane, x Sqrt[(x - xs)^2 + (y - ys)^2 + (z - h)^2] == -x^2 + 
          x xs - y^2 + y ys + z (-z + h), x > 0}]], 1 -> 0]]]
sphericAnamorphosisMap[{yi_, zi_}, h_ : 1] := 
 Module[{x, y, z, sh, ptI, ptV, solQ, ptQ, eqns, sol}, 
  sh = Sign[zi] Abs[h]; ptV = {1000000, 0, 0}; 
  solQ = NSolve[{x, y, z} \[Element] 
      HalfLine[{{0, yi, zi}, ptV}] && {x, y, z} \[Element] 
      Sphere[], {x, y, z}]; ptQ = First[{x, y, z} /. solQ]; 
  eqns = {RegionMember[
     HalfLine[{ptQ, ReflectionTransform[ptQ][-ptV]}], {x, y, sh}], 
    RegionMember[
     InfinitePlane[{{0, 0, sh}, {1, 0, sh}, {0, 1, sh}}], {x, y, 
      sh}]}; sol = Quiet[NSolve[eqns, {y, x}][[1]]]; {x, y, sh} /. 
   sol]

The two above functions are the inverse of each other. For example each new random point pnt in the plane z=2 will be reflected as a point whose anamorphic map is again the same point pnt. This computes the (negligible) difference between the two pnt:

With[{r = 10, h = 2}, pnt = RandomPoint[Rectangle[{-r, -r}, {r, r}]]; 
 Most[sphericAnamorphosisMap[Rest[sphericReflectionMap[pnt, h]], h]] -
   pnt]

enter image description here

This is an example of application of the functions: 1. left : a circle in the plane z=-2.5 is reflected as an oval shaped curve, computed by sphericReflectionMap 2 right: an oval curve in z=-2.5, computed by sphericAnamorphosisMap is reflected as a circle in a spheric mirror

enter image description here

It can be observed that all of our surrounding space is reflected in a sphere shaped mirror. We can explore this by looking for the range and domain of the functions sphericReflectionMap and sphericAnamorphosisMap using random points . This shows the reflection in a spherical mirror of 1000 random points in the planes z=-2 and z=+2. Even if we extend the domain to the complete infinite planes z=+/-2, the range is limited to the upper or lower half-disks inside the mirror.

Module[{h = 3, r = 10, n = 1000, pnts, reflectedPntsBotttom, 
  reflectedPntsTop}, 
 pnts = RandomPoint[Rectangle[{-r, -r}, {r, r}], n]; 
 reflectedPntsBotttom = 
  ParallelMap[sphericReflectionMap[#1, -h] &, pnts]; 
 reflectedPntsTop = ParallelMap[sphericReflectionMap[#1, h] &, pnts]; 
 mirror = {{Opacity[.15], Lighter[Blue, .75], 
    Sphere[]}, {Opacity[.25], 
    Style[Sphere[], Blue, Specularity[White, 25], 
     ClipPlanes -> 
      InfinitePlane[{{0, 0, 0}, {0, 1, 0}, {0, 0, 
         1}}]]}, {Opacity[.2], 
    Cylinder[{{-.01, 0, 0}, {0, 0, 0}}, 1]}}; 
 Graphics3D[{mirror, {Opacity[.25], (InfinitePlane[{{0, 0, #1}, {1, 
          0, #1}, {0, 1, #1}}] &) /@ {-h, h}}, AbsolutePointSize[1.5],
    Red, Point[pnts /. {x_, y_} -> {x, y, -h}], Blue, 
   Point[pnts /. {x_, y_} -> {x, y, h}], AbsolutePointSize[.75], Red, 
   Point[reflectedPntsBotttom], Blue, Point[reflectedPntsTop]}, 
  Lighting -> "Accent", PlotRange -> {{-10, 10}, {-10, 10}, {-h, h}}, 
  Axes -> True]]

enter image description here

Points at infinity are reflected on the rim of the reflection half-disks. Points on the rim of the half-disk have their anamorphic map at infinity. For all practical applications, we have to stay away from the rims. This shows the four keypoints along the rim of the lower reflection half-disk (left) and their anamorphic map (right).

enter image description here

A first practical test of our functions is to fill up the two half-disks to a reasonable distance from the rim. Below is a help function to convert a letter to a FilledCurve with provisions for scaling (sc) and centering (dx,dy). Since FilledCurve is not supported in 3D, we convert the FilledCurve to a Line object.

horizontalLetter2D[lt_, sc_, dx_, dy_] :=
First[First[
ImportString[
ExportString[Style[lt, FontFamily -> "Times", FontSize -> 72], 
"PDF"], "TextMode" -> "Outlines"]]] /. {x_?NumericQ, y_} :> 
RotationMatrix[Pi/2] . {x, y}/sc /. {x_?NumericQ, 
y_} :> {x + dx, y + dy};
horizontalLetter3D[lt_, sc_, dx_, dy_] := 
horizontalLetter2D[lt, sc, dx, 
dy] /. {x_?NumericQ, y_?NumericQ} :> {0, x, y} /. 
FilledCurve[a_, b_] -> Line[b]
Graphics[{Circle[], horizontalLetter2D["A", 85, -.2, -.7], 
horizontalLetter2D["B", 85, +.75, -.65], 
horizontalLetter2D["C", 85, +.75, .3], 
horizontalLetter2D["D", 95, -.15, .25]}, Axes -> True, 
ImageSize -> Small]

enter image description here

anaHorizontalLetter2D[lt_, sc_, dx_, dy_] := 
 MapAt[Most[sphericAnamorphosisMap[#1, 3]] &, 
  horizontalLetter2D[lt, sc, dx, dy], {-1, 1, 1, -1, All, All}]
anaHorizontalLetter3D[lt_, sc_, dx_, dy_] := 
 MapAt[sphericAnamorphosisMap[#1, 3] &, 
   horizontalLetter2D[lt, sc, dx, dy], {-1, 1, 1, -1, All, All}] /. 
  FilledCurve[a_, b_] -> Line[b]
Graphics3D[{{Opacity[.25], {{Opacity[.15], Lighter[Blue, .75], 
     Sphere[]}, 
    Style[Sphere[], Blue, Specularity[White, 25], Opacity[.13], 
     ClipPlanes -> 
      InfinitePlane[{{0, 0, 0}, {0, 1, 0}, {0, 0, 
         1}}]]}}, {horizontalLetter3D["A", 85, -.2, -.7], 
    horizontalLetter3D["B", 85, +.75, -.65], 
    horizontalLetter3D["C", 85, +.75, .3], 
    horizontalLetter3D["D", 95, -.15, .25]} /. 
   Thickness[_] :> 
    AbsoluteThickness[1], {anaHorizontalLetter3D["A", 85, -.2, -.7], 
    anaHorizontalLetter3D["B", 85, +.75, -.65], 
    anaHorizontalLetter3D["C", 90, +.75, .3], 
    anaHorizontalLetter3D["D", 105, -.15, .25]} /. 
   Thickness[_] :> AbsoluteThickness[3], {AbsoluteThickness[2], 
   Line[{{-6, -8, -3}, {-6, 6, -3}, {6, 
      6, -3}, {7, -8, -3}, {-6, -8, -3}}], 
   Line[{{-6, -8, 3}, {-6, 6, 3}, {6, 6, 3}, {7, -8, 3}, {-6, -8, 
      3}}]}}, PlotRange -> {{-6, 7}, {-8, 6}, {-3, 3}}, 
 Boxed -> False]

enter image description here

Above, we have the printout of the previous code (L) and the real world reflection in a Christmas ball hanging between two prints of the converted anamorphic letters (R). Now, we are ready to reflect two famous Christmas symbols in our Christmas-ball mirror. First the Xmas tree: these 15 points define the outline of a tree to be reflected in the lower half-disk:

xmasTree = {{-0.714, -0.571}, {-0.286, -0.771`}, {-0.286, -0.671`}, \
{0., -0.857}, {0.`, -0.714`}, {0.286, -0.9`}, {0.28600, -0.614`}, \
{0.571, -0.671`}, {0.571, -0.471}, {0.286, -0.529`}, {0.286, \
-0.243`}, {0.`, -0.429`}, {0., -0.286}, {-0.286, -0.471}, {-0.286, \
-0.371`}, {-0.714, -0.571}};
Graphics[{Circle[], FaceForm[Green], EdgeForm[AbsoluteThickness[3]], 
  Polygon[xmasTree]}, Axes -> True]

enter image description here

To get the correctly reflected shape, we need to interpolate a sufficient number of points between the original ones. The following function will interpolate enough points between pnt1 and pnt2 to reduce the distance between them to d. Applied to the original 15, this results in 90 points and a more accurate reflection if sphericAnamorphosisMap is applied resulting in curved lines between the original 15 keypoints:

interpol[{pnt1 : {x1_, y1_}, pnt2 : {x2_, y2_}}, d_ : 0.1] := 
 Module[{n}, n = EuclideanDistance[pnt1, pnt2]/d + 0.001`; 
  Table[(1 - t) pnt1 + t pnt2, {t, 0, 1, 1/n}]]
xmasTreePoints = (interpol[#1, .05] &) /@ 
   Partition[xmasTree, 2, 1, {1, 1}];
anaXmasTreePoints = 
  ParallelMap[Most[sphericAnamorphosisMap[#1, 2]] &, 
    xmasTreePoints, {2}] /. {x_?NumericQ, y_} -> {x, -y};
Graphics[{FaceForm[Green], EdgeForm[AbsoluteThickness[5]], 
  Polygon[Flatten[anaXmasTreePoints, 1]]}]

enter image description here

We do the same actions for a star shape to be reflected in the upper half-disk...

xmasStar = 
  Table[{Cos[(2 Pi k 2)/5.], Sin[(2 Pi k 2)/5.]}, {k, 
     5}] /. {x_?NumericQ, y_} -> {x, y + 1.25}/2.5;
Graphics[{Circle[], FaceForm[Yellow], EdgeForm[AbsoluteThickness[3]], 
  Polygon[xmasStar]}, Axes -> True]

enter image description here

xmasStarPoints = 
  interpol[#, .05] & /@ Partition[xmasStar, 2, 1, {1, 1}];
anaXmasStarPoints = 
  ParallelMap[Most[sphericAnamorphosisMap[#, 2]] &, 
    xmasStarPoints, {2}] /. {x_?NumericQ, y_} -> {x, -y};
Graphics[{FaceForm[Yellow], EdgeForm[AbsoluteThickness[5]], 
  Polygon@Flatten[anaXmasStarPoints, 1]}]

enter image description here

... and we put it all together in a Graphics3D (L) and in a real world setup reflected in a hanging Christmas ball!

Graphics3D[{mirror, {{FaceForm[Green], EdgeForm[AbsoluteThickness[1]],
     Polygon@
      Flatten[xmasTreePoints, 1] /. {x_?NumericQ, y_} -> {0, -x, -y}, 
    EdgeForm[AbsoluteThickness[3]], 
    Polygon@Flatten[anaXmasTreePoints, 1] /. {x_?NumericQ, y_} -> {-x,
        y, 2}}}, {{FaceForm[Orange], EdgeForm[AbsoluteThickness[1]], 
    Polygon@Flatten[xmasStarPoints, 1] /. {x_?NumericQ, 
       y_} -> {0, -x, -y}, EdgeForm[AbsoluteThickness[3]], 
    Polygon@Flatten[anaXmasStarPoints, 1] /. {x_?NumericQ, y_} -> {-x,
        y, -2}}}, {AbsoluteThickness[3], 
   Line[{{-6, -5, -2}, {-6, 6, -2}, {6, 
      6, -2}, {7, -5, -2}, {-6, -5, -2}}], 
   Line[{{-6, -5, 2}, {-6, 6, 2}, {6, 6, 2}, {7, -5, 2}, {-6, -5, 
      2}}], AbsoluteThickness[2], Blue, 
   Line[{{0, 1, 0}, {0, 6, 0}}]}}, Boxed -> False, ImageSize -> 250]

enter image description here

5 Replies

Fantastic work Erik. Thank you for sharing.

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 1 year ago

In your 4th code-box the first row is missing, i.e.:

horizontalLetter2D[lt_, sc_, dx_, dy_] :=

and in the last code-box you used different variable names then in the code-box before (interStar instead of xmasStarPoints, anaStar instead of anaXmasStarPoints). It should read:

Graphics3D[{mirror, {{FaceForm[Green], EdgeForm[AbsoluteThickness[1]],
     Polygon@
      Flatten[xmasTreePoints, 1] /. {x_?NumericQ, y_} -> {0, -x, -y}, 
    EdgeForm[AbsoluteThickness[3]], 
    Polygon@Flatten[anaXmasTreePoints, 1] /. {x_?NumericQ, y_} -> {-x,
        y, 2}}}, {{FaceForm[Orange], EdgeForm[AbsoluteThickness[1]], 
    Polygon@Flatten[xmasStarPoints, 1] /. {x_?NumericQ, 
       y_} -> {0, -x, -y}, EdgeForm[AbsoluteThickness[3]], 
    Polygon@Flatten[anaXmasStarPoints, 1] /. {x_?NumericQ, y_} -> {-x,
        y, -2}}}, {AbsoluteThickness[3], 
   Line[{{-6, -5, -2}, {-6, 6, -2}, {6, 
      6, -2}, {7, -5, -2}, {-6, -5, -2}}], 
   Line[{{-6, -5, 2}, {-6, 6, 2}, {6, 6, 2}, {7, -5, 2}, {-6, -5, 
      2}}], AbsoluteThickness[2], Blue, 
   Line[{{0, 1, 0}, {0, 6, 0}}]}}, Boxed -> False, ImageSize -> 250]

Then everything is working fine:)

Posted 1 year ago

Was a negligent “copy/paste”! Thanks for your correction Oliver!

Congratulations! Your post was highlighted on the Wolfram's official social media channels. Thank you for your contribution.  We are looking forward to your future posts.

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