Message Boards Message Boards

Happy theoretical 2014 from Russia!

Posted 11 years ago
I guess it is typical for Russian greetings to come with necessity to brush up on your theoretical mechanics. As you can see below there are 61 randomly constructed friction-damped pendulums swinging in chaos just to eventually converge to cheerful red 2014 – which is inscribed in their stable equilibrium positions. Watch them here dancing under inspirational classical music.

Our sister Russian community counts almost 2000 members from all around Eastern Europe and beyond. Over the holidays they have enjoyed this Wolfram Language artwork designed by Roman Osipov and wish to share it with us. Original notebook in Russian can be dowloaded here. So let me translate the inner workings.

Take a simple string with some simple formatting:
string = Style["2014", FontFamily -> "Arial", 11];

Let's Rasterize, Binarize and Rotate the resulting image to the right by 90 degrees (necessary for to adjust for different coordinate systems in images and WL arrays):
image = ImageRotate[Binarize@Rasterize[string], -90 Degree];

Convert the image to a set of numbers corresponding to the two color values??, because it was binarized (1 - white, 0 - black):
imageData = ImageData[image];

Translate the image into a set of points, taking the indices of black pixels in Cartesian coordinates:
points = N[Position[imageData, 0]];

Look at the resulting set of points:
Graphics[Point[points], ImageSize -> 500]

Find how many points there are in the image:
lengthP = Length[points]
(* Out[] = 61 *)

We will now define a function, which solves the differential equation describing the pendulum with damping:
sol[x0_: 1, v0_: 0, s_: 1] := sol[x0, v0, s] =
  NDSolve[{x''[t] + s x'[t] + 9.8 Sin[x[t]] == 0, x[0] == x0, x'[0] == v0}, x, {t, 0, 40}]

Here are some auxiliary functions that convert the differential equation obtained above into coordinates of the pendulum:
coord[t_, x0_: 1, v0_: 0, s_: 1] := coord[t, x0, v0, s] = x[t] /. sol[x0, v0, s][[1]];

rC[t_, {a_: 0, b_: 0}, R_: 1, x0_, v0_, s_] :=
rC[t, {a, b}, R, x0, v0, s] = {a, b} + R {Cos[coord[t, x0, v0, s] - Pi/2], Sin[coord[t, x0, v0, s] - Pi/2] + 1};

We now construct a function that transforms each of the points in a row in 2014, to a pendulum, which runs from a random position, with random initial velocity and suspended on a string of random length and has a random color:
 color := Hue[RandomReal[{0, 1/5}]];
 graphicsData[t_] =
  Table[{R, x0, v0, s} = {RandomInteger[{1, 10}],
     RandomReal[{-Pi, Pi}], RandomReal[{0, 1}], RandomReal[{0.2, 1}]};
   currentCoords = rC[t, points[[n]], R, x0, v0, s];
   {{LightGray, Thick, Line[{currentCoords, points[[n]] + {0, R}}]},
    {AbsolutePointSize[6], Gray, Point[points[[n]] + {0, R}], White,
     AbsolutePointSize[3], Point[points[[n]] + {0, R}]},
   AbsolutePointSize[15], color, Point[currentCoords]},
  {n, 1, lengthP}];

Finally ready to go greeting-manipulator 
Graphics[graphicsData[t], Background -> Lighter[Gray, 0.9],
  PlotRange -> {{-1, 30}, {0, 22}}, ImageSize -> 550],
  {{t, 0, "time"}, 0, 40, 1/48, AnimationRate -> 24, Appearance -> "Open"},
  SaveDefinitions -> True, FrameMargins -> 0]

POSTED BY: Vitaliy Kaurov
5 Replies
Happy New  Year!

That's entertaining!

For the record, one can get the points coordinates simply by:
points = PixelValuePositions[Binarize@Rasterize[string, "Image"], 0];
POSTED BY: Matthias Odisio
Luca, thank you for the kind words and missing piece of code - I added it to the post.
POSTED BY: Vitaliy Kaurov
Posted 11 years ago
Very nice!
I've tried it to understand its workings and learn something more about Mathematica language.
Anyway there a line missing:
lengthP = Length[points];
That's an interesting idea, Frank, but I am just a humble translator. My goal was to deliver Roman's original greeting as it is. But I will let Roman know your suggestion.
POSTED BY: Vitaliy Kaurov
Why didn't you use ParametricNDSolve?
POSTED BY: Frank Kampas
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
or Discard

Group Abstract Group Abstract