WOLFRAM

How Laplace Would Hide a Goat: The New Science of Magic Windows

Last week, I read Michael Berry’s paper, “Laplacian Magic Windows.” Over the years, I have read many interesting papers by this longtime Mathematica user, but this one stood out for its maximizing of the product of simplicity and unexpectedness. Michael discusses what he calls the magic window. For 70+ years, we have known about holograms, and now we know about magic windows. So what exactly is a magic window? Here is a sketch of the optics of one:

Magic window optics sketch


Parallel light falls onto a glass sheet that is planar on the one side and has some gentle surface variation on the other side (bumps in the above image are vastly overemphasized; the bumps of a real magic window would be minuscule). The light gets refracted by the magic window (the deviation angles of the refracted light rays are also overemphasized in the graphic) and falls onto a wall. Although the window bumpiness shows no recognizable shape or pattern, the light density variations on the wall show a clearly recognizable image. Starting with the image that one wants to see on the wall, one can always construct a window that shows the image one has selected. The variations in the thickness of the glass are assumed to be quite small, and the imaging plane is assumed to be not too far away so that the refracted light does not form caustics—as one sees them, for instance, at the bottom of a swimming pool in sunny conditions.

Now, how should the window surface look to generate any pre-selected image on the wall? It turns out that the image visible on the wall is the Laplacian of the window surface. Magic windows sound like magic, but they are just calculus (differentiation, to be precise) in action. Isn’t this a neat application of multivariate calculus? Schematically, these are the mathematical steps involved in a magic window.

Implementation-wise, the core steps are the following:

Magic window implementation

And while magic windows are a 2017 invention, their roots go back hundreds of years to so-called magic mirrors. Magic mirrors are the mirror equivalent of magic windows: they too can act as optical Laplace operators (see the following).

Expressed more mathematically: Let the height of the bumpy side of the glass surface be f(x,y). Then the intensity of the light brightness on the wall is approximately Δx,y f(x,y), where Δ is the Laplacian ∂2./∂x2+∂2./∂y2. Michael calls such a window a “magic window.” It is magic because the glass surface height f(x,y) does not in any way resemble Δ x,y f(x,y).

It sounds miraculous that a window can operate as a Laplace operator. So let’s do some numerical experiments to convince ourselves that this does really work. Let’s start with a goat that we want to use as the image to be modeled. We just import a cute-looking Oberhasli dairy goat from the internet.

goat = ImageTake[RemoveAlphaChannel[ColorConvert[Import[           "https://s-media-cache-ak0.pinimg.com/originals/fa/60/ce/\      fa60ce323b5642a78abb1b1814fcd582.jpg"], "Grayscale"]], {1, -30}]
goat = ImageTake[RemoveAlphaChannel[ColorConvert[Import[           "https://s-media-cache-ak0.pinimg.com/originals/fa/60/ce/\      fa60ce323b5642a78abb1b1814fcd582.jpg"], "Grayscale"]], {1, -30}]

{w, h} = ImageDimensions[goat];

The gray values of the pixels can be viewed as a function h: ℝ*ℝ->[0,1]. Interpolation allows us to use this function constructively.

ifGoat = Interpolation[   Flatten[MapIndexed[{Reverse@#2, #1} &, ImageData[goat], {2}], 1]]

Here is a 3D plot of the goat function ifGoat.

Plot3D[ifGoat[x, y], {x, 1, w}, {y, 1, h}, ColorFunction -> GrayLevel,   MeshFunctions -> {}, PlotPoints -> 200,  BoxRatios -> {w, h, w/8}, ViewPoint -> {0, 2, 4},   ViewVertical -> {0, -1, 0}]

Plot3D[ifGoat[x, y], {x, 1, w}, {y, 1, h}, ColorFunction -> GrayLevel,   MeshFunctions -> {}, PlotPoints -> 200,  BoxRatios -> {w, h, w/8}, ViewPoint -> {0, 2, 4},   ViewVertical -> {0, -1, 0}]

And we can solve the Poisson equation with the image as the right-hand side: Δ f = image using NDSolveValue.

We will use Dirichlet boundary conditions for now. (But the boundary conditions will not matter for the main argument.)

ndsGoat = NDSolveValue[{Laplacian[U[x, y], {x, y}] == ifGoat[x, y],     DirichletCondition[U[x, y] == 1/2, True]}, {U}, {x, y} \[Element]      Rectangle[{1, 1}, {w, h}],    Method -> {"PDEDiscretization" -> {"FiniteElement", {"MeshOptions" \ -> {MaxCellMeasure -> 1}}}}][[1]]

The Poisson equation solution is quite a smooth function; the inverse of the Laplace operator is a smoothing operation. No visual trace of the goat seems to be left.

Plot3D[Evaluate[ndsGoat[x, y]], {x, 1, w}, {y, 1, h},               MeshFunctions -> {#3 &}, PlotPoints -> 80,   AxesLabel -> {x, y}]

Plot3D[Evaluate[ndsGoat[x, y]], {x, 1, w}, {y, 1, h},               MeshFunctions -> {#3 &}, PlotPoints -> 80,   AxesLabel -> {x, y}]

Overall it is smooth, and it is also still smooth when zoomed in.

Plot3D[Evaluate[ndsGoat[x, y]], {x, 100, 200}, {y, 100, 200},                MeshFunctions -> {#3 &}, PlotPoints -> 80,   AxesLabel -> {x, y}]

Plot3D[Evaluate[ndsGoat[x, y]], {x, 100, 200}, {y, 100, 200},                MeshFunctions -> {#3 &}, PlotPoints -> 80,   AxesLabel -> {x, y}]

Even when repeatedly zoomed in.

Plot3D[Evaluate[ndsGoat[x, y]], {x, 190, 200}, {y, 190, 200},                MeshFunctions -> {#3 &}, PlotPoints -> 80,   AxesLabel -> {x, y}]

Plot3D[Evaluate[ndsGoat[x, y]], {x, 190, 200}, {y, 190, 200},                MeshFunctions -> {#3 &}, PlotPoints -> 80,   AxesLabel -> {x, y}]

The overall shape of the Poisson equation solution can be easily understood through the Green’s function of the Laplace operator.

GreenFunction[{Laplacian[u[x, y],{x, y}],    DirichletCondition[u[x, y] == 0, True]}, u[x, y],                                 {x, y} \[Element]    Rectangle[{0, 0}, {Lx, Ly}], {m, n}]

We calculate and visualize the first few terms (individually) of the double sum from the Green’s function.

integral[{jx_, jy_}, {kx_, ky_}] =   Integrate[   Sin[Pi x kx/Lx] Sin[Pi y ky/Ly], {x, jx, jx + 1}, {y, jy, jy + 1}]

cfF = With[{lx = w, ly = h, id = ImageData[goat]},    Compile[{kx, ky},      Module[{sum = 0. },      Do[sum =         sum + (-1) id[[jy, jx]]  1/(          kx ky \[Pi]^2) (Cos[(jx kx \[Pi])/lx] -             Cos[((1 + jx) kx \[Pi])/lx]) (Cos[(jy ky \[Pi])/ly] -             Cos[((1 + jy) ky \[Pi])/ly]),       {jy, ly - 1}, {jx, lx - 1}];      sum]] ];

With[{lx = w, ly = h},  Table[Plot3D[    Evaluate[     cfF[kx, ky] 1/((\[Pi]^2 kx^2)/lx^2 + (\[Pi]^2 ky^2)/       ly^2) (Sin[(\[Pi] x kx)/lx] Sin[(\[Pi] y ky)/ly])], {x, 1,      lx}, {y, 1, ly},    Ticks -> {None, None, Automatic},     PlotLabel -> "{kx,ky}" == {kx, ky}, MeshFunctions -> {#3 &}],   {kx, 3}, {ky, 3}]]

With[{lx = w, ly = h},  Table[Plot3D[    Evaluate[     cfF[kx, ky] 1/((\[Pi]^2 kx^2)/lx^2 + (\[Pi]^2 ky^2)/       ly^2) (Sin[(\[Pi] x kx)/lx] Sin[(\[Pi] y ky)/ly])], {x, 1,      lx}, {y, 1, ly},    Ticks -> {None, None, Automatic},     PlotLabel -> "{kx,ky}" == {kx, ky}, MeshFunctions -> {#3 &}],   {kx, 3}, {ky, 3}]]

Taking 252 terms into account, we have the following approximations for the Poisson equation solution and its Laplacian. The overall shape is the same as the previous numerical solution of the Poisson equation.

goatPoissonApprox[x_, y_] = With[{lx = w, ly = h},    Monitor[     Sum[cfF[kx, ky] 1/((\[Pi]^2 kx^2)/lx^2 + (\[Pi]^2 ky^2)/        ly^2) (Sin[(\[Pi] x kx)/lx] Sin[(\[Pi] y ky)/ly]), {kx,        25}, {ky, 25}], {kx, ky}]];

With[{lx = w, ly = h},   Plot3D[Evaluate[goatPoissonApprox[x, y]], {x, 1, lx}, {y, 1, ly},    MeshFunctions -> {#3 &}]]

With[{lx = w, ly = h},   Plot3D[Evaluate[goatPoissonApprox[x, y]], {x, 1, lx}, {y, 1, ly},    MeshFunctions -> {#3 &}]]

For this small number of Fourier modes, the outline of goat is recognizable, but its details aren’t.

With[{cfL =     Compile[{x, y},      Evaluate[Laplacian[goatPoissonApprox[x, y], {x, y}]]]},  ReliefPlot[Table[cfL[x, y], {y, h, 1, -1}, {x, 1, w}],    ColorFunction -> GrayLevel, Frame -> False]]

Applying the Laplace operator to the PDE solutions recovers (by construction) a version of the goat. Due to finite element discretization and numerical differentiation, the resulting goat is not quite the original one.

ReliefPlot[  Table[Evaluate[Laplacian[ifGoat[x, y], {x, y}]], {y, h, 1, -1}, {x,     w}],                         ColorFunction -> GrayLevel, Frame -> False]

A faster and less discretization-dependent way to solve the Poisson equation uses the fast Fourier transform (FFT).

FDSTGoat =    FourierDST[    Table[(* \[CapitalDelta]^-1 *) -1./(4 - 2 Cos[x  Pi/h] -          2 Cos[y Pi/w]), {y, h}, {x, w}] FourierDST[ImageData[goat],       1], 1];

ListPlot3D[FDSTGoat, MeshFunctions -> {#3 &}]
ListPlot3D[FDSTGoat, MeshFunctions -> {#3 &}]

This solution recovers the goat more faithfully. Here is the recovered goat after interpolating the function values.

if\[CapitalDelta]Goat =   Interpolation[   Flatten[MapIndexed[{Reverse@#2, #1} &, FDSTGoat, {2}], 1],    InterpolationOrder -> 3]

ReliefPlot[  Table[Evaluate[Laplacian[if\[CapitalDelta]Goat[x, y], {x, y}]], {y,     h, 1, -1}, {x, w}],                         ColorFunction -> GrayLevel, Frame -> False]

Taking into account that any physical realization of a magic window made from glass will unavoidably have imperfections, a natural question to ask is: What happens if one adds small perturbations to the solution of the Poisson equation?

The next input modifies each grid point randomly by a perturbation of relative size 10p. We see that for this goat, the relative precision of the surface has to be on the order of 10-6 or better—a challenging but realizable mechanical accuracy.

Table[if\[CapitalDelta]GoatRandomized = Interpolation[Flatten[     MapIndexed[{Reverse@#2, (1 + 10^-p RandomReal[{-1, 1}]) #1} &,       FDSTGoat, {2}], 1], InterpolationOrder -> 3];  ReliefPlot[   Table[Evaluate[     Laplacian[if\[CapitalDelta]GoatRandomized[x, y], {x, y}]], {y, h,      1, -1}, {x, w}],                          ColorFunction -> GrayLevel, Frame -> False,    PlotLabel -> HoldForm[10^-#] &[p]],  {p, 3, 6}]

To see how the goat emerges after differentiation (Δ = ∂2 ./∂x2+∂2 ./∂y2), here are the partial derivatives shown.

Function[\[Delta],    ReliefPlot[    Table[Evaluate[\[Delta] @ if\[CapitalDelta]Goat[x, y]], {y, h,       1, -1}, {x, w}],                             ColorFunction -> GrayLevel,     Frame -> False, PlotLabel -> \[Delta]]] /@                        {Function[f, D[f, x]], Function[f, D[f, y]],                         Function[f, D[f, {x, 2}]],    Function[f, D[f, {y, 2}]]}

And because we have ∂2 ./∂x2+∂2 ./∂y2 =(∂./∂x+ⅈ ∂./∂y)(∂./∂x–ⅈ ∂./∂y), we also look at the Wirtinger derivatives.

Function[\[Delta],    ReliefPlot[    Table[Evaluate[\[Delta] @ if\[CapitalDelta]Goat[x, y]], {y, h,       1, -1}, {x, w}],                             ColorFunction -> GrayLevel,     Frame -> False, PlotLabel -> \[Delta]]] /@                        {Function[f, Arg[D[f, x] + I D[f, y]]],    Function[f, Abs[D[f, x] + I D[f, y]]],                        Function[f, Arg[D[f, x] - I D[f, y]]],    Function[f, Abs[D[f, x] + I D[f, y]]]}

Function[\[Delta],    ReliefPlot[    Table[Evaluate[\[Delta] @ if\[CapitalDelta]Goat[x, y]], {y, h,       1, -1}, {x, w}],                             ColorFunction -> GrayLevel,     Frame -> False, PlotLabel -> \[Delta]]] /@                        {Function[f, Arg[D[f, x] + I D[f, y]]],    Function[f, Abs[D[f, x] + I D[f, y]]],                        Function[f, Arg[D[f, x] - I D[f, y]]],    Function[f, Abs[D[f, x] + I D[f, y]]]}

We could also just use a simple finite difference formula to get the goat back. This avoids any interpolation artifacts and absolutely faithfully reproduces the original goat.

{ImageConvolve[   Image[FDSTGoat], -{{0, -1, 0}, {-1, 4, -1}, {0, -1, 0}},    Padding -> None],   LaplacianFilter[Image[FDSTGoat], 1],   LaplacianFilter[Image[FDSTGoat], 2]}

The differentiation can even be carried out as an image processing operation.

ImageConvolve[Image[FDSTGoat], -{{0, -1, 0}, {-1, 4, -1}, {0, -1, 0}},    Padding -> None] // ImageAdjust

So far, nothing really interesting. We integrated and differentiated a function. Let’s switch gears and consider the refraction of a set of parallel light rays on a glass sheet.

We consider the lower parts of the glass sheet planar and the upper part slightly wavy with an explicit description height = f(x,y). The index of refraction is n, and we follow the light rays (coming from below) up to the imaging plane at height = Z. Here is a small Manipulate that visualizes this situation for the example surface f(x,y) = 1 + ε (cos(α x) + cos(β y).

We do want the upper surface of the glass nearly planar, so we use the factor ε in the previous equation.

g[x_, y_] := Cos[\[Alpha] x] + Cos[\[Beta] y]; f[x_, y_] := 1 +(* small height variations *) \[CurlyEpsilon]  g[x, y];  normalize = #/Sqrt[#.#] &; lightRay[{\[Alpha]_, \[Beta]_, \[CurlyEpsilon]_}, {x_, y_}, n_, Z_] =   Module[{dir0 = normalize[{0, 0, 1}], normal, \[Phi], \[Theta], P0,      direction2, dir, \[Sigma]},    (* surface normal *)    normal = normalize[Grad[z - f[x, y], {x, y, z}]];    (* refract the light ray using Snell's law *)    \[Phi] = ArcCos[normal.dir0];    \[Theta] = ArcSin[n Sin[\[Phi]]];    (* surface point of refraction *)    P0 = {x, y, f[x, y]};     (* refracted ray *)    direction2 = normalize[dir0 - normal.dir0 normal];     dir = Cos[\[Theta]] normal + Sin[\[Theta]] direction2 ;    (* ray up to height Z *)    \[Sigma] = (Z - P0[[3]])/dir[[3]];    (* return pair: {surface point, image plane point} *)    {P0, P0 + \[Sigma] dir}    ];

Manipulate[  Module[{surface,  p0, p1, rays, \[CapitalDelta] = 2 Pi/pp},   surface =     Plot3D[Evaluate[      1 + \[CurlyEpsilon] (Cos[\[Alpha] x] + Cos[\[Beta] y])], {x, -Pi,       Pi}, {y, -Pi, Pi},     Filling -> -2, FillingStyle -> Directive[White, Opacity[0.4]],      MeshFunctions -> {#3 &},     MeshStyle -> GrayLevel[0.5], Lighting -> "Neutral",      ImageSize -> 400,     BoundaryStyle -> Gray,      PlotStyle -> Directive[White, Opacity[0.4]]];     rays = Table[{p0, p1} =        N@lightRay[{\[Alpha], \[Beta], \[CurlyEpsilon]}, {\[Xi], \ \[Eta]}, n, Z];                           (* ignore rays with total reflection *)                          If[MatchQ[p1, {_Real, _Real, _Real}],                                  {Tube[         Line[{MapAt[-4 &, p0, 3], p0, p1}], 0.02],         Sphere[p1, 0.04]}, {}],          {\[Eta], -Pi + \[CapitalDelta]/2,        Pi - \[CapitalDelta]/         2, \[CapitalDelta]},   {\[Xi], -Pi + \[CapitalDelta]/2,        Pi - \[CapitalDelta]/2, \[CapitalDelta]}] // Quiet;   Show[{surface, Graphics3D[{Yellow, rays}]},            PlotRange -> All, BoxRatios -> Automatic,     Background -> Black]],   {{pp, 18, "rays"}, 1, 32, 1, Appearance -> "Labeled"}, Delimiter,  {{n, 3}, 1, 5, Appearance -> "Labeled"}, Delimiter,  {{Z, 5}, 1, 20, Appearance -> "Labeled"}, Delimiter,  {{\[CurlyEpsilon], 0.08}, -1, 1, Appearance -> "Labeled"}, Delimiter,  {{\[Alpha], 1}, 0, 5, Appearance -> "Labeled"},  {{\[Beta], 1}, 0, 5, Appearance -> "Labeled"},  TrackedSymbols :> True]

Manipulate[  Module[{surface,  p0, p1, rays, \[CapitalDelta] = 2 Pi/pp},   surface =     Plot3D[Evaluate[      1 + \[CurlyEpsilon] (Cos[\[Alpha] x] + Cos[\[Beta] y])], {x, -Pi,       Pi}, {y, -Pi, Pi},     Filling -> -2, FillingStyle -> Directive[White, Opacity[0.4]],      MeshFunctions -> {#3 &},     MeshStyle -> GrayLevel[0.5], Lighting -> "Neutral",      ImageSize -> 400,     BoundaryStyle -> Gray,      PlotStyle -> Directive[White, Opacity[0.4]]];     rays = Table[{p0, p1} =        N@lightRay[{\[Alpha], \[Beta], \[CurlyEpsilon]}, {\[Xi], \ \[Eta]}, n, Z];                           (* ignore rays with total reflection *)                          If[MatchQ[p1, {_Real, _Real, _Real}],                                  {Tube[         Line[{MapAt[-4 &, p0, 3], p0, p1}], 0.02],         Sphere[p1, 0.04]}, {}],          {\[Eta], -Pi + \[CapitalDelta]/2,        Pi - \[CapitalDelta]/         2, \[CapitalDelta]},   {\[Xi], -Pi + \[CapitalDelta]/2,        Pi - \[CapitalDelta]/2, \[CapitalDelta]}] // Quiet;   Show[{surface, Graphics3D[{Yellow, rays}]},            PlotRange -> All, BoxRatios -> Automatic,     Background -> Black]],   {{pp, 18, "rays"}, 1, 32, 1, Appearance -> "Labeled"}, Delimiter,  {{n, 3}, 1, 5, Appearance -> "Labeled"}, Delimiter,  {{Z, 5}, 1, 20, Appearance -> "Labeled"}, Delimiter,  {{\[CurlyEpsilon], 0.08}, -1, 1, Appearance -> "Labeled"}, Delimiter,  {{\[Alpha], 1}, 0, 5, Appearance -> "Labeled"},  {{\[Beta], 1}, 0, 5, Appearance -> "Labeled"},  TrackedSymbols :> True]

The reason we want the upper surface mostly planar is that we want to avoid rays that “cross” near the surface and form caustics. We want to be in a situation where the density of the rays is position dependent, but the rays do not yet cross. This restricts the values of n, Z and the height of the surface modulation.

Now let’s do the refraction experiment with the previous solution of the Laplace equation as the height of the upper glass surface. To make the surface variations small, we multiply that solution by 0.0001.

WolframAlpha["refractive index of glass", {{"Result", 1},    "ComputableData"},   PodStates -> {"Result__Show details", "Result__Hide details"}]

We use the median refractive index of glass, n = 1.53.

ifGoatSmall[x_, y_] = 0.0001  if\[CapitalDelta]Goat[x, y];

gradGoatSmall[x_, y_] = Grad[z - ifGoatSmall[x, y], {x, y, z}];

Instead of using lightRay, we will use a compiled version for faster numerical evaluation.

refractCompiled[{x_, y_}, n_, Z_] :=    cf[x, y, Z, n, gradGoatSmall[x, y], ifGoatSmall[x, y]];

cf = Compile[{x, y, Z, n, {g2, _Real, 1}, s2},    Module[{dir0 = Normalize[{0, 0, 1}], normal, \[Phi], \[Theta], P0,       direction2 = {1., 1, 1}, dir, \[Sigma]},     normal = Normalize[g2];     \[Phi] = ArcCos[normal.dir0];     \[Theta] = ArcSin[n Sin[\[Phi]]];     P0 = {x, y, s2};     direction2 = Normalize[dir0 - normal.dir0 normal];      dir = Cos[\[Theta]] normal + Sin[\[Theta]] direction2 ;     \[Sigma] = (Z - P0[[3]])/dir[[3]];     {P0, P0 + \[Sigma] dir}]];

In absolute units, say the variations in glass height are at most 1 mm; we look at the refracted rays a few meters behind the glass window. We will use about 3.2 million lights rays (42 per pixel).

With[{\[CapitalDelta] = 0.25, Z = 5000},   Monitor[   data = Line[      Flatten[Table[        refractCompiled[{x, y}, 1.53, Z], {y, 1,          h, \[CapitalDelta]}, {x, 1, w, \[CapitalDelta]}], 1]];,   {y, x}]]

points = Most[#] & /@ data[[1, All, 2]]; Length[points]

Displaying all endpoints of the rays gives a rather strong Moiré effect. But the goat is visible—a true refraction goat!

Graphics[{PointSize[0.001], Opacity[0.02],    Point[Developer`ToPackedArray[{1, -1} # & /@ points]]}]

Graphics[{PointSize[0.001], Opacity[0.02],    Point[Developer`ToPackedArray[{1, -1} # & /@ points]]}]

If we accumulate the number of points that arrive in a small neighborhood of the given points {X,Y} in the plane height=Z, the goat becomes much more visible. (This is what would happen if we would observe the brightness of the light that goes through the glass sheet and we assume that the intensities are additive.) To do the accumulation efficiently, we use the function Nearest.

nf = Nearest[points]; Monitor[tNF =     Table[Length@nf[{x, y}, {Infinity, 2}], {x, -20, w + 20}, {y, -20,       h + 20}];, {x, y}] ReliefPlot[Reverse@Transpose[tNF],   ColorFunction -> (GrayLevel[1 - #^2] &), Frame -> False]

nf = Nearest[points]; Monitor[tNF =     Table[Length@nf[{x, y}, {Infinity, 2}], {x, -20, w + 20}, {y, -20,       h + 20}];, {x, y}] ReliefPlot[Reverse@Transpose[tNF],   ColorFunction -> (GrayLevel[1 - #^2] &), Frame -> False]

Note that looking into the light that comes through the window would not show the goat because the light that would fall into the eye would mostly come from a small spatial region due to the mostly parallel light rays.

The appearance of the Laplacian of the surface of the glass sheet is not restricted to only parallel light. In the following, we use a point light source instead of parallel light. This means that the effect would also be visible by using artificial light sources, rather than sunlight with a magic window.

cfP = With[{w = w, h = h},   Compile[{x, y, Z, n, {g2, _Real, 1}, s2},    Module[{dir0 = Normalize[{x, y, s2} - {w/2, h/2, 5000}],       normal, \[Phi], \[Theta], P0, direction2 = {1., 1, 1},       dir, \[Sigma]},     normal = Normalize[g2];     \[Phi] = ArcCos[normal.dir0];     \[Theta] = ArcSin[n Sin[\[Phi]]];     P0 = {x, y, s2};     direction2 = Normalize[dir0 - normal.dir0 normal];      dir = Cos[\[Theta]] normal + Sin[\[Theta]] direction2 ;     \[Sigma] = (Z - P0[[3]])/dir[[3]];     {P0, P0 + \[Sigma] dir}]]]

refractCompiledP[{x_, y_}, n_, Z_] :=   cfP[x, y, Z, n, gradGoatSmall[x, y], ifGoatSmall[x, y]]

With[{Z = 5000, \[CapitalDelta] = .25},  Monitor[   dataP =      Line[Flatten[       Table[refractCompiledP[{x, y}, 1.5, Z], {x, 1,          w, \[CapitalDelta]}, {y, 1, h, \[CapitalDelta]}], 1]];,   {x, y}] ]

ptsP = Reverse[Most[#]] & /@ dataP[[1, All, 2]];  nfP = Nearest[ptsP]; With[{padding = 400},  Monitor[tNFP = Table[Length@nfP[{x, y}, {Infinity, 2}],                   {x, -padding, w + padding},   {y, -padding,        h + padding}];, {x, y}]]

ReliefPlot[Reverse@tNFP, ColorFunction -> (GrayLevel[1 - #^2] &),     Frame -> False] //                                                                      Rasterize[#, "Image", ImageSize -> 400] & // ImageCrop

ReliefPlot[Reverse@tNFP, ColorFunction -> (GrayLevel[1 - #^2] &),     Frame -> False] //                                                                      Rasterize[#, "Image", ImageSize -> 400] & // ImageCrop

So why is the goat visible in the density of rays after refraction? At first, it seems quite surprising whether either a parallel or point source shines on the window.

On second thought, one remembers Maxwell’s geometric meaning of the Laplace operator:

(\[CapitalDelta] f)(Subscript[Overscript[r, \[RightVector]], 0])=Underscript[lim, \[Rho]->0]((2d)/\[Rho]^2 (Subscript[\[LeftAngleBracket]f\[RightAngleBracket], S(Subscript[Overscript[r, \[RightVector]], 0],\[Rho])]-f(Subscript[Overscript[r, \[RightVector]], 0])))

… where Math notation indicates the average of f on a sphere centered at Math notation 2 with radius ρ. Here is a quick check of the last identity for two and three dimensions.

 Limit[2*2/\[Rho]^2 (Normal[       Series[Integrate[\[ScriptF][x, y], {x, y} \[Element]           Sphere[{x0, y0}, \[Rho]],          Assumptions -> \[Rho] > 0 \[And] (x0 | y0) \[Element]             Reals], {x, x0, 3}, {y, y0, 3}]]/      ArcLength[Sphere[{x0, y0}, \[Rho]]] - \[ScriptF][x0,       y0]), \[Rho] -> 0]

 Limit[2*3/\[Rho]^2 (Normal[       Series[Integrate[\[ScriptF][x, y, z], {x, y, z} \[Element]           Sphere[{x0, y0, z0}, \[Rho]],          Assumptions -> \[Rho] > 0 \[And] (x0 | y0 | z0) \[Element]             Reals], {x, x0, 3}, {y, y0, 3}, {z, z0, 3}]]/      Area[Sphere[{x0, y0, z0}, \[Rho]]] - \[ScriptF][x0, y0,       z0]), \[Rho] -> 0]

At a given point in the imaging plane, we add up the light rays from different points of the glass surface. This means we carry out some kind of averaging operation.

So let’s go back to the general refraction formula and have a closer look. Again we assume that the upper surface is mostly flat and that the parameter ε is small. The position {X,Y} of the light ray in the imaging plane can be calculated in closed form as a function of the surface g(x,y), the starting coordinates of the light ray {x,y}, the index of refraction n and the distance of the imaging plane Z.

Clear[f, g]; f[x_, y_] := f0 + \[CurlyEpsilon] g[x, y]; normalize = #/Sqrt[#.#] &; \[ScriptCapitalR] = Module[{dir0 = normalize[{0, 0, 1}]},    normal = normalize[Grad[z - f[x, y], {x, y, z}]];    \[Phi] = ArcCos[normal.dir0];    \[Theta] = ArcSin[n Sin[\[Phi]]];    P0 = {x, y, f[x, y]};     direction2 = normalize[dir0 - normal.dir0 normal];     dir = Cos[\[Theta]] normal + Sin[\[Theta]] direction2 ;    \[Sigma] = (Z - P0[[3]])/dir[[3]];    P0 + \[Sigma] dir ] // Simplify

That is a relatively complicated-looking formula. For a nearly planar upper glass surface (small ε), we have the following approximate coordinates for the {X,Y} coordinates of the imaging plane where we observe the light rays in terms of the coordinate {x,y} of the glass surface.

Series[Most[\[ScriptCapitalR]], {\[CurlyEpsilon], 0, 1}]

This means in zeroth order we have {X,Y} ≈ {x,y}. And the deviation of the light ray position in the imaging plane is proportional (n–1)Z. (Higher-order corrections to {X,Y} ≈ {x,y} we could get from Newton iterations, but we do not need them here.)

The density of rays is the inverse of the Jacobian for going from {x,y} to {X,Y}. (Think on the change of variable formulas for 1:1 transforms for multivariate integration.)

1/Det[Grad[Most[\[ScriptCapitalR]], {x, y}]] // Short[#, 6] &

LeafCount[1/Det[Grad[Most[\[ScriptCapitalR]], {x, y}]]]

Quantifying the size of the resulting expression shows that it is indeed a large expression. This is quite a complex formula. For a quadratic function in x and y, we can get some feeling for the density as a function of the physical parameters ε, n and Z as well as the parameters that describe the surface by varying them in an interactive demonstration. For large values of n, Z and ε, we see how caustics arise.

refractionDensity[{x_, y_}, {n_, Z_, \[CurlyEpsilon]_}, {c00_, c10_,      c01_, c11_, c20_, c02_}] =    1/Det[Grad[Most[\[ScriptCapitalR]], {x, y}]] /.      g -> Function[{x, y},        c00 + c10 x + c01 y + c11 x y + c20 x^2 + c02 y^2] /. f0 -> 1;

Manipulate[  {Plot3D[Evaluate[     c00 + c10 x + c01 y + c11 x y + c20 x^2 + c02 y^2], {x, -1,      1}, {y, -1, 1},    MeshFunctions -> {#3 &}],   Plot3D[Evaluate[     refractionDensity[{x, y}, {n, Z, \[CurlyEpsilon]}, {c00, c10, c01,        c11, c20, c02}]], {x, -1, 1}, {y, -1, 1},    MeshFunctions -> {#3 &}]},   {{n, 3}, 1, 5, Appearance -> "Labeled"},   {{Z, 5}, 1, 20, Appearance -> "Labeled"},   {{\[CurlyEpsilon], 0.08}, -1, 1, Appearance -> "Labeled"}, Delimiter,  {{c00, 0}, -2, 2, Appearance -> "Labeled"},  {{c10, 0}, -2, 2, Appearance -> "Labeled"},  {{c01, 0}, -2, 2, Appearance -> "Labeled"},  {{c11, 0.7}, -2, 2, Appearance -> "Labeled"},  {{c20, 1.2}, -2, 2, Appearance -> "Labeled"},  {{c02, 1}, -2, 2, Appearance -> "Labeled"},  ControlPlacement -> Top, TrackedSymbols :> True]

For nearly planar surfaces (first order in ε), the density is equal to the Laplacian of the surface heights (in x,y coordinates). This is the main “trick” in the construction of magic windows.

intensity =   Series[1/Det[      Grad[Most[\[ScriptCapitalR]], {x, y}]], {\[CurlyEpsilon], 0,      1}] // Simplify

This explains why the goat appears as the intensity pattern of the light rays after refraction. This means glass sheets act effectively as a Laplace operator.

Using Newton’s root-finding method, we could calculate the intensity in X,Y coordinates, but the expression explains heuristically why refraction on a nearly planar surface behaves like an optical Laplace operator. For more details, see this article.

Now we could model a better picture of the light ray density by pre-generating a matrix of points in the imaging plane using, say, 10 million rays, and record where they fall within the imaging plane. This time we model the solution of the Poisson equation using ListDeconvolve.

ifGoat2 = Interpolation[   Flatten[    MapIndexed[{Reverse@#2, #1} &,      ListDeconvolve[-{{0, -1, 0}, {-1, 4, -1}, {0, -1, 0}},       ImageData[goat]], {2}], 1], InterpolationOrder -> 5]

The approximate solution of the Poisson equation is not quite as smooth as the global solutions, but the goat is nevertheless invisible.

Plot3D[Evaluate[ifGoat2[x, y]], {x, 1, w}, {y, 1, h},   MeshFunctions -> {#3 &}, PlotPoints -> 80]

ReliefPlot[  Table[Evaluate[Laplacian[ifGoat2[x, y], {x, y}]], {y, h, 1, -1}, {x,     w}], ColorFunction -> GrayLevel, Frame -> False]

ifGoatSmall2[x_, y_] = 0.002  ifGoat2[x, y];

gradGoatSmall2[x_, y_] = Grad[z - ifGoatSmall2[x, y], {x, y, z}];

refractCompiled2[{x_, y_}, n_, Z_] :=    cf[x, y, Z, n, gradGoatSmall2[x, y], ifGoatSmall2[x, y]];

(* this will take a few minutes *) With[{\[Mu] = 4, \[CapitalDelta] = 0.1, Z = 1000, \[Delta] = 25},  Monitor[   mat = Table[0, {\[Mu] (h + 2 \[Delta])}, {\[Mu] (w + 2 \[Delta])}];    Do[\[Upsilon] = \[Mu] Round[(refractCompiled2[{x, y}, 1.53, Z][[          2]] + \[Delta]), 1./\[Mu]];    If[1 <= \[Upsilon][[2]] <= \[Mu] (h + 2 \[Delta]) &&       1 <= \[Upsilon][[1]] <= \[Mu] (w + 2 \[Delta]),      mat[[\[Upsilon][[2]], \[Upsilon][[1]]]] =       mat[[\[Upsilon][[2]], \[Upsilon][[1]]]] + 1],     {x, 1, w, \[CapitalDelta]}, {y, 1, h, \[CapitalDelta]}];, {x, y}]]

We adjust the brightness/darkness through a power law (a crude approximation for a Weber–Fechner perception).

ImageResize[Blur[Image[1 - (mat/Max[mat])^0.3], 6], 600] // ImageCrop

If the imaging plane is too far away, we do get caustics (that remind me of the famous cave paintings from Lascaux).

With[{\[Mu] = 4, \[CapitalDelta] = 0.25, Z = 4000, \[Delta] = 25},  Monitor[   matC = Table[0, {\[Mu] (h + 2 \[Delta])}, {\[Mu] (w + 2 \[Delta])}];    Do[\[Upsilon] = \[Mu] Round[(refractCompiled2[{x, y}, 1.53, Z][[          2]] + \[Delta]), 1./\[Mu]];    If[1 <= \[Upsilon][[2]] <= \[Mu] (h + 2 \[Delta]) &&       1 <= \[Upsilon][[1]] <= \[Mu] (w + 2 \[Delta]),                matC[[\[Upsilon][[2]], \[Upsilon][[1]]]] =       matC[[\[Upsilon][[2]], \[Upsilon][[1]]]] + 1],     {x, 1, w, \[CapitalDelta]}, {y, 1, h, \[CapitalDelta]}];, {x, y}]]

ImageResize[Blur[Image[1 - (matC/Max[matC])^.2], 5], 600] // ImageCrop

If the image plane is even further away, the goat slowly becomes unrecognizable.

With[{\[Mu] = 4, \[CapitalDelta] = 0.25, Z = 8000, \[Delta] = 60},  Monitor[   matC2 =     Table[0, {\[Mu] (h + 2 \[Delta])}, {\[Mu] (w + 2 \[Delta])}];    Do[\[Upsilon] = \[Mu] Round[(refractCompiled2[{x, y}, 1.53, Z][[          2]] + \[Delta]), 1./\[Mu]];    If[1 <= \[Upsilon][[2]] <= \[Mu] (h + 2 \[Delta]) &&       1 <= \[Upsilon][[1]] <= \[Mu] (w + 2 \[Delta]),                 matC2[[\[Upsilon][[2]], \[Upsilon][[1]]]] =       matC2[[\[Upsilon][[2]], \[Upsilon][[1]]]] + 1],     {x, 1, w, \[CapitalDelta]}, {y, 1, h, \[CapitalDelta]}];, {x, y}]]

ImageResize[Blur[Image[1 - (matC2/Max[matC2])^.1], 5],    600] // ImageCrop

Although not practically realizable, we also show what the goat would look like for negative Z; now it seems much more sheep-like.

With[{\[Mu] = 4, \[CapitalDelta] = 0.25, Z = -3000, \[Delta] = 60},  Monitor[   matC3 =     Table[0, {\[Mu] (h + 2 \[Delta])}, {\[Mu] (w + 2 \[Delta])}];    Do[\[Upsilon] = \[Mu] Round[(refractCompiled2[{x, y}, 1.53, Z][[          2]] + \[Delta]), 1./\[Mu]];    If[1 <= \[Upsilon][[2]] <= \[Mu] (h + 2 \[Delta]) &&       1 <= \[Upsilon][[1]] <= \[Mu] (w + 2 \[Delta]),                 matC3[[\[Upsilon][[2]], \[Upsilon][[1]]]] =       matC3[[\[Upsilon][[2]], \[Upsilon][[1]]]] + 1],     {x, 1, w, \[CapitalDelta]}, {y, 1, h, \[CapitalDelta]}];, {x, y}]]

ImageResize[Blur[Image[1 - (matC3/Max[matC3])^.2], 5],    600] // ImageCrop

Here is a small animation showing the shape of the goat as a function of the distance Z of the imaging plane from the upper surface.

Even if the image is just made from a few lines (rather than each pixel having a non-white or non-black value), the solution of the Poisson equation is a smooth function, and the right-hand side is not recognizable in a plot of the solution.

imHomer =   ColorConvert[   Rasterize[    Show[Entity["PopularCurve", "HomerSimpsonCurve"]["Plot"],       Axes -> False] /.                                                                       \                 _RGBColor :> Black, "Image", ImageSize -> 300],    "Grayscale"]

{wHomer, hHomer} = ImageDimensions[imHomer];

ifHomer =    Interpolation[    Flatten[MapIndexed[{#2, #1} &, ImageData[imHomer], {2}], 1],     InterpolationOrder -> 4];

im\[CapitalDelta]Homer =    FourierDST[    Table[-1./(4 - 2 Cos[x  Pi/hHomer] - 2 Cos[y Pi/wHomer]), {y,        hHomer}, {x, wHomer}] *                                                  FourierDST[ImageData[imHomer], 1], 1];

if\[CapitalDelta]Homer =    Interpolation[    Flatten[MapIndexed[{Reverse@#2, #1} &,       im\[CapitalDelta]Homer, {2}], 1], InterpolationOrder -> 2];

Plot3D[Evaluate[if\[CapitalDelta]Homer[x, y]], {x, 1, wHomer}, {y, 1,    hHomer}, MeshFunctions -> {#3 &}, PlotPoints -> 80]

But after refraction on a glass sheet (or applying the Laplacian), we see Homer quite clearly.

 Image[ListConvolve[-{{0, -1, 0}, {-1, 4, -1}, {0, -1, 0}},     im\[CapitalDelta]Homer]] // ImageAdjust

Despite the very localized curve-like structures that make the Homer image, the resulting Poisson equation solution again looks quite smooth. Here is the solution textured with its second derivative (the purple line will be used in the next input).

Plot3D[Evaluate[if\[CapitalDelta]Homer[x, y]], {x, 1, wHomer}, {y, 1,    hHomer}, PlotPoints -> 80,  BoxRatios -> {wHomer, hHomer, wHomer/2},   PlotStyle -> Texture[imHomer], Mesh -> {{200}},  MeshFunctions -> {#2 &}, MeshStyle -> Purple,   ViewPoint -> {0.3, -1.9, 2.9}]

The next graphic shows a cross-section of the Poisson equation solution together with its (scaled) first and second derivatives with respect to x along the purple line of the last graphic. The lines show up quite pronounced in the second derivatives.

Plot[Evaluate[{if\[CapitalDelta]Homer[x, 200]/10000,     D[if\[CapitalDelta]Homer[x, 200], x]/100,     D[if\[CapitalDelta]Homer[x, 200], x, x]}], {x, 1, wHomer},  PlotLegends -> {HoldForm[if\[CapitalDelta]Homer[x, 200]/10000],     HoldForm[D[if\[CapitalDelta]Homer[x, 200], x]],     HoldForm[D[if\[CapitalDelta]Homer[x, 200], {x, 2}]]}]

Let’s repeat a modification of the previous experiment to see how precise the surface would have to be to show Homer. We add some random waves to the Homer solution.

With[{M = 20, n = 8},   if\[CapitalDelta]Homer2[\[Delta]_][x_, y_] =     if\[CapitalDelta]Homer[x, y]*     (1 + \[Delta] Sum[         RandomReal[{}] Cos[           RandomReal[{-M, M}] x + 2 Pi RandomReal[]] Cos[           RandomReal[{-M, M}] y + 2 Pi RandomReal[]],         {n}])];

Again we see that the surface would have to be correct at the (10-6) level or better.

ArrayPlot[    Table[Evaluate[       Laplacian[if\[CapitalDelta]Homer2[10^-#][x, y], {x, y}]], {y, 1,       hHomer}, {x, 1, wHomer}], Frame -> False,    ColorFunction -> GrayLevel, PlotLabel -> HoldForm[10^-# ]] & /@ {5,    6, 7, 8}

Or one can design a nearly planar window that will project one’s most favorite physics equation on the wall when the Sun is shining.

physicsFormulas =    Select[(Last /@ Select[{#, FormulaData[#]} & /@ FormulaData[],         MemberQ[#,           "SpeedOfLight" | "GravitationalConstant" |            "BoltzmannConstant" | "ElectricConstant" |                            "MagneticConstant" | "PlanckConstant" |            "ReducedPlanckConstant" | "ElectronMass" |                             "StefanBoltzmannConstant" |            "ElementaryCharge" | "FaradayConstant" |            "RydbergConstant", {-1}] &]),                                FreeQ[#, _Real, \[Infinity]] &] /.     Quantity[1, s_String] :> HoldForm[Quantity[None, s]];

imPhysics =   ColorConvert[   ImageCollage[    Rasterize[#, "Image", ImageSize -> RandomInteger[{200, 400}]] & /@      TraditionalForm /@                                                                              \             RandomSample[physicsFormulas, 12], Background -> White,     ImageSize -> 800], "Grayscale"]

{wPhysics, hPhysics} = ImageDimensions[imPhysics];

ifPhysics =    Interpolation[    Flatten[MapIndexed[{#2, #1} &,       N[Floor[ImageData[imPhysics]]], {2}], 1],     InterpolationOrder -> 4];

im\[CapitalDelta]Physics =    FourierDST[    Table[-1./(4 - 2 Cos[x  Pi/hPhysics] - 2 Cos[y Pi/wPhysics]), {y,        hPhysics}, {x, wPhysics}]*                                                      FourierDST[ImageData[imPhysics], 1], 1];

if\[CapitalDelta]Physics =    Interpolation[    Flatten[MapIndexed[{Reverse@#2, #1} &,       im\[CapitalDelta]Physics, {2}], 1], InterpolationOrder -> 6];

When looking at the window, one will not notice any formulas. But this time, the solution of the Poisson equation has more overall structures.

Plot3D[Evaluate[if\[CapitalDelta]Physics[x, y]], {x, 1, wPhysics}, {y,    1, hPhysics}, MeshFunctions -> {#3 &}, PlotPoints -> 80]

But the refracted light will make physics equations. The resulting window is perfect for the entrance of, say, physics department buildings.

Image[ListConvolve[-{{0, -1, 0}, {-1, 4, -1}, {0, -1, 0}},     im\[CapitalDelta]Physics]] // ImageAdjust

Now that we’re at the end of this post, let us mention that one can also implement the Laplacian through a mirror, rather than a window. See Michael Berry’s paper from 2006, “Oriental Magic Mirrors and the Laplacian Image” (see this article as well). Modifying the above function for refracting a light ray to reflecting a light ray and assuming a mostly flat mirror surface, we see the Laplacian of the mirror surface in the reflected light intensity.

Clear[f, g]; f[x_, y_] := f0 + \[CurlyEpsilon] g[x, y]; normalize = #/Sqrt[#.#] &; \[ScriptCapitalR]R =   Module[{dir0 = normalize[{0, 0, 1}], normal, \[Phi], P0, direction2,      dir, \[Sigma]},    normal = normalize[Grad[z - f[x, y], {x, y, z}]];    \[Phi] = ArcCos[normal.dir0];     P0 = {x, y, f[x, y]};     direction2 = normalize[dir0 - normal.dir0 normal];     dir = Cos[\[Phi]] normal - Sin[\[Phi]] direction2 ;    \[Sigma] = (Z - P0[[3]])/dir[[3]];    P0 + \[Sigma] dir ] // Simplify

Series[1/Det[     Grad[Most[\[ScriptCapitalR]R], {x, y}]], {\[CurlyEpsilon], 0,     1}] // Simplify

Making transparent materials and mirrors of arbitrary shape, now called free-form optics, is considered the next generation of modern optics and will have wide applications in science, technology, architecture and art (see here). I think that a few years from now, when the advertising industry recognizes their potential, we will see magic windows with their unexpected images behind them everywhere.


Download this post as a Computable Document Format (CDF) file. New to CDF? Get your copy for free with this one-time download.

Comments

Join the discussion

!Please enter your comment (at least 5 characters).

!Please enter your name.

!Please enter a valid email address.

1 comment

  1. Yet another tour de force from Michael Trott. Laplace is for me an intellectual hero for his work in Probability and in Physics, and here he is again. I had the pleasure of a conversation with Sir Michael Berry on a bus trip connected to an International Mathematica Symposium some years ago. He’s a polymath, just like your Michael. How about Michael and Michael doing a Wolfram web-cast, on whatever they like?

    Reply