# How can this type of optical illusion be created in Mathematica?

I see these around the web and would like to make them in Mathematica.
Combining them in an array is actually quite mesmerizing! • is it my eyes or do I see it spinning? This only happens when I am not looking at it directly. I bet that either The Mathematica Guidebook: Graphics or Graphica: The World Of Mathematica Graphics both by Graphics Michael Trott will have something like this ! – Nasser Aug 14 '13 at 23:21
• – Michael E2 Aug 14 '13 at 23:41
• As usual: what have you tried? What Mathematica related difficulty are you having in producing this image? – Jens Aug 14 '13 at 23:56
• I didn't downvote and instead upvoted now... since apparently someone had fun wit this after all. But I also agree with @MichaelE2. – Jens Aug 15 '13 at 0:47
• You might be interested in this blog which also animates such optical illusions. – Michael E2 Aug 15 '13 at 1:40

Forward Mapping

One way to do it is to create the texture for one tile and then transform repeated copies of it in a way that resembles the original illusion.

First we create the tile:

tile = Module[{KeyHole},
KeyHole[base_] := Sequence[
Disk[{0, 1/3} + base, 1/10], Rectangle[{-1/30, 1/15} + base, {1/30, 1/3} + base]
];
Image@Rasterize@Graphics[
{Orange, Rectangle[{0, 0}, {1, 1}],
Blue,   Rectangle[{0, 0}, {1/2, 1/2}], Rectangle[{1/2, 1/2}, {1, 1}],
Black, KeyHole[{0,   0}], KeyHole[{1/2, 1/2}], KeyHole[{1,   0}],
White, KeyHole[{0, 1/2}], KeyHole[{1/2,   0}], KeyHole[{1, 1/2}]
},
PlotRange -> {{0, 1}, {0, 1}}
]
] Then we make repeated copies of it:

floortex = ImagePad[
ImageRotate[#, Right],
5 First@ImageDimensions[#], "Periodic"
] &[tile] For the transformation we can use an exponential mapping, which will turn the $y$-coordinate into an angle and the $x$-coordinate into an exponent for radial distance. Since the mapping is most elegantly described with complex numbers but we need to work with cartesian coordinates we can use ComplexExpand to do the work for us (which is not very hard in this case, but could be useful for trying out other mappings):

ComplexExpand[Through[{Re, Im}[ Exp[x + I y] ]]]
(* {E^x Cos[y], E^x Sin[y]} *)


Since this is so useful we wrap it in a procedure for easy reuse:

CartesianMappingFromComplexFunction[f_] := Function[{x, y},
Evaluate@ComplexExpand@Through[{Re, Im}[f[x + I y]]]
]


Now we just need a way to transform our checkerboard image according to our mapping, which is exactly what ImageForwardTransformation does:

ImageForwardTransformation[
floortex,
{Exp[#[]] Cos[#[]], Exp[#[]] Sin[#[]]} &,
PlotRange -> {{-1, 1}, {-1, 1}},
DataRange -> {{-2 \[Pi], 0}, {0, 2 \[Pi]}},
Background -> White
] Inverse Mapping

Michael E2 pointed out another possible way, namely using the inverse mapping, so let's try that! Up to now we basically let Mathematica do a forward transform of our checkerboard into the disk shape and let it fill the holes via interpolation and throw away the points that got mapped outside of our PlotRange which is kind of wasteful.

Instead we can go the reverse route and start with the destination pixel locations and ask where they came from before undergoing that exponential mapping. Since we made the effort to generalize the procedure of getting a cartesian mapping from any complex function we now can just plug in the inverse complex function, which is the (or rather a branch of) the complex Log, and get

CartesianMappingFromComplexFunction[Log]
(* Function[{x, y}, {Log[x^2 + y^2]/2, Arg[x + I*y]}] *)


Great! Now we can use ImageTransformation with our inverse mapping

ImageTransformation[
floortex,
{Log[#[]^2 + #[]^2]/2, Arg[#[] + I*#[]]} &,
PlotRange -> {{-1, 1}, {-1, 1}},
DataRange -> {{-2 \[Pi], 0}, {-\[Pi], \[Pi]}}, Padding -> White
]


where we had to adjust the DataRange in order to coincide with the target set of Arg. Because we evenly sample the target image instead of the original checkerboard, we get much better image quality with less computation (14s vs. 19s on my machine).

To see the difference here are images from both approaches, but generated from a tile with RasterSize -> 128 and ImageResolution -> 128 given as options to Rasterize: ImageForwardTransformation ImageTransformation

With ImageTransformation, we basically get antialiasing for free, which can be further customized via the Resampling option.

• Very cool solution thanks! How does ComplexExpand function apply to this? I don't see it used. – R Hall Aug 15 '13 at 0:10
• @RHall He used ComplexExpand to simply justify to the formula he is using inside the ImageForwardTransformation. – PlatoManiac Aug 15 '13 at 0:12
• @PlatoManiac Thanks very much! – R Hall Aug 15 '13 at 0:14
• @RHall This is very similar to the method of this answer to the question I said above was related, which uses a log-polar transformation to convert a regular pattern in the plane to circular pattern. – Michael E2 Aug 15 '13 at 0:15
• @Thies @RHall Ok, then one more thing I would add is that the ImageTransformation method runs 9X faster on my machine, 6 vs. 54-55 sec. Code: LogPolar[{x_, y_}] := { Log[Sqrt[x^2 + y^2]], ArcTan[x, y]}; ImageTransformation[floortex, LogPolar, PlotRange -> {{-1, 1}, {-1, 1}}, DataRange -> {{-2 π, 0}, {-π, π}}, Padding -> White]. Cheers! :) – Michael E2 Aug 15 '13 at 17:17

I decided to take a slightly different approach. Instead of transforming an image, I thought of constructing a function that will look like the illusory figure in the OP after performing the log-polar transform. Here's what I came up with:

checkerboard[x_, y_] := Boole[EvenQ[Floor[x] - Floor[y]]]
keyholes[x_, y_] := Boole[(Mod[x - 1/2, 1] - 1/2)^2 + (Mod[y, 1] - 2/3)^2 < 1/25 ||
(13/30 < Mod[x - 1/2, 1] < 17/30 && 1/8 < Mod[y, 1] < 1/2)]

DensityPlot[With[{u = 32 ArcTan[x, y]/π, v = 4 Log[x^2 + y^2]},
(1 - keyholes[u, v]) (2 checkerboard[u, v] - 1) +
keyholes[u, v] (2 checkerboard[u - 1/2, v] - 1)/3],
{x, -1, 1}, {y, -1, 1},
ColorFunction -> (Blend[{Orange, Black, White, Blue}, #] &),
Exclusions -> None, Frame -> False, PlotPoints -> 405,
RegionFunction -> (#1^2 + #2^2 < 1 &)] Here is a ContourPlot[] version of a slightly less "busy-looking", but still sufficiently eye-popping illusion:

ContourPlot[With[{u = 12 ArcTan[x, y]/π, v = 2 Log[x^2 + y^2]},
(1 - keyholes[u, v]) (2 checkerboard[u, v] - 1) +
keyholes[u, v] (2 checkerboard[u - 1/2, v] - 1)/3],
{x, -1, 1}, {y, -1, 1},
ColorFunction -> (Blend[{Orange, Black, White, Blue}, #] &),
ContourStyle -> None, Exclusions -> None, Frame -> False,
PlotPoints -> 405, RegionFunction -> (#1^2 + #2^2 < 1 &)] The illusion can be created completely in vector form without using any plotting function. I'll start from the wonderfully elegant solution by Thies Heidecke.

The key change is that instead of Circle and Rectangle I use Polygon-based approximations for them:

Clear[squarePoints, KeyHole, tile]
squarePoints[{xmin_, ymin_}, {xmax_, ymax_}, n_: 6] :=
Join[Array[{#, ymin} &, n, {xmin, xmax}], Array[{#, ymax} &, n, {xmax, xmin}]];
KeyHole[base_] :=
Sequence[Polygon[CirclePoints[{0, 1/3} + base, 1/10, 24]],
Polygon[base + # & /@ {{-1/30, 1/15}, {1/30, 1/15}, {1/30, 1/3}, {-1/30, 1/3}}]];
tile[base_] := {
Orange, Polygon[{squarePoints[{0, 1/2} + base, {1/2, 1} + base],
squarePoints[{1/2, 0} + base, {1, 1/2} + base]}],
Blue, Polygon[{squarePoints[{0, 0} + base, {1/2, 1/2} + base],
squarePoints[{1/2, 1/2} + base, {1, 1} + base]}],
Black, KeyHole[{0, 0} + base], KeyHole[{1/2, 1/2} + base], KeyHole[{1, 0} + base],
White, KeyHole[{0, 1/2} + base], KeyHole[{1/2, 0} + base], KeyHole[{1, 1/2} + base]};


Now the illusion can be generated as follows:

nCircle = 10; levels = 10;
gr = Graphics[N@Table[tile[{x, y}], {x, nCircle}, {y, levels}],
ImageSize -> 600] /. {y_Real, x_Real} :> {E^(2 Pi x/nCircle) Cos[2 Pi y/nCircle],
E^(2 Pi x/nCircle) Sin[2 Pi y/nCircle]} We can turn on antialiasing using Style:

Style[%, Antialiasing -> True] 