75
$\begingroup$

I noticed that both the lower cased 'i' and the Apple logo  are topologically equivalent to the disjoint union of two closed discs.

enter image description here

I'd like to animate a homotopy from the left to the right, can this be done in Mathematica 10 with built in functions?

Improve this question
$\endgroup$
3
  • 1
    $\begingroup$ I guess you mean a homotopy, actually. $\endgroup$
    – Mark McClure
    Commented Sep 11, 2014 at 22:28
  • $\begingroup$ Yeah, they are homeomorphic, but you are right, it's the homotopy that I want. $\endgroup$
    – tlehman
    Commented Sep 11, 2014 at 22:29
  • $\begingroup$ I did something like here to illustrate graph isomorphism. That's much simpler, though, really. Shouldn't be to hard to grab a set of points describing the boundaries of the objects but it might be tricky to maintain the topological integrity throughout the animation. $\endgroup$
    – Mark McClure
    Commented Sep 11, 2014 at 22:33

3 Answers 3

Reset to default
99
$\begingroup$

Here's a way to morph the boundaries. After finding the boundaries by Thinning of the result of EdgeDetect, FindCurvePath finds a sequence of points that traces a path around each segment. MorphologicalComponents numbers the component left to right, top to bottom, so that 1 is the apple leaf, 2 is the i-dot, 3 is the apple body, and 4 is the i-stem (5, 6 are the equal sign). We can then interpolate a path around each boundary (cIFNs). Finally we interpolate between the corresponding paths (1-p)... + p....

img = Import["https://i.sstatic.net/B7Fka.png"];
boundaries = Thinning @ EdgeDetect[img, 1];
comp = MorphologicalComponents @ boundaries;

pdata = Position[comp, #].{{0, -1}, {1, 0}} & /@ {1, 2, 3, 4};

curves = FindCurvePath /@ pdata;

cIFNs = MapThread[
   Interpolation[
     Transpose@{Rescale@Range@Length@First@#2, #1[[First@#2]]}, 
     PeriodicInterpolation -> True] &, {pdata, curves}
   ];

(* offset between middle of apple and middle of "i" *)
offset = First @ Differences[Mean @ Through[{Min, Max}[#]] & /@ pdata[[{3, 4}, All, 1]]];

Manipulate[
  ParametricPlot[{
     (1 - p) cIFNs[[1]][t] + p (cIFNs[[2]][t] + {-offset, 0}),
     (1 - p) cIFNs[[3]][t] + p (cIFNs[[4]][t] + {-offset, 0})},
   {t, 0, 1},
   Axes -> False, Frame -> True, 
   PlotRange -> {{0, 
      Total[Through[{Min, Max}[pdata[[3, All, 1]]]]]}, {-Last@
        ImageDimensions[img], 0}}],
  {p, 0, 1}
  ]

enter image description here

To morph the areas, post-process the plot by replacing Line with Polygon:

ParametricPlot[...] /. Line -> Polygon

One can omit the frame, of course.

Improve this answer
$\endgroup$
5
  • 1
    $\begingroup$ This is by far the greatest solution I've seen, excellent work! $\endgroup$
    – tlehman
    Commented Sep 12, 2014 at 18:40
  • $\begingroup$ WOW, wicked answer! +1 $\endgroup$
    – Ellie
    Commented Oct 5, 2014 at 21:13
  • $\begingroup$ Here's a neat way to see the evolution: ParametricPlot3D[{Append[(1 - p) cIFNs[[1]][t] + p (cIFNs[[2]][t] + {-offset, 0}), 200 p], Append[(1 - p) cIFNs[[3]][t] + p (cIFNs[[4]][t] + {-offset, 0}), 200 p]}, {p, 0, 1}, {t, 0, 1}, Axes -> False, Boxed -> False] $\endgroup$
    – Greg Hurst
    Commented Nov 24, 2015 at 17:04
  • $\begingroup$ Or use -200p instead of 200p to see the evolution in reverse order. $\endgroup$
    – Greg Hurst
    Commented Nov 24, 2015 at 17:08
  • $\begingroup$ Seeing the homotopy between the apple logo and the equals sign is pretty neat too. pdata = Position[comp, #].{{0, -1}, {1, 0}} & /@ {1, 5, 3, 6} $\endgroup$
    – Greg Hurst
    Commented Nov 24, 2015 at 17:15
55
$\begingroup$

One way to do it would be to use glyphs. We can extract the curves that make up the two characters as follows:

a = First@First@Last@First@First@
       ImportString[ExportString[
         Style[FromCharacterCode[61440], 24, FontFamily -> "Baskerville Old Face"],
       "PDF"], "PDF", "TextMode" -> "Outlines"];

b = First@First@Last@First@First@
       ImportString[ExportString[
         Style["i", 24, Bold, FontFamily -> "Courier New"],
       "PDF"], "PDF", "TextMode" -> "Outlines"];

These each give a FilledCurve, which I presume defines a spline. The documentation doesn't seem to explain the format given here. But it appears to be a bunch of control information (degree? knots?), then a bunch of points. But we shall not let ignorance stop us.

The main challenge now is morphing one curve into another. Since the apple logo has more points than the 'i', we shall simply force a bunch of repeated points in the 'i' curve to aid in the transition. First grab the data:

control = First@a;
pa = Last@a;
pb = Last@b;
magic = {{2, 8, 3, 8, 2}, {2, 2, 1, 2, 2, 2, 1, 2, 2, 2, 1, 2, 2, 2, 1, 2, 2, 2, 1,
    2, 2, 2, 1, 2, 2, 2, 1, 2, 2, 2, 1, 2, 2, 2, 1, 2, 2, 2, 1, 2, 2, 2, 2, 2}};

Then repeat some points in the 'i':

newb = Map[Sequence @@ ConstantArray[First@#, Last@#] &, Thread /@ Thread[{pb, magic}], {2}];

Now we can just do a simple linear transition between the two:

Table[Graphics@FilledCurve[control, pa + t (newb - pa)], {t, 0, 1, 0.1}]

Using a sinusoidal t, and some well chosen Export options (exercise left to the reader), we get:

applemorph

Improve this answer
$\endgroup$
44
$\begingroup$

Let us do it purely by image-processing. The main idea is to use DistanceTransform here.

{img1, img2} = ImageResize[#, Scaled[3]] & /@ 
   Import /@ {"https://i.sstatic.net/RKHo5.png", 
        "https://i.sstatic.net/MFGR4.png"}

The signed distances to the boundaries of all morphological components are

dist = ImageData@ImageSubtract[DistanceTransform@Image@#, 
          DistanceTransform@ColorNegate@Image@#] & /@ 
       ComponentMeasurements[#, "Mask"][[All, 2]] &@
     MorphologicalComponents@ColorNegate@Binarize@# & /@ {img1, img2};

Map[ImageAdjust@Image@# &, dist, {2}] // Grid

enter image description here

It is remain is to take a linear composition of these distances

top[t_] := ColorNegate@Image@Total[UnitStep[# (1 - t) + #2 t] & @@@ Transpose@dist];

Export["anim.gif", Join[#, Reverse@#] &@ 
   Table[ImageResize[top[t], Scaled[1/3]], {t, 0, 1, 0.01}]];

enter image description here

Improve this answer
$\endgroup$
5
  • $\begingroup$ I'm afraid this technique doesn't always produce a homotopy. For example, try interpolating a small disk in the lower left corner to a small disk in the upper right; it will disappear along the way. $\endgroup$
    – user484
    Commented Sep 12, 2014 at 17:15
  • $\begingroup$ @RahulNarain, yes, if there is no intersection then there is such an artifact. One can avoid it by introducing a moving center and applying the algorithm above relative to the moving center. Like in physics: motion of the center of mass and the relative motion. If you are interesting, I can add corresponding lines to the code. $\endgroup$
    – ybeltukov
    Commented Sep 12, 2014 at 19:11
  • $\begingroup$ I think translating the center of mass will not help with these images: i.sstatic.net/2ob00.png, i.sstatic.net/RIL4B.png. But perhaps I'm being too critical. $\endgroup$
    – user484
    Commented Sep 12, 2014 at 19:39
  • $\begingroup$ @RahulNarain Yes :) It's a very difficult task to deal with such images. Spirals will be even more difficult. Thank you for the deep insight in my answer! $\endgroup$
    – ybeltukov
    Commented Sep 12, 2014 at 20:20
  • $\begingroup$ The big benefit of this approach is that can create a smooth mapping between shapes where a homotopy doesn't exist at all, e.g. mapping a "P" to an "F", or an "O" to an "i". I only discovered your answer until I hacked it down myself. Nevertheless +1 for this nice answer. $\endgroup$
    – halirutan
    Commented Mar 19, 2017 at 10:41

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.