# Homotopy Visualization

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

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

• I guess you mean a homotopy, actually. Commented Sep 11, 2014 at 22:28
• Yeah, they are homeomorphic, but you are right, it's the homotopy that I want. Commented Sep 11, 2014 at 22:29
• 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. Commented Sep 11, 2014 at 22:33

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;

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}
]


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

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


One can omit the frame, of course.

• This is by far the greatest solution I've seen, excellent work! Commented Sep 12, 2014 at 18:40
• WOW, wicked answer! +1 Commented Oct 5, 2014 at 21:13
• 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] Commented Nov 24, 2015 at 17:04
• Or use -200p instead of 200p to see the evolution in reverse order. Commented Nov 24, 2015 at 17:08
• 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} Commented Nov 24, 2015 at 17:15

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:

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@#] & /@
MorphologicalComponents@ColorNegate@Binarize@# & /@ {img1, img2};

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


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}]];


• 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.
– user484
Commented Sep 12, 2014 at 17:15
• @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. Commented Sep 12, 2014 at 19:11
• 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.
– user484
Commented Sep 12, 2014 at 19:39
• @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! Commented Sep 12, 2014 at 20:20
• 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. Commented Mar 19, 2017 at 10:41