Message Boards Message Boards

The Vertigo Wall of Kitaoka Akiyoshi

Posted 4 years ago

Recently, a friend brought up this illusory figure by Kitaoka Akiyoshi, which could be considered as a further elaboration of the more popular café wall illusion. I thought it wouldn't be too hard to redo this in Mathematica, so I went for it.

The first step is to construct "bricks" for this new dizzying wall:

tile1p = ColorConvert[Rasterize[
         Graphics[{{Rectangle[{0, 0}, {1, 1}], Rectangle[{2, 2}, {3, 3}]},
                   {FaceForm[], EdgeForm[Directive[AbsoluteThickness[6], Gray]], 
                    Rectangle[{0, 0}, {3, 3}]}}, ImageSize -> Small, 
                  PlotRange -> {{0, 3}, {0, 3}}, PlotRangePadding -> None], 
         "Image"], "Grayscale"];

tile1m = ColorNegate[tile1p];
tile2p = ImageRotate[tile1p, π/2];
tile2m = ColorNegate[tile2p];

tile3p = ColorConvert[Rasterize[
         Graphics[{{Rectangle[{0, 0}, {1, 1}], Rectangle[{2, 0}, {3, 1}]},
                   {FaceForm[], EdgeForm[Directive[AbsoluteThickness[6], Gray]], 
                    Rectangle[{0, 0}, {3, 3}]}}, ImageSize -> Small, 
                   PlotRange -> {{0, 3}, {0, 3}}, PlotRangePadding -> None], 
         "Image"], "Grayscale"];

tile3m = ColorNegate[tile3p];
tile4p = ImageRotate[tile3p, π];
tile4m = ColorNegate[tile4p];

I needed to stare at Kitaoka's original image for quite a while to grok the pattern; having done so, I figured using a Switch[] in a Table[] would be easiest for me. Thus, here's how to show (a smaller version of) Kitaoka's wall:

With[{m = 20, n = 53}, 
     kita = ImageAssemble[Table[Switch[Mod[j, 2, 1],
                                       1, Switch[Mod[k, 18, 1],
                                                 x_ /; x < 9, If[Mod[k, 2, 1] == 1,
                                                                 tile1m, tile1p],
                                                 9, tile3m,
                                                 x_ /; x < 18, If[Mod[k, 2, 1] == 1,
                                                                  tile2m, tile2p],
                                                 18, tile4p],
                                       2, Switch[Mod[k, 18, 1],
                                                 x_ /; x < 9, If[Mod[k, 2, 1] == 1,
                                                                 tile1p, tile1m],
                                                 9, tile3p,
                                                 x_ /; x < 18, If[Mod[k, 2, 1] == 1,
                                                                  tile2p, tile2m],
                                                 18, tile4m]],
                                 {j, m}, {k, n}]]]

The effect is already pretty striking in grayscale: Kitaoka's illusion, monochrome

Applying a splash of color, however, seemed to either magnify or mute the effect for my eyes. For instance,

Colorize[kita, ColorFunction -> "M10DefaultDensityGradient"]

Kitaoka's wall, first colorization

does a number on my eyes, while with

Colorize[kita, ColorFunction -> "ThermometerColors"]

Kitaoka's wall, second colorization

the lines do not look too bent at all as I see it.

Of course, one can make a "vector" version of this by tiling appropriate Polygon[] objects in Graphics[], instead of using ImageAssemble[] like I did. (This would be important if you try to implement Charlie Deck's animated variation.) I'll leave that for someone else to do.

POSTED BY: J. M.
6 Replies

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: EDITORIAL BOARD

Could this be done with ArrayPlot?

POSTED BY: Carlo Barbieri
Posted 4 years ago

Yes, I suppose one can:

t1p = SparseArray[{{0, 0, 1}, {0, 0, 0}, {1, 0, 0}}];
t1m = SparseArray[1 - t1p, Automatic, 0];
t2p = Reverse[t1p];
t2m = Reverse[t1m];
t3p = SparseArray[{{0, 0, 0}, {0, 0, 0}, {1, 0, 1}}];
t3m = SparseArray[1 - t3p, Automatic, 0];
t4p = Reverse[t3p];
t4m = Reverse[t3m];

With[{m = 20, n = 53}, 
     ArrayPlot[ArrayFlatten[Table[Switch[Mod[j, 2, 1],
                                         1, Switch[Mod[k, 18, 1],
                                                   x_ /; x < 9, If[Mod[k, 2, 1] == 1,
                                                                   t1m, t1p],
                                                   9, t3m,
                                                   x_ /; x < 18, If[Mod[k, 2, 1] == 1,
                                                                    t2m, t2p],
                                                   18, t4p],
                                         2, Switch[Mod[k, 18, 1],
                                                   x_ /; x < 9, If[Mod[k, 2, 1] == 1,
                                                                   t1p, t1m],
                                                   9, t3p,
                                                   x_ /; x < 18, If[Mod[k, 2, 1] == 1,
                                                                    t2p, t2m],
                                                   18, t4m]], {j, m}, {k, n}]], 
                ColorFunction -> "M10DefaultDensityGradient", 
                Mesh -> {Range[0, 3 m, 3], Range[0, 3 n, 3]}, Frame -> None]]
POSTED BY: J. M.

Did I just trick you into making the vector version? :)

I would also suggest the use of PixelConstrained...

POSTED BY: Carlo Barbieri
Posted 4 years ago

ArrayPlot[] uses Raster[] internally, so I'm not too sure it counts as a "vector" version. ;)

POSTED BY: J. M.

Given that all lines are straight it should really make no difference.

POSTED BY: Carlo Barbieri
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