Tell me more ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.
up vote 28 down vote favorite
7

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.

  1. Animated process of construction from scratch, as it is described in Verbeia's blog post.
  2. Animated morphing of original pentagonal star to the current heptagonal one (J.M.'s idea in the comment)
  3. Some less fussy, a neutral animation of the logo itself, more suitable for placing on webpages.
share|improve this question
4  
I'd sure like to see somebody automagically morph a hyperbolic pentagon to a heptagon... – 0x4A4D♦ Oct 11 '12 at 1:53
@J.M. You mean something like a flash shape tween between the two? – VF1 Oct 13 '12 at 0:54
@VF1, yes, something like that... – 0x4A4D♦ Oct 13 '12 at 1:28
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 Nov 13 '12 at 16:15

8 Answers

up vote 21 down vote

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]
share|improve this answer
+1! Pure genius! – Ajasja Oct 25 '12 at 15:51
Excellent, +1 - although you've shown the official logo upside down :) – cormullion Oct 26 '12 at 12:02
@cormillion, fixed! In previous version it was pts2 = Range[2 Pi/7, 2 Pi, 2 Pi/7] // N. – faleichik Oct 26 '12 at 15:07
up vote 20 down vote

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
share|improve this answer
The only annoying issue is this polygon jumping. I think this is a numerical instability artefact in Rotate. – faleichik Oct 18 '12 at 11:26
Have you tried using RotationTransform instead? – Mr.Wizard♦ Oct 18 '12 at 12:24
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 – faleichik Oct 18 '12 at 12:46
up vote 19 down vote

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

share|improve this answer
The first one is my favorite so far. +1! – faleichik Oct 16 '12 at 22:22
Alternatively: f[c_] := 1 - Abs[1 - c] – 0x4A4D♦ Oct 20 '12 at 14:31
up vote 17 down vote

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@ "http://i.stack.imgur.com/VqjJ9.png","Byte"],"NB"]
share|improve this answer
4  
code or it didn't happen – Rojo Oct 17 '12 at 12:38
+1 for your code distribution method. – Mechanical snail Nov 15 '12 at 13:02
@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) – belisarius Nov 15 '12 at 17:06
up vote 16 down vote

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]

image

share|improve this answer
3  
nice! On the other hand I wouldn't want to have this amount of flickering on my webpage! – chris Oct 11 '12 at 6:51
@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. – VF1 Oct 11 '12 at 14:01
1  
aaah! Motion sickness! – drN Oct 14 '12 at 22:04
Good for the tip of a nerd's Christmas tree – Rojo Oct 17 '12 at 12:40
up vote 16 down vote

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[
   "http://i.stack.imgur.com/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]]

1

share|improve this answer
ahhahahahaha.... – Mr.Wizard♦ Oct 16 '12 at 4:28
"too silly...."! – cormullion Oct 16 '12 at 13:00
2  
Finally, something completely different! – István Zachar Oct 16 '12 at 14:19
1  
Ah, finally the foot. Where are the mints? – Yves Klett Oct 16 '12 at 20:21
up vote 15 down vote

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.

share|improve this answer
Cool! Perhaps it will look more spectacular with removed gray polygons. The holes will make this "more three-dimensional". – faleichik Oct 16 '12 at 22:26
and that is considerably harder – belisarius Oct 16 '12 at 22:32
@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♦ Oct 16 '12 at 22:49
OK, now I see why it is more involved than I thought. – faleichik Oct 16 '12 at 23:02
up vote 10 down vote

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

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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