4
$\begingroup$

Poem Animation right to left speed and hold

This is a very cool artistic simple tooling black and white text effect that would appear to be possible using Mathematica's animation tool. How can this animation be created in Mathematica?

Here's what I tried but can not get ListAnimate to start the animation when the words are all visible, then do a full revolution with them.

    i = 0;
line1 = Table[{x, i++/3, 
    22}, {x, {"If", " you", "      should     ", 
     "      ever         ", "      leave         ", "      me"}}];
i = 0;
line2 = Table[{x, i++/3, 
    16}, {x, {"though", "life", "would", "still", "go", "on", 
     "believe", "me"}}];
i = 0;
line3 = Table[{x, i++/3, 
    10}, {x, {"the", "world", "could", "show" , "nothing" , "to", 
     "me"}}];
i = 0;
line4 = Table[{x, i++/3, 
    6}, {x, {"so", " what", " good", " would", " living", " do", 
     " me?"}}];
i = 0;
line5 = Table[{x, i++/3, 
    1}, {x, {"God", " only", " knows", " what", " Id", " be", 
     " without", " you"}}];
i = 0;
ListAnimate@
  Table[Graphics[{
     {Inset[#[[1]], {.4 i*#[[2]], #[[3]]}] & /@ line1},
     {Inset[#[[1]], {.3 i*#[[2]], #[[3]]}] & /@ line2},
     {Inset[#[[1]], {.25 i*#[[2]], #[[3]]}] & /@ line3},
     {Inset[#[[1]], {.2 i*#[[2]], #[[3]]}] & /@ line4},
     {Inset[#[[1]], {.1 i*#[[2]], #[[3]]}] & /@ line5}},
    PlotRange -> {{-10, 140}, {-10, 30}}], {i, 1, 400, 2}] /. 
 HoldPattern[AppearanceElements -> _] -> (AppearanceElements -> None)

enter image description here

$\endgroup$
3
  • 1
    $\begingroup$ What have you tried? $\endgroup$
    – MarcoB
    Jan 21 at 14:38
  • $\begingroup$ There are many examples of questions without code in this forum, especially related to images and animation. So posting this is not without precedent. $\endgroup$
    – R Hall
    Jan 21 at 14:52
  • 2
    $\begingroup$ Perhaps, but it's not a good precedent... $\endgroup$
    – J. M.'s torpor
    Jan 22 at 13:13
14
$\begingroup$

Here is an approach using some basics of object-oriented programming.

Load the lyrics:

str = "It's been a long, long time\nSince I've memorized your face\nIt's been four hours now\nSince I've wandered through your place\nAnd when I sleep on your couch\nI feel very safe\nAnd when you bring the blankets\nI cover up my face\nI do Love you, I doLove you\nAnd when you play guitar\nI listen to the strings buzz\nThe metal vibrates underneath your fingers\nAnd when you crochet\nI feel mesmerized and proud\nAnd I would say I love you\nbut saying it out loud is hard\nSo I won't say it at all\nAnd I won't stay very long\nBut you are the life I needed all along\nI think of you as my brother\nAlthough that sounds dumb\nWords are futile devices"
lyrics = StringSplit /@ StringSplit[StringDelete[str, ","], "\n"];
{nR, nW} = {Length@lyrics, Length /@ lyrics};

We also need to enter some baseline x-coordinates for each word to make the full text initially readable:

xpos = {{1, 1, 40}, {1, 2, 60}, {1, 3, 70}, {1, 4, 90}, {1, 5, 110}, {2, 1, 45}, {2, 2, 70}, {2, 3, 115}, {2, 4, 135}, {3, 1, 45}, {3, 2, 70}, {3, 3, 90}, {3, 4, 115}, {4, 1, 45}, {4, 2, 65}, {4, 3, 102}, {4, 4, 135}, {4, 5, 160}, {5, 1, 35}, {5, 2, 55}, {5, 3, 65}, {5, 4, 90}, {5, 5, 105}, {5, 6, 125}, {6, 1, 30}, {6, 2, 50}, {6, 3, 70}, {7, 1, 35}, {7, 2, 55}, {7, 3, 75}, {7, 4, 100}, {7, 5, 120}, {8, 1, 30}, {8, 2, 55}, {8, 3, 70}, {8, 4, 85}, {9, 1, 30}, {9, 2, 45}, {9, 3, 70}, {9, 4, 90}, {9, 5, 100}, {9, 6, 130}, {10, 1, 35}, {10, 2, 55}, {10, 3, 75}, {10, 4, 95}, {11, 1, 30}, {11, 2, 60}, {11, 3, 75}, {11, 4, 90}, {11, 5, 120}, {12, 1, 40}, {12, 2, 65}, {12, 3, 100}, {12, 4, 145}, {12, 5, 165}, {13, 1, 40}, {13, 2, 60}, {13, 3, 80}, {14, 1, 30}, {14, 2, 50}, {14, 3, 95}, {14, 4, 110}, {15, 1, 35}, {15, 2, 45}, {15, 3, 70}, {15, 4, 90}, {15, 5, 100}, {15, 6, 120}, {16, 1, 35}, {16, 2, 65}, {16, 3, 75}, {16, 4, 90}, {16, 5, 110}, {16, 6, 125}, {17, 1, 35}, {17, 2, 45}, {17, 3, 70}, {17, 4, 90}, {17, 5, 105}, {17, 6, 125}, {18, 1, 35}, {18, 2, 45}, {18, 3, 70}, {18, 4, 90}, {18, 5, 110}, {19, 1, 35}, {19, 2, 50}, {19, 3, 70}, {19, 4, 90}, {19, 5, 110}, {19, 6, 120}, {19, 7, 150}, {19, 8, 170}, {20, 1, 30}, {20, 2, 55}, {20, 3, 70}, {20, 4, 85}, {20, 5, 100}, {20, 6, 115}, {21, 1, 60}, {21, 2, 80}, {21, 3, 110}, {22, 1, 45}, {22, 2, 65}, {22, 3, 95}};
x0[r_, i_] := Cases[xpos, {r, i, _}][[1, -1]]

Define a class of objects which allows to create word objects (this_ in the function below) characterized by their row r and position in their sentence i:

SetAttributes[Words, HoldFirst];
Words[this_[r_, i_]] := (
this@t = 0.;
this@vel = 0.;
this@x = -150.;
this@y = 395. - 15r;

this@show := (
  this@t += 1;
  this@x += this@vel;
  Which [
    this@t < 25i, this@vel = 0,
    this@x < 20., this@vel = 2,
    this@x < x0[r, i], this@vel = .1 i,
    word[1, 1]@t < 1500, this@vel = this@x/4000,
    True, this@vel = i*this@t /1250 
   ];
  Inset[lyrics[[r, i + 1]], {this@x, this@y}, Left]
  );
)

This class allows each word to have its own coordinates. Coordinate x varies as a function of the word velocity vel. The Which statement enables the velocity of a word to vary throughout the journey. Playing around with the different values in Which can make the animation smoother, faster...

Notice that in the definition of the class, each word starts to accelerate once it reaches its baseline x-position x0[r,i].

Since the first word of each sentence is static, define:

StaticWords = Table[Inset[lyrics[[r, 1]], {20, 395 - 15 r}, Left], {r, nR}];

Create the actual instances of the remaining mobile words:

 Do[Words[word[r, i][r, i]], {r, nR}, {i, nW[[r]] - 1}]

Draw the list of all graphs:

optgph = {Background -> Black, PlotRange -> {{0, 400}, {40, 400}},ImageSize -> 500};

Table[word[r, i]@show, {T, 2000}, {r, nR}, {i, nW[[r]] - 1}];
MapThread[RotateRight, {Table[%[[All, r]], {r, nR}], Table[50 i - 1550, {i, nR}]}];
graph = Graphics[{White, StaticWords, #}, optgph] & /@Table[%[[All, T]], {T, 2000}];

in which RotateRight makes the full text readable from the start and introduces a slight lag between the sentences.

Animate the graph:

Animate[graph[[t]], {t, 1, Length@graph, 1}, AnimationRate -> 400]

enter image description here

$\endgroup$
1
  • $\begingroup$ Nice solution to this seemingly difficult problem! $\endgroup$
    – R Hall
    Feb 23 at 20:55
1
$\begingroup$

You may use ImageTransformation, not only for text, but for any picture. Say pic is some picture of yours. You may also distort the image in an arbitrary direction. But note also, all lines are treated the same. Here is an example that animates the effect:

Animator[Dynamic[x], AnimationDirection -> Backward]
Dynamic[x]
Dynamic@ImageTransformation[pic, (# {x, 1}) &]

enter image description here

enter image description here

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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