# Reproduce the annulus fractal

I've made some attempts, but I don't know how to set the color and thickness of the circle.

Graphics[{
NestList[#/.Circle[{x_,y_},R_]->With[{r=1/2R},
Append[Table[Circle[{x,y}+(R+r)/2 {Cos@#,Sin@#},(R-r)/2]&[2k Pi/4],{k,0,3}],
Circle[{x,y},r]]]&,Circle[{0,0},1],4]
}]

• You can use Torus in Graphics3D. Mar 13 at 13:02

First, a variation on @azerbajdzan's approach to subdivide an annulus:

ClearAll[step]
step = ReplaceAll[Annulus[c_, r_] :> With[{rr = r + Subtract @@ r}, Flatten @
{an[c, r], Annulus[c, rr/2],
Annulus[c + r[[1]] #, rr/4] & /@
{{0, 3/4}, {0, -3/4}, {3/4, 0}, {-3/4, 0}}}]];


Next, a function to re-render an annulus using ParametricPlot:

ClearAll[annulusToPP]
annulusToPP[Annulus[c_, r_]] := First @
ParametricPlot[{s  Cos[θ], s  Sin[θ]} + c,
{θ, 0, 2 π}, {s, r[[1]], r[[2]]},
BoundaryStyle -> None,
MeshFunctions -> {#4 &}, Mesh -> {r},
ColorFunction -> (Blend[
Thread[{{r[[1]], Mean@r, r[[2]]}, {#, Lighter[#, .95], #} &@
Hue[#3/2/Pi]}], #4] &),
ColorFunctionScaling -> False]

Graphics[
Nest[step, Annulus[{0, 0}, {1, 1.15}], 3] /. an -> Annulus /.
a_Annulus :> annulusToPP[a], ImageSize -> Large]


There is some bug in ConicGradientFilling if more than 2 colors are used. (see line at right of each annulus)

Bellow are images with number of colors in gradient nc=2 and nc=6.

rule = Annulus[{x_, y_}, {a_, b_}] ->
Sequence @@ {an[{x, y}, {a, b}],
Annulus[{x, y}, ({a, b} - (b - a))/2],
Annulus[{x - 3/4*a, y}, ({a, b} - (b - a))/4],
Annulus[{x + 3/4*a, y}, ({a, b} - (b - a))/4],
Annulus[{x, y - 3/4*a}, ({a, b} - (b - a))/4],
Annulus[{x, y + 3/4*a}, ({a, b} - (b - a))/4]};
nc = 6;

Nest[# /. rule &, {Annulus[{0, 0}, {1, 1.1}]}, 5] /. an -> Annulus /.
RandomChoice[ColorData[97, "ColorList"], nc]], x} // Graphics


With Graphics[#, Background -> Black] & colors are maybe more perceptible.

• +1 Very nice, Indeed! Mar 15 at 21:10

Inspired by @kglr, this is a faster version

Clear["*"];
r1=0.9; s=1/2; n=4;
step=GeometricTransformation[#,Append[Table[AffineTransform[{(1-s)/2 {{r1,0},{0,r1}},
r1 (1+s)/2 {Cos@#,Sin@#}&[2k Pi/n ]}],{k,0,n-1}],ScalingTransform[s r1{1,1}]]]&;

img=VisualizationCoreParametricPlot[{r Cos[t],r Sin[t]},{t,0,2Pi},{r,r1,1},
PlotPoints->90,Mesh->None,BoundaryStyle->None,Axes->False,Frame->False,
]//Rasterize;

level=5;
Graphics[{
Texture@Darker[img,Rescale[Tr@#2,{1,level},{0,0.6}]]],#}&,
NestList[step,Annulus[{0,0},{r1,1}],level-1]]
},ImageSize->Large,Background->Black,
BaseStyle->{FilledCurveBoxOptions->{Method->{"SplinePoints"->60}}}
]


# In 3D

ClearAll[r];
r [{x_,y_,z_,r1_,r2_}]:={
{x , y,z,r1/2,r2},
{x - 3/4*r1, y,z,r1/4,r2},
{x+ 3/4*r1, y,z,r1/4,r2},
{x,y- 3/4*r1,z,r1/4,r2},
{x,y+ 3/4*r1,z,r1/4,r2}
}

ClearAll[t];
t[{x_,y_,z_,r1_,r2_}]:=Torus[{x,y,z},{r1-r2,r1+r2}]

Graphics3D@Flatten@Map[
t
, NestList[Map[r,#, {-2}]&,{0,0,0,1,0.01},4]
, {-2}
]
`