Create the source image for this cool animated illusion

Question

Have a look at this very awesome video:

https://www.youtube.com/watch?v=lvvcRdwNhGM

You have a vertically discretized image, which is composed of 5 or 6 images, which are shifted by an increment, as large as the line width of the comb.

When you move the comb you display always one of those images, and hence create the illusion of movement:

I would like to create the background images to print out using Mathematica.

Input: Image or video sequence + Line width of grid (distance between two black lines)

Output: image to print out and use as background image behind the comb

*Steps for the Mathematica code:*

n: distance between each black line

m: number of input images

Let's try to animate a flying bird:

1. Cut out vertical slices from each image. The slice width should be equal to the distance between each black line n multiplied by the number of input pictures m.

2. Reassemble all the pictures, but each picture should be translated by m(i)n.

It would be awesome to see it work. Any help is welcome.

Answer 1

TUTORIAL

---

Import Image

img = Import["https://i.sstatic.net/xzcUg.jpg"]

Split into Components

Using this approach (credit: nikie):

m = MorphologicalComponents[Binarize@ColorNegate[ColorConvert[img, "Grayscale"]]];
Colorize[m]

components = ComponentMeasurements[{m, img}, {"Area", "BoundingBox"}, #1 > 100 &];

trim = ImageTrim[img, #] & /@ components[[All, 2, 2]]

There's a problem with trim[[3]] and trim[[4]], so:

Trim Component nr 3

trim[[3]] = RemoveBackground @ DeleteSmallComponents @ RemoveBackground @ trim[[3]]

Trim Component nr 4

trim[[4]] = RemoveBackground @ DeleteSmallComponents @ RemoveBackground @ trim[[4]]

Component Images

trim

dim = ImageDimensions /@ trim

{{299, 272}, {301, 256}, {262, 231}, {262, 253}, {302, 255}, {281, 269}, {261, 252}, {261, 231}}

ListAnimate @ trim

trim = ImageResize[#, {304, 270}] & /@ trim

I decided on the above {304, 270} so that 304 will be easily divisible by 8 later.

dim = ImageDimensions /@ trim

ListAnimate @ trim

Image Cuts

This is the proper part; I made it very crude just to show the approach and how does it work. The details, like the number of slices, their widths and heights etc. should be thought through.

cuts = Plus[#, {1, 0}] & /@ Partition[FindDivisions[{1, 304, 38}, 8], 2, 1]

{{1, 38}, {39, 76}, {77, 114}, {115, 152}, {153, 190}, {191, 228}, {229, 266}, {267, 304}}

slices = Table[ImageTake[trim[[i]], {1, 270}, #] & /@ cuts, {i, 8}]

Reassemble

reas = Flatten @ Table[Flatten[slices][[i ;; 64 ;; 8]], {i, 8}]

reas2 = ImageAssemble[ConformImages @ reas]

Moving Window

ImageDimensions @ reas2

{2432, 270}

window = ImageAssemble @
  Table[ImagePad[#, {{38, 0}, {0, 0}}, Directive@Transparent] & @
    ImageResize[Graphics[Rectangle[]], {304 - 38, 270}], 8]

Overlay[{reas2, window}]

Slide

Make a set of windows:

windows = 
 Table[ImageAssemble @
   RotateRight[First @ ImagePartition[window, {38, 270}], i], {i, 0, 7}]

Make a set of Overlays:

seq = Overlay[{reas2, #}] & /@ windows

Finally:

ListAnimate @ seq

---

---

The last gif doesn't really look like a flying bird due to the ratios etc. So now I'll repeat the steps from Image Cuts on with modifications to make it look nicer.

Image Cuts

Let's stick to the width of each component equal to 304;

Divisors @ 304

{1, 2, 4, 8, 16, 19, 38, 76, 152, 304}

Let's make 16 slices of each component, each slice be of width 19 pixels:

cuts = Plus[#, {1, 0}] & /@ Partition[FindDivisions[{1, 304, 19}, 16], 2, 1]

{{1, 19}, {20, 38}, {39, 57}, {58, 76}, {77, 95}, {96, 114}, {115, 133}, {134, 152}, {153, 171}, {172, 190}, {191, 209}, {210, 228}, {229, 247}, {248, 266}, {267, 285}, {286, 304}}

slices = Table[ImageTake[trim[[i]], {1, 270}, #] & /@ cuts, {i, 8}]

Reassemble

There are

Length @ Flatten @ slices

128

slices, so

reas = Flatten @ Table[Flatten[slices][[i ;; 128 ;; 16]], {i, 16}]
reas2 = ImageAssemble[ConformImages @ reas]

But here the image is stretched only horizontally, which makes it unproportional. Since

ImageDimensions @ reas2

{2432, 270}

where $2432=304\times 8$, we need to ImageResize the image also vertically by a factor of 8:

reas2 = ImageResize[reas2, {2432, 270*8}]

Moving Window

Now the same trick with window:

window = ImageAssemble @
  Table[ImagePad[#, {{19, 0}, {0, 0}}, Directive@Transparent] & @
    ImageResize[Graphics[Rectangle[]], {304/2 - 19, 270 8}], 16]

Note that I'm quite insane, because

ImageDimensions @ window

{2432, 2160}

(i.e., a resolution of a not bad TV ;)

The Overlay of two images looks nice:

Overlay[{reas2, window}]

Slide

The same as before:

windows = 
 Table[ImageAssemble @
   RotateRight[First @ ImagePartition[window, {19, 270 8}], i], {i, 0, 7}]

seq = Overlay[{reas2, #}] & /@ windows

and finally

gif3 = ListAnimate@seq

Unfortunately, the gif is too big (2.3 MB) to upload it here, so you can see it on imgur: https://i.sstatic.net/3bu2O.jpg

---

---

Smaller-sized gif

The high-resolution (i.e., final reas2 and window) should be perfect if one would really want to print it like on the YT video. To make a reasonable-size gif, let's resize reas2 and windows:

reas3 = ImageResize[reas2, {304, 270}]

windows2 = ImageResize[#, {304, 270}] & /@ windows

seq2 = Overlay[{reas3, #}] & /@ windows2

ListAnimate @ seq2

and the gif is exported with

Export["gif4.gif", seq2, "DisplayDurations" -> 0.25]

---

There's also this YT video showing how to draw a pacman by hand. That approach is equivalent to taking only four components, meaning that the black lines were 3x thicker than the transparent one (I refer to the window now), i.e. 75% of the window is black. In the above bird, $7/8=87.5\%$ is black, so there's not much space left to see the actual figure. So I'd say that the fewer the component images, the better. And also the animation rate is crucial.

(I now think that maybe Gray instead of Black would be better for the bird's window...)

---

Due to an invitation by Vitaliy Kaurov (thanks!), this answer has been also cross posted on http://community.wolfram.com/groups/-/m/t/980590?p_p_auth=QTOfV64I and chosen to be among the Staff Picks.

Answer 2

I gave this a try too. Turns out this method works better for certain aspect ratios, and certain number of frames. My image isn't very suitable, but here we go. I got the image from this website.

img = RemoveAlphaChannel@Import["http://blaiprat.github.io/jquery.animateSprite/img/scottpilgrim_multiple.png"];

{w, h} = {108, 140};
gap = 5;

{right, left} = ImagePartition[img, {w, h}];

right // GraphicsRow

background = ImageAssemble@Flatten@Transpose[
      First[ImagePartition[#, {gap, h}]] & /@ right
    ]

The above is all you need for a printout. This for previewing the effect on the computer:

white = ConstantImage[White, {gap, h}];
black = ConstantImage[Black, {gap, h}];

frames = Table[
  mask = RotateRight[PadRight[{white}, Length[right], black], n];
  mask = ImageAssemble@PadRight[{}, Floor[w Length[mask]/gap], mask];
  ImageMultiply[background,mask], {n, 0, Length[right], 1}];

You can export the frames as a gif or look at them with ListAnimate.

Export["running.gif", frames]