It looks hard to decipher the text in the above image : that's because it is a cylindrical anamorphic image. This means you need a cylindrical mirror and a specific viewpoint to interpret the image correctly. I made several Wolfram Demonstrations about this type of anamorphism in the past. This drew the attention of a Brazilian friend who sent me an article about a remarkable example of cylindrical anamorphosis in the São Paulo República metro station by Antonio Peticov. See the website: "Underground collection: art in São Paulo subway"
In my past demonstrations, the viewer has to look down on a deformed image on the floor to see the real image reflected. Here however, the viewer has to look upward to see the anamorphic image on the ceiling reflected as an undeformed image in the cylindrical mirror. This appeared to me like an unexpected extension of my previous contributions and I set myself to work with Mathematica to see if I could reproduce this type of anamorphic art. First the geometry:
A point S on the floor (left) or ceiling (right) will emit a light-ray SQ that reflects as QV to the viewer's eye at V. With the eye at V, a person looks downward (left) or upward (right) and sees a point S on the ceiling as a point I reflected in the cylindrical mirror. The points S, Q, V and I are all in the same plane and n is the normal to the cylinder at Q and the rays sQ and vQ will form equal angles with n.
To make it compatible with both floor- and ceiling anamorphosis, I modified the function used in my demonstrations. The function has to detect if the viewer is looking up- or downward by comparing the z coordinates of the viewer (at V) and the image point (at I).
The new function cylAnamorphMap performs 3 steps:
Find Q, the intersection point of the view line VI and the cylinder
(assumed to have unit radius)
Find the symmetrical of the view line VQI to the normal n to
cylinder at Q
Find the intersection point S of the symmetric view line with the
horizontal plane plane at z=0 (floor level) or z=h (ceiling height).
This point S is the anamorphic map of the image point I.
cylAnamorphMap[{xi_, zi_}, {yv_, zv_}, h_] :=
Module[{ptV, ptI, ptQ, ptVv}, ptV = {0, yv, zv};
ptI = {xi, 1/yv, zi};
ptQ = {x, y, z} /.
First[NSolve[{Element[{x, y, z}, HalfLine[{ptI, ptV}]] &&
x^2 + y^2 == 1}, {x, y, z}]];
ptVv = ReflectionTransform[ReplacePart[ptQ, 3 -> 0], ptQ][ptV]; {x,
y, z} /. First[
NSolve[{Element[{x, y, z}, HalfLine[{ptVv, ptQ}]] &&
z == If[zv > zi, 0, h]}, {x, y, z}]]]
The following GIF's show the function in action on a point moving around a circle and around its anamorphic map on the floor (left) or the ceiling (right)
To test our function in practice, we first try an experiment with a text message. The following code scales and centers the text and converts it into a FilleCurve object:
loveCeiling[h0_] :=
First[First[
ImportString[
ExportString[
Style["\[Star] What the\n \[HeartSuit] World \[Star]\n\
\[Star]needs now", FontFamily -> "American Typewriter",
FontWeight -> "SemiBold", LineSpacing -> {0, 12}], "PDF"],
"TextMode" -> "Outlines"]]] /. {x_?NumericQ,
y_?NumericQ} :> {x, y} .033 /. {x_?NumericQ,
y_?NumericQ} :> {x - .92, y + .9 + h0};
loveFloor[h0_] :=
First[First[
ImportString[
ExportString[
Style["\n \[HeartSuit] is Love \[Star]\n \
\[Star]\[Star] sweet \[Star]\[Star]\n \[HeartSuit]\[HeartSuit] \
Love \[HeartSuit]\[HeartSuit]", FontFamily -> "American Typewriter",
FontWeight -> "SemiBold", LineSpacing -> {0, 12}], "PDF"],
"TextMode" -> "Outlines"]]] /. {x_?NumericQ,
y_?NumericQ} :> {x, y} .036 /. {x_?NumericQ,
y_?NumericQ} :> {x - 1.21, y - .05 + h0};
love[h0_] := Join[loveFloor[h0], loveCeiling[h0]];
Graphics[love[.5], Axes -> True, AxesOrigin -> {-1., 0.35},
ImageSize -> Small]
We now use the function cylAnamorphMap to create the anamorphic map printout for the floor (left) or the ceiling (right):
Module[{ptsFloor, ptsCeiling, anaPtsFloor,
anaPtsCeiling}, {ptsFloor, ptsCeiling} =
DeleteCases[love[.05], Thickness[_], \[Infinity]] /.
FilledCurve[_, pts_] :> pts /. {x_?NumericQ, y_} :> # & /@ {{-x,
y}, {x, -(y - 1.) + 1.}};
{anaPtsFloor, anaPtsCeiling} =
ParallelMap[
Most[cylAnamorphMap[#1, {10., 7}, 10]] &, #, {5}] & /@ {ptsFloor,
ptsCeiling};
GraphicsRow[
Graphics[{Circle[], Map[Line, #, {3}]}] & /@ {anaPtsFloor,
anaPtsCeiling}]]
We put a cylindrical mirror on top of the two printouts and look at the reflection: this is a photograph of the reflection of the floor image looking downward in the mirror (left) and the reflection of the ceiling image looking upward (right).
Next we take a photographic image. Since our function cylAnamorphMap operates on 2-dimensional coordinates, we have to convert the image information into an array of coordinates (squares) and their corresponding colors. The following code will divide a photo into an array of colored squares.
square[center : {x_,
y_}] :=(*gives the coordinates of a unit square centered around \
{x,y}*)With[{s = .5}, {{x - s, y - s}, {x - s, y + s}, {x + s,
y + s}, {x + s, y - s}}]
convert2Squares[image_] :=
Module[{xi, yi, centers, densities},
{xi, yi} = ImageDimensions[image];
centers = ParallelTable[{x, y}, {x, .5, xi}, {y, 0.5, yi}];
densities =
ParallelMap[RGBColor@ImageValue[image, #] &, centers, {2}];
MapThread[{EdgeForm[#2], FaceForm[#2],
Polygon[square[#]]} &, {centers, densities}, 2]]
img = ImageResize[ExampleData[{"TestImage", "Mandrill"}], 200];
convert2Squares[ImageResize[img, 25]] // Short[#, 2] &
Graphics[%, Axes -> True]
This code will scale and center the array of squares to fit within the cylinder.
centerScaleLift[sqrs_List, scl_, dzi_ : 0] :=
Module[{xi}, xi = First@Dimensions[sqrs];
sqrs /. {x_?NumericQ, y_?NumericQ} :>
2 scl*{x - .5 xi, y *dzi/scl}/xi]
Th function anamorphSquareTiles will divide the photographic image into an array of squares created by convert2Squares and will convert the vertices of the squares into their anamorphic map using cylAnamorphMap.
anamorphSquareTiles[image_, viewdPoint : {xv_, zv_}, scale_ : .95,
dzi_ : 1] :=
Module[{polySpecs},
polySpecs = centerScaleLift[convert2Squares[image], scale, dzi];
MapAt[Most[cylAnamorphMap[#, {xv, zv}, 10]] &,
polySpecs, {All, All, -1, All, All}]]
This is the result of the above function applied to the image img, creating an anamorphic version for reflection from the floor (left) and from the ceiling (right)
GraphicsRow[{Rotate[
Graphics[{Circle[],
anamorphSquareTiles[
ImageReflect[img, Left -> Right], {100, 70}]}], \[Pi]]
Rotate[
Graphics[{Circle[],
anamorphSquareTiles[ImageReflect@img, {100, 70}]}], \[Pi]]}]
These are photos of the above printouts reflected in the cylindrical mirror. Looking down (left) or upward into the mirror (right).
Here is how I proceeded to make these photographs: The mirror core is a cylindrical cardboard sugar shaker: diameter 85mm and height 185mm. The reflective material is rolled several times around the cylinder: "heat reflecting window film". The paper printouts were the Mathematica outputs saved as .pdf files and printed as a 2 page "Poster" with Adobe Acrobat .
In case you can not make your own mirror, you can still explore anamorphism in the virtual world. Here is a simulation of the reflection of both the floor (left) and ceiling (right) anamorphic text.
Imagine a large room with the previous anamorphic images painted on floor and ceiling and the message correctly reflected in the mirror column to be admired by the entering visitor! You can enter this room with the code in the attached notebook "Mathematica floor and ceiling.nb"
Hope you enjoyed the magic of anamorphic reflection!
Attachments: