13
$\begingroup$

enter image description here
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]
}]
$\endgroup$
1
  • 1
    $\begingroup$ You can use Torus in Graphics3D. $\endgroup$ Mar 13 at 13:02

4 Answers 4

12
+100
$\begingroup$

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]

enter image description here

$\endgroup$
13
$\begingroup$

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 /. 
  x_Annulus :> {ConicGradientFilling[
     RandomChoice[ColorData[97, "ColorList"], nc]], x} // Graphics

enter image description here

enter image description here

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

enter image description here

$\endgroup$
1
  • $\begingroup$ +1 Very nice, Indeed! $\endgroup$ Mar 15 at 21:10
6
$\begingroup$

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=Visualization`Core`ParametricPlot[{r Cos[t],r Sin[t]},{t,0,2Pi},{r,r1,1},
  PlotPoints->90,Mesh->None,BoundaryStyle->None,Axes->False,Frame->False,
  PlotRangePadding->None,ImageSize->400{1,1},
  ColorFunction->(Blend[Thread[{{0,0.5,1},{#,Lighter[#,.8],#}&@Hue[#3]}],#4]&)
]//Rasterize;

level=5;
Graphics[{
  MapIndexed[{SurfaceAppearance["TextureShading",
  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}}}
]

enter image description here

$\endgroup$
5
$\begingroup$

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

enter image description here

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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