Message Boards Message Boards

[GIF] A to Z (Image morph)

Image morph

A to Z

I've mentioned before that there's a construction which gives a correspondence between points on the Grassmann manifold $G_2(\mathbb{R}^n)$ of 2-dimensional linear subspaces of $\mathbb{R}^n$ and planar $n$-gons; details at 1, 2, 3, 4, 5, 6.

In particular, this gives a way of morphing between any two (discrete) shapes you like; this animation shows the shortest path from A to Z.

Here's the code; notice that I use the smootheststep function:

ProjectionBasis[{A_, B_}, {C_, D_}] := 
  Normalize[#] & /@ 
   Eigenvectors[
    Transpose[Transpose[{A, B}].{A, B}.Transpose[{C, D}].{C, D}], 2];

PlaneGeo[{A_, B_}, {C_, D_}, t_] := 
  Module[{a, b, c, d, cPerp, dPerp, dist1, dist2},
   {a, b} = ProjectionBasis[{C, D}, {A, B}];
   {c, d} = ProjectionBasis[{A, B}, {C, D}];
   {cPerp, dPerp} = {Normalize[c - (c.a)*a], Normalize[d - (d.b)*b]};
   dist1 = ArcCos[a.c];
   dist2 = ArcCos[b.d];
   {Cos[t*dist1]*a + Sin[t*dist1]*cPerp, 
    Cos[t*dist2]*b + Sin[t*dist2]*dPerp}
   ];

MakePoly[data_] := 
  Normalize[#] & /@ 
   Transpose[{Re[#], Im[#]} & /@ 
     Sqrt[Table[#[[n]][[1]] + I*#[[n]][[2]], {n, 1, Length[#]}] &[
       RotateLeft[#] - # &[data]]]];

RawAData = {{-3., .9}, {1.07, 8.18}, {1.85, 8.2}, {5.96, 0.86}, {4.89,
     0.86}, {1.77, 6.6}, {1.18, 6.6}, {.12, 4.58}, {2.87, 4.6}, {3.35,
     3.76}, {-.18, 3.76}, {-1.72, .94}};

RawZData = {{0.82, 7.26}, {7.61, 7.32}, {7.65, 
    6.04}, {1.92, -.06}, {7.76, -.02}, {7.8, -1.16}, {.71, -1.12}, \
{.71, .02}, {6.36, 6.12}, {.85, 6.12}, {.82, 6.12}, {.82, 7.26}};

ToPol[frame_] := 
  Accumulate[ReIm[(Complex @@ #)^2] & /@ Transpose[frame]];

smootheststep[t_] := -20 t^7 + 70 t^6 - 84 t^5 + 35 t^4;

DynamicModule[{cols = RGBColor /@ {"#f77e5e", "#3dbd5d", "#303030"}, 
  centeredpoints, s},
 Manipulate[
  s = smootheststep[t];
  centeredpoints = # - ConstantArray[Mean[#], Length[#]] &[
    RotationTransform[(26 - 44 s) Degree][
     Prepend[ToPol[
       PlaneGeo[MakePoly[RawAData], MakePoly[RawZData], s]], {0, 0}]]];
  Graphics[{Thickness[.008], JoinForm["Round"], 
    Blend[cols[[;; 2]], s], Line[centeredpoints]}, 
   ImageSize -> {540, 540}, 
   PlotRange -> {{-.26 + .02 s, .29 + .02 s}, {-.28 - .065 s, .32 - .065 s}}, Background -> cols[[-1]]], {t, 0, 1}]
 ]
POSTED BY: Clayton Shonkwiler
13 Replies
Sort By:

This is interesting:

this animation shows the shortest path from A to Z

But "shortest" in what sense, what is the measure? Perhaps the area that boundary traces? This is an attempt to visualize the "integral change". If we modify just the part of code starting from DynamicModule, we get (note .SVG gives nice vector look):

Module[{cols = RGBColor /@ {"#f77e5e", "#3dbd5d", "#303030"}, centeredpoints, s},
  tmp = Table[s = smootheststep[t];
    centeredpoints = # - ConstantArray[Mean[#], Length[#]] &[
      RotationTransform[(26 - 44 s) Degree][Prepend[ToPol[
         PlaneGeo[MakePoly[RawAData], MakePoly[RawZData], s]], {0, 0}]]];
    Graphics[{Thickness[.008], Opacity[.5], JoinForm["Round"], 
      Blend[cols[[;; 2]], s], Line[centeredpoints]}, 
     ImageSize -> {540, 540}, 
     PlotRange -> {{-.26 + .02 s, .29 + .02 s}, {-.28 - .065 s, .32 - .065 s}}, 
Background -> cols[[-1]]], {t, 0, 1, .005}]];

Show[tmp, PlotRange -> All]

enter image description here
POSTED BY: Marina Shchitova
POSTED BY: Clayton Shonkwiler

Very cool. But your GIF has letter "A" straight. And you Manipulate does not. Do you have the code that makes Z - > A with both letters straight, as on GIF?

POSTED BY: Sam Carrettie

Yes, there often is some interesting math hiding behind my animations, and you're right that I should probably do a better job pointing it out when it's there. Often when I finish an animation (which can sometimes take a long time), the last thing I want to do is spend another hour explaining the ideas behind it, but I will try to be more conscientious about that.
POSTED BY: Clayton Shonkwiler

enter image description here - another post of yours has been selected for the Staff Picks group, congratulations! We are happy to see you at the top of the "Featured Contributor" board. Thank you for your wonderful contributions, and please keep them coming!
POSTED BY: EDITORIAL BOARD

Neat image!
POSTED BY: Sander Huisman

This is a complete mystery. Below the Manipulates for both codes you provided on 

$Version
"11.0.1 for Mac OS X x86 (64-bit) (September 21, 2016)"

1st

enter image description here

2nd

enter image description here
POSTED BY: Sam Carrettie
POSTED BY: Clayton Shonkwiler

Ah, okay, I'm on a different version, so my guess is that this is some internal change in how eigenvectors are computed. How about this (which completely obscures what's going on, but eliminates the eigenvector computations)?

ToPol[frame_] := 
  Accumulate[ReIm[(Complex @@ #)^2] & /@ Transpose[frame]];

smootheststep[t_] := -20 t^7 + 70 t^6 - 84 t^5 + 35 t^4;

DynamicModule[{cols = RGBColor /@ {"#f77e5e", "#3dbd5d", "#303030"}, 
  centeredpoints, s, AZPath},
 AZPath[s_] := {{-0.6183 Cos[0.6237 s] - 
     0.05281 Sin[0.6237 s], -0.1936 Cos[0.6237 s] - 
     0.05875 Sin[0.6237 s], -0.4726 Cos[0.6237 s] + 
     0.1089 Sin[0.6237 s], -0.05233 Cos[0.6237 s] - 
     0.7733 Sin[0.6237 s], -0.3966 Cos[0.6237 s] + 
     0.2414 Sin[0.6237 s], -0.03886 Cos[0.6237 s] + 
     0.1973 Sin[0.6237 s], -0.1054 Cos[0.6237 s] - 
     0.07660 Sin[0.6237 s], -0.3627 Cos[0.6237 s] - 
     0.3582 Sin[0.6237 s], -0.1609 Cos[0.6237 s] + 
     0.3523 Sin[0.6237 s], -0.09504 Cos[0.6237 s] + 
     0.1416 Sin[0.6237 s], -0.1219 Cos[0.6237 s] - 
     0.05366 Sin[0.6237 s], 
    0.05338 Cos[0.6237 s] - 
     0.07418 Sin[0.6237 s]}, {-0.1933 Cos[1.476 s] - 
     0.06772 Sin[1.476 s], 0.04221 Cos[1.476 s] + 0.1317 Sin[1.476 s],
     0.4471 Cos[1.476 s] + 
     0.4660 Sin[1.476 s], -0.2261 Cos[1.476 s] - 
     0.05784 Sin[1.476 s], -0.4140 Cos[1.476 s] + 
     0.1673 Sin[1.476 s], -0.1679 Cos[1.476 s] - 0.5314 Sin[1.476 s], 
    0.3220 Cos[1.476 s] - 0.2102 Sin[1.476 s], 
    0.08257 Cos[1.476 s] - 0.3301 Sin[1.476 s], 
    0.1509 Cos[1.476 s] - 0.4968 Sin[1.476 s], -0.4106 Cos[1.476 s] + 
     0.003600 Sin[1.476 s], 0.3832 Cos[1.476 s] - 0.2160 Sin[1.476 s],
     0.2482 Cos[1.476 s] - 0.02369 Sin[1.476 s]}};
 Manipulate[s = smootheststep[t];
  centeredpoints = # - ConstantArray[Mean[#], Length[#]] &[
    RotationTransform[(26 - 44 s) Degree][
     Prepend[ToPol[AZPath[s]], {0, 0}]]];
  Graphics[{Thickness[.008], JoinForm["Round"], 
    Blend[cols[[;; 2]], s], Line[centeredpoints]}, 
   ImageSize -> {540, 540}, 
   PlotRange -> {{-.26 + .02 s, .29 + .02 s}, {-.28 - .065 s, .32 - .065 s}}, Background -> cols[[-1]]], {t, 0, 1}]]
POSTED BY: Clayton Shonkwiler

Beautiful. And thanks for the explanation. I am finding myself going on a loop reading through it ;-) So there is basically so much more math behind this animation. I was watching your animation posts for quite awhile already. And I got a sense that despite visual simplicity there is always some math complexity to it. And as this case proves, there is more to it than meets the eye. I think many people here would be interested in hearing the more detailed mathy explanations when you post animations. It is very cool to try to understand what is really happening. I'm looking forward to more food for thought and eyes ;-)
POSTED BY: Marina Shchitova
POSTED BY: Sam Carrettie

Agree! I'm not even sure I grasp a tiny bit of it to be honest! But it is very interesting and potentially useful!
POSTED BY: Sander Huisman

The Manipulate gives a straight A on my computer, so I'm not sure what the problem is. Maybe this will work?

ProjectionBasis[{A_, B_}, {C_, D_}] := 
  Normalize[#] & /@ 
   Eigenvectors[
    Transpose[Transpose[{A, B}].{A, B}.Transpose[{C, D}].{C, D}], 2];

PlaneGeo[{A_, B_}, {C_, D_}, t_] := 
  Module[{a, b, c, d, cPerp, dPerp, dist1, dist2}, {a, b} = 
    ProjectionBasis[{C, D}, {A, B}];
   {c, d} = ProjectionBasis[{A, B}, {C, D}];
   {cPerp, dPerp} = {Normalize[c - (c.a)*a], Normalize[d - (d.b)*b]};
   dist1 = ArcCos[a.c];
   dist2 = ArcCos[b.d];
   {Cos[t*dist1]*a + Sin[t*dist1]*cPerp, 
    Cos[t*dist2]*b + Sin[t*dist2]*dPerp}];

AFrame = {{0.5587691672676915`, 0.1981237081903733`, 
    0.561282439075137`, 0.`, 0.29303258430728735`, 0.`, 
    0.17528178862450003`, 0.37198264830477284`, 0.1908285679285995`, 
    0.`, 0.205163066218776`, 
    0.00396483829652537`}, {0.3277750387491631`, 
    0.00253963018178132`, -0.3289966965729807`, 0.23203064786359323`, 
    0.49280250767258005`, 0.17229769584575513`, -0.28992889821878054`,
     0.0013526462896582667`, -0.11074211838066708`, 
    0.421444913379544`, -0.34580148914295383`, -0.25381158645873014`}};

ZFrame = {{0.5395712230915538`, 0.16826135725211128`, 
    0.2378635055662534`, 0.500401524060885`, 0.15909799999674124`, 
    0.0015553022620756472`, 0.1563317110647911`, 0.547153066305452`, 
    0.`, 0.`, 0.15633171106479107`, 
    0.`}, {0.0023839205766322895`, -0.16308532865529982`, -0.5497830309003788`, 0.0017136837511977539`, -0.15361352050274618`, 
    0.5513590391833545`, 0.1563317110647911`, 0.23900682840695045`, 
    0.4860550423730885`, 0.035864954221169684`, 0.15633171106479107`, 
    0.`}};

ToPol[frame_] := 
  Accumulate[ReIm[(Complex @@ #)^2] & /@ Transpose[frame]];

smootheststep[t_] := -20 t^7 + 70 t^6 - 84 t^5 + 35 t^4;

DynamicModule[{cols = RGBColor /@ {"#f77e5e", "#3dbd5d", "#303030"}, 
  centeredpoints, s}, Manipulate[s = smootheststep[t];
  centeredpoints = # - ConstantArray[Mean[#], Length[#]] &[
    RotationTransform[(26 - 44 s) Degree][
     Prepend[ToPol[PlaneGeo[AFrame, ZFrame, s]], {0, 0}]]];
  Graphics[{Thickness[.008], JoinForm["Round"], 
    Blend[cols[[;; 2]], s], Line[centeredpoints]}, 
   ImageSize -> {540, 540}, 
   PlotRange -> {{-.26 + .02 s, .29 + .02 s}, {-.28 - .065 s, .32 - .065 s}}, Background -> cols[[-1]]], {t, 0, 1}]]
POSTED BY: Clayton Shonkwiler
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Tag limit exceeded
Note: Only the first five people you tag will receive an email notification; the other tagged names will appear as links to their profiles.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract