Happy theoretical 2014 from Russia!

Ideas
, , , , ,
1

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.

gif_im_color_dither_16_e1cfeb94e9.gif

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]

s3v5gtbd43refdsv43refv.gif
s3v5gtbd43refdsv43refv.gif360×120 724 Bytes

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

Manipulate[
 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]

gif_im_color_dither_32_fc2e6ffb05.gif

14 Likes
2

Why didn’t you use ParametricNDSolve?

3

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.

4

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

Thanks

1 Like
5

Luca, thank you for the kind words and missing piece of code - I added it to the post.

6

Happy New Year!

That’s entertaining!

For the record, one can get the points coordinates simply by:

points = PixelValuePositions[Binarize@Rasterize[string, "Image"], 0];
1 Like