Happy theoretical 2014 from Russia!

Posted 10 years ago
18666 Views
|
5 Replies
|
16 Total Likes
|
 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 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]
5 Replies
Sort By:
Posted 10 years ago
 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 10 years ago
 Luca, thank you for the kind words and missing piece of code - I added it to the post.
Posted 10 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];Thanks
Posted 10 years ago
 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 10 years ago
 Why didn't you use ParametricNDSolve?