0
$\begingroup$

How to make an animation of following fractal-like gif by using Mathematica?

enter image description here

$\endgroup$
15
$\begingroup$

Not as great as the original but should serve as a good starting point. The code should probably be self-explanatory...

(* parameters *)
innerradius = 20;
outerradius = 23;
numvertices = 12;
xrange = {-100, 100};
yrange = {-100, 100};
numframes = 150;
colour = Black;
finalangle = 720 Degree; (* must be a multiple of 360 Degree / numvertices *)
blurring = 10;
halfangleadjust = 14 / 10;

(* secondary stuff *)
middleradius = (outerradius + innerradius) / 2;
enlargementfactor = 2 outerradius / (outerradius - innerradius);
initialcenter = {0, -middleradius * enlargementfactor};
vertices = CirclePoints[
  initialcenter,
  {middleradius * enlargementfactor, 90 Degree},
  numvertices
];
annuli[innerrad_] := Annulus[#, {innerrad, outerradius}] & /@ vertices;

(* transformations *)
translationsteps = Table[{0, middleradius * enlargementfactor} x, {x, 0, 1, 1 / numframes}];
shrinkingsteps = Subdivide[1, 1/enlargementfactor, numframes];
rotationsteps = Table[finalangle * x^4, {x, 0, 1, 1 / numframes}];
ingrowthsteps = Table[innerradius * x^10, {x, 0, 1, 1 / numframes}];

(* faux motion blur *)
opacitysteps = Abs[Abs @ Subdivide[-1, 1, blurring] - 1];
halfanglesteps = Table[halfangleadjust (360 Degree / numvertices / 2) x^5, {x, 0, 1, 1 / numframes}];

(* construction *)
frames = Table[
  Module[
    {centre, innerrad, blurringsteps, composite},
    centre = TranslationTransform[translationsteps[[n]]] @ initialcenter;
    innerrad = innerradius - ingrowthsteps[[n]];
    blurringsteps = Subdivide[-halfanglesteps[[n]], halfanglesteps[[n]], blurring];
    composite = Composition[
      Rotate[#, -rotationsteps[[n]], centre] &,
      Scale[#, shrinkingsteps[[n]], centre] &,
      Translate[#, translationsteps[[n]]] &
    ] @ annuli[If[innerrad == 0, 1 / 1000, innerrad]];
    Graphics[
      {MapThread[{Opacity[#1, colour], Rotate[composite, #2, centre]} &, {opacitysteps, blurringsteps}]},
      Background -> GrayLevel[95 / 100],
      PlotRange -> {xrange, yrange}
    ]
  ],
  {n, 1, numframes + 1}
];

Then ListAnimate[frames] gives

Bees and Bombs

$\endgroup$
7
$\begingroup$

Here's something you can start with,

rinit = 6;
rfactor = 0.05;
rstep = .025;
npoints = Floor[(rinit - rfactor rinit)/rstep];
imglist = Table[
   With[{r = rinit - n rstep},
    Graphics[{Thickness[.03],
        Circle[#, rfactor r]} & /@

      CirclePoints[{0, -r + 2 (rinit - npoints rstep)}, {r, 
        2 π/npoints n}, 40.],
     ImageSize -> 300,
     PlotRange -> {{-1.1, 1.1}, {-1.1, 1.1}}]],
   {n, 0, npoints}];

Manipulate[imglist[[n]], {{n, 1}, 1, Length@imglist, 1}]

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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