Animating mathematica.se logo

Question

As we all know our site's logo was completely generated by Mathematica. I suppose it is quite natural to make the next step -- to generate the animated version of this logo. There's a lot of space for creativity here, and I suggest to consider the following options.

Animated process of construction from scratch, as it is described in Verbeia's blog post.
Animated morphing of original pentagonal star to the current heptagonal one (J.M.'s idea in the comment)
Some less fussy, a neutral animation of the logo itself, more suitable for placing on webpages.

I'd sure like to see somebody automagically morph a hyperbolic pentagon to a heptagon... — J. M.'s missing motivation, Commented Oct 11, 2012 at 1:53
@J.M. You mean something like a flash shape tween between the two? — VF1, Commented Oct 13, 2012 at 0:54
If the intention is to change the static logo at the top of each mathematica.se page to a dynamic logo, please don't: it needlessly wastes a bit of bandwidth and, more significantly, distracts from the content. (As a programming exercise, that's another matter.) — murray, Commented Nov 13, 2012 at 16:15

faleichik · Accepted Answer · 2012-10-18 11:25:38Z

58

Let me join.

enter image description here

logo = Cases[
   p7 /. triangulate /. moretriangles /. shrink /. shrink /. shrink /. colour3[] /. colour4["SunsetColors", 1, 28/34] , {c__, Polygon[pts__]}, \[Infinity]];
logo = SortBy[logo, First];
p = Evaluate[InterpolatingPolynomial[{
     {0, {0, 0, 0, 0}}, {Pi, {Pi, 0, 0, 0, 0}}, {2 Pi, {2 Pi, 0, 0, 0}}},#]] &;
pp[a_] := If[Abs[a - Pi] < .6, Pi, p@a];(*to stabilize flickering*)
nf = 37;(*number of frames*)
frames = Table[
   Graphics[Thread[Rotate[logo, p@angle]],
    PlotRange -> 1.2, ImageSize -> 240
    ],
   {angle, 0, 2 Pi, (2 Pi)/(nf - 1)}];
ListAnimate@frames

answered Oct 18, 2012 at 11:25

faleichik

12.7k8 gold badges43 silver badges62 bronze badges

$\begingroup$ The only annoying issue is this polygon jumping. I think this is a numerical instability artefact in Rotate. $\endgroup$
– faleichik
Commented Oct 18, 2012 at 11:26
$\begingroup$ Have you tried using RotationTransform instead? $\endgroup$
– Mr.Wizard
Commented Oct 18, 2012 at 12:24
$\begingroup$ Not really, but I'm pretty sure that it won't help. This is possibly related to this problem: mathematica.stackexchange.com/q/9560/219 $\endgroup$
– faleichik
Commented Oct 18, 2012 at 12:46

Add a comment |

Dr. belisarius · Accepted Answer · 2012-11-13 03:09:58Z

53

Breathing with occluded borders, per Toad's request:

enter image description here

Run the following command to get the Mathematica code

NotebookPut@ImportString[Uncompress@FromCharacterCode@Flatten@ImageData[
               Import@ "https://i.sstatic.net/VqjJ9.png","Byte"],"NB"]

edited Nov 13, 2012 at 3:09

answered Oct 16, 2012 at 22:31

Dr. belisarius

116k13 gold badges204 silver badges454 bronze badges

4

$\begingroup$ code or it didn't happen $\endgroup$
– Rojo
Commented Oct 17, 2012 at 12:38
$\begingroup$ @Mechanicalsnail Here the upload code meta.mathematica.stackexchange.com/a/633/193 and here a palette meta.mathematica.stackexchange.com/q/771/193 (although this one seems to work only on some platforms) $\endgroup$
– Dr. belisarius
Commented Nov 15, 2012 at 17:06
$\begingroup$ To the future visitors who might face a problem running the code: see my comment here $\endgroup$
– polfosol
Commented Sep 8, 2021 at 7:52

Add a comment |

faleichik · Accepted Answer · 2012-10-26 15:05:53Z

43

Who wanted the automagic? :)

enter image description here

mmastar[as_, nn_: 1] := Graphics[
   Scale[#, 1/max@#, {0, 0}] &[
    Polygon[pt /@ as] /. triangulate /. moretriangles /. shrink /. 
          shrink /. shrink /. colour3[] /. colour4[] /. curve /. 
     bolicsn[nn]], AspectRatio -> Automatic, PlotRange -> 0.025];
da = 0.0001;
max[zu_] := 
  Cases[zu, {_?NumericQ, _?NumericQ}, \[Infinity]] // Norm // Max;
pt[a_] := {Sin@a, Cos@a};
pts0 = Range[ 0, (2 - 2/5) Pi, 2 Pi/5] // N
pts1 = Append[Insert[pts0, pts0[[2]] - da, 2], pts0[[-1]] + da]
pts2 = Range[Pi/7, 2 Pi, 2 Pi/7] // N
ptsat[t_] := (1 - t) pts1 + t pts2;
nn0 = 1; nn1 = 0.0001;
nat[t_] := (1 - t) nn0 + t nn1;
frames = Table[mmastar[ptsat[t], nat[t]], {t, 0, 1, 1/16}] // Reverse;
ListAnimate[frames]

edited Oct 26, 2012 at 15:05

answered Oct 25, 2012 at 15:34

faleichik

12.7k8 gold badges43 silver badges62 bronze badges

$\begingroup$ Excellent, +1 - although you've shown the official logo upside down :) $\endgroup$
– cormullion
Commented Oct 26, 2012 at 12:02
$\begingroup$ @cormillion, fixed! In previous version it was pts2 = Range[2 Pi/7, 2 Pi, 2 Pi/7] // N. $\endgroup$
– faleichik
Commented Oct 26, 2012 at 15:07

Add a comment |

wxffles · Accepted Answer · 2012-10-16 20:07:53Z

As per the blog:

Export["breathing.gif", Table[Graphics[
    p7 /. triangulate /. moretriangles /. shrink /. shrink /. shrink /. colour3[] /.
    colour4["SunsetColors", 1, 28/34] /. curve /. bolicsn[(1 - Cos[2 \[Pi] t])/2], 
  ImageSize -> 150], {t, 0, 1, 0.05}]];

breathing

Some good old fashioned colour cycling:

Clear[f];
f[c_] /; c > 2 := c - 2;
f[c_] /; c > 1 := 2 - c;
f[c_] := c;

colour4c[s_: "SunsetColors", a_?NumericQ, b_?NumericQ, c_?NumericQ] :=
  Polygon[v_] /; Length[v] == 4 :>
    {ColorData[s, f[c + a - b Norm[PolygonCentroid[v]]]], Polygon[v]}

Export["ColourCycleLogo.gif", Table[Graphics[
    p7 /. triangulate /. moretriangles /. shrink /. shrink /. shrink /. colour3[] /.
    colour4c["SunsetColors", 1, 28/34, t], 
  ImageSize -> 150], {t, 0, 2, 0.05}], "DisplayDurations" -> ConstantArray[0.05, 41]];

colours

$\begingroup$ The first one is my favorite so far. +1! $\endgroup$
– faleichik
Commented Oct 16, 2012 at 22:22 — faleichik, Commented Oct 16, 2012 at 22:22
$\begingroup$ Alternatively: f[c_] := 1 - Abs[1 - c] $\endgroup$
– J. M.'s missing motivation ♦
Commented Oct 20, 2012 at 14:31 — J. M.'s missing motivation, Commented Oct 20, 2012 at 14:31

Community · Accepted Answer · 2012-10-27 20:58:04Z

Load some images:

size = {200, 200};
foot = ImageResize[Import[
   "http://upload.wikimedia.org/wikipedia/commons/a/ab/Monty_python_foot.png"
  ], size];
spikey = ImageResize[Import[
   "http://upload.wikimedia.org/wikipedia/en/b/bf/MathematicaSpikeyVersion8.png"
  ], size];
mse = ImageResize[Import[
   "https://i.sstatic.net/yjrEY.png"
  ], size];

Crop them, squash them, transform them:

feet = Table[ImageCrop[foot, size {1, k}, Top], {k, 0.1, 0.9, 0.1}];
spoke = Table[ImageResize[spikey, size {1, k}], {k, 0.9, 0.1, -0.1}];
logos = Table[ImagePerspectiveTransformation[mse, 
  FindGeometricTransform[{{0, 0}, {1, 0},
    {0.5, 0.5} + {-(1/(-2 - 2 Cos[t])), (-4 - 3 Cos[t] + 8 Sin[t])/(8 + 8 Cos[t])},
    {0.5, 0.5} + {1/(-2 - 2 Cos[t]), (-4 - 3 Cos[t] + 8 Sin[t])/(8 + 8 Cos[t])}},
    {{0, 0}, {1, 0}, {1, 1}, {0, 1}}][[2]], Padding -> White], {t, 0, \[Pi]/2, \[Pi]/40}];
squish = Table[ImageCrop[logos[[1]], size {1, k}, Top], {k, 0.1, 0.9, 0.1}];

Assemble them together:

a = ImageAssemble[List /@ #] & /@ Thread[{feet, spoke}];
b = ImageAssemble[List /@ #] & /@ Thread[{Reverse@feet, squish}];
c = logos;
d = ConstantArray[Last@logos, 5];

Animate:

Export["logoanimate.gif", Join[a, b, c, d]]

$\begingroup$ ahhahahahaha.... $\endgroup$
– Mr.Wizard
Commented Oct 16, 2012 at 4:28 — Mr.Wizard, Commented Oct 16, 2012 at 4:28
$\begingroup$ "too silly...."! $\endgroup$
– cormullion
Commented Oct 16, 2012 at 13:00 — cormullion, Commented Oct 16, 2012 at 13:00
$\begingroup$ Finally, something completely different! $\endgroup$
– István Zachar
Commented Oct 16, 2012 at 14:19 — István Zachar, Commented Oct 16, 2012 at 14:19
$\begingroup$ Ah, finally the foot. Where are the mints? $\endgroup$
– Yves Klett
Commented Oct 16, 2012 at 20:21 — Yves Klett, Commented Oct 16, 2012 at 20:21

rm -rf · Accepted Answer · 2012-10-16 21:14:06Z

Here's a spinning "3D version" of the logo

enter image description here

Using the code from meta/blog to create the logo (assigned to the variable logo), continue with the following steps:

side[o_] := Block[{z, pts = Partition[
    Table[N[{Cos[t], Sin[t], z}], {t, Pi/14, 2 Pi, 2 Pi/7}], 2, 1, 1]},
    Composition[Polygon, Flatten[#, 1] &] /@ Thread[{pts /. z -> o/2, Reverse /@ pts /. z -> -o/2}]
]

logo3D = With[{d = 0.1}, 
    Graphics3D[{
        {EdgeForm@None, #}, 
        {EdgeForm@None, FaceForm@RGBColor[0.5995136280878135`, 0.20347121886943803`, 0.37787606421753417`], side@d}
        }, Boxed -> False, Lighting -> "Neutral"
    ] & @@ (logo /. Polygon[x__] :> Polygon[{x /. {a_, b_} :> {a, b, d/2}, 
        x /. {a_, b_} :> {a, b, -d/2}}])
]

frames = Table[Graphics3D[
        {Rotate[First@logo3D, x, {0, 1, 0}]},
        Lighting -> "Neutral",
        ViewAngle -> 35 Degree, ViewVector -> {0, 0, 3.5},
        ViewCenter -> {1, 1, 1}/2, ViewRange -> All, ViewVertical -> {0, 1, 0},
        Axes -> False, Boxed -> False, ImageSize -> 400
    ], {x, 0, 2 Pi, Pi/20}
];

Export["spin.gif", frames, "DisplayDurations" -> 0.05];

A "true 3D version" of the logo would involve raised and beveled profiles for the various inner decorations, but that's considerably harder.

Cool! Perhaps it will look more spectacular with removed gray polygons. The holes will make this "more three-dimensional". — faleichik, Commented Oct 16, 2012 at 22:26
@faleichik I agree, and not just that, one would also need to bevel the various polygons "nicely" to give it depth and structure. As I mentioned in the last line, it's a much harder problem :) — rm -rf, Commented Oct 16, 2012 at 22:49

VF1 · Accepted Answer · 2012-10-11 01:44:50Z

26

A very rough interpretation, which I hope might at least give some ideas:

(* Final image *)
fin = (p7 /. triangulate /. moretriangles /. shrink
      /. shrink /. shrink /. colour3[] /. colour4["SunsetColors", 1, 28/34]);
icycle[ j_, k_] := 
      Table[Graphics[fin[[1 ;; i, j, k]], PlotRange -> 1], {i, 7}] 
kcycle[i_, j_] := 
      Table[Graphics[fin[[i, j, 1 ;; k]], PlotRange -> 1], {k, 4}]
raster = Rasterize/@
    Prepend[Drop[
       Module[{c}, 
        Flatten@
         {Table[(c = icycle[1, 1 ;; m])~Join~Reverse[c], {m, 4}], 
          Table[(c = kcycle[1 ;; 7, 1 ;; m])~Join~Reverse[c], {m, 4}]}], -4],
   Graphics[{White, Rectangle[]}]];
Export["logo.gif", raster]

answered Oct 11, 2012 at 1:44

VF1

4,74224 silver badges31 bronze badges

4

$\begingroup$ nice! On the other hand I wouldn't want to have this amount of flickering on my webpage! $\endgroup$
– chris
Commented Oct 11, 2012 at 6:51
$\begingroup$ @chris thanks. I was just having fun with this, and this is the end result. I'd love to play with it some more though and maybe get something smother if I have time. $\endgroup$
– VF1
Commented Oct 11, 2012 at 14:01
1

$\begingroup$ aaah! Motion sickness! $\endgroup$
– dearN
Commented Oct 14, 2012 at 22:04
$\begingroup$ Good for the tip of a nerd's Christmas tree $\endgroup$
– Rojo
Commented Oct 17, 2012 at 12:40

Add a comment |

bill s · Accepted Answer · 2014-01-15 03:08:15Z

Somewhat belatedly, here is a version that starts from random points and slowly coalesces into the logo.

Begin with the logo from the blog entry which is here called img, and apply a jitter filter which randomizes the position of each pixel within a region of specified size. By starting with a large region (100 pixels by 100 pixels) and shrinking down to 1 by 1, the image changes from a point cloud into a geometric object.

video = Table[
   ImageFilter[RandomChoice[Flatten[#, 1]] &, img, i, Interleaving -> True], 
     {i, {100, 90, 80, 70, 60, 50, 40, 30, 25, 20, 15, 10, 9, 8, 7, 6, 5, 4, 3, 2, 1}}];

enter image description here

cormullion · Accepted Answer · 2012-10-16 12:58:29Z

18

Not very interesting, but I learnt a few things...

tab = Table[Show[
    Graphics[Rectangle[{-1, -1}, {1, 1}]],
    i (* where i is the final graphic produced by Verbeia's blog post *)  
     /. 
     {GrayLevel[0.85] -> Opacity[0],
      Polygon[{a_, b_, c_, d_}] -> 
       {
        Scale[Rotate[Polygon[{a, b, c, d}], 2 Pi t, {0, 0}], t, {0, 0}]
       }
      }
    ],
   {t, 0, 1, 0.02}]; 

Export["stack-logo.gif", Flatten[Join[tab, Reverse[tab]]]]

stack overrun

answered Oct 16, 2012 at 12:58

cormullion

24.3k4 gold badges64 silver badges134 bronze badges

Add a comment |

Stack Exchange Network

Animating mathematica.se logo

9 Answers 9

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

Linked

Hot Network Questions

Animating mathematica.se logo

9 Answers 9

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

Linked

Related

Hot Network Questions

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