Make a fractal-like dot animation

Question

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

Answer 1

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

Answer 2

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