The figure is
See the how-to video or a speeded-up GIF.
I believe it should be possible to draw this figure programmatically using some Random
function, but I'm rather new to Mathematica, so I could really use some help here.
Mathematica Stack Exchange is a question and answer site for users of Wolfram Mathematica. It only takes a minute to sign up.
Sign up to join this communityThe figure is
See the how-to video or a speeded-up GIF.
I believe it should be possible to draw this figure programmatically using some Random
function, but I'm rather new to Mathematica, so I could really use some help here.
Here's a quick take on it:
Clear[spiralize];
spiralize[p_, d_:10, r_:4, f_:0.8, s_:1, t_:0.005]:=Module[{m,rr=r},
m = Mean @ p[[1]];
Graphics[{EdgeForm[Thickness[t]],FaceForm[White],
NestList[GeometricTransformation[
GeometricTransformation[#,
RotationTransform[rr++s \[Degree],m]],
ScalingTransform[{f,f},m]
]&, p, d]}
]
]
pts = RandomReal[{-1, 1}, {50, 2}];
polys = MeshPrimitives[VoronoiMesh[pts], 2];
Show[spiralize[#, 40, 5, 0.85] & /@ polys]
Play with the parameters:
pts = RandomReal[{-1, 1}, {10, 2}];
polys = MeshPrimitives[VoronoiMesh[pts], 2];
Manipulate[
Show[spiralize[#, d, r, f, s, t] & /@ polys], {{d, 10}, 1, 20,
1}, {{r, 5}, 1, 20}, {{f, 0.85}, 0, 1}, {{s, 1}, 0.1,
3}, {{t, 0.001}, 0, 0.01}]
voronoi[pts_] := ListDensityPlot[Append[#, 0]&/@ pts, InterpolationOrder-> 0,
Frame -> False]
pts = RandomReal[{0, 256}, {20, 2}];
cp = Cases[Normal@voronoi[pts], Polygon[a_, ___] :> Polygon[a], ∞];
cp1 = cp /. Polygon[a___] :> a;
ms = Mean /@ cp1;
Graphics[{EdgeForm[Black], FaceForm[White], cp,
Line /@ Join @@@ (Transpose /@ (MapThread[
Table[BSplineFunction[Join[Join[#1, #1][[i ;; i + 1]], #2]][t],
{i, 1, Length@#1}] &, {cp1, List /@ ms}, 1] /.
a_[t] :> a /@ Range[0, 1, .03]))}]
20
in pts = RandomReal[{0, 256}, {20, 2}];
is the number of spirals. The spacing is determined by Range[0, 1, .03]
,so you may try things like (Rescale[Sin[# ^(2)] & /@ Range[0.001, 1, .05]])
instead
$\endgroup$
Mar 23, 2016 at 22:52
Here is a slightly different way of going about it:
BlockRandom[SeedRandom[42, Method -> "Rule30CA"]; (* for reproducibility *)
pts = RandomReal[{-1, 1}, {50, 2}]];
With[{h = 1/5 (* offset *), n = 30 (* iterations *)},
Graphics[{FaceForm[], EdgeForm[AbsoluteThickness[1/5]],
NestList[# /. Polygon[p_] :>
Polygon[Transpose[Partition[p, 2, 1, 1], {1, 3, 2}].
{1 - h, h}] &,
MeshPrimitives[VoronoiMesh[pts], 2], n]}]]
This version incorporates Rahul's suggestion to randomize the rotation directions:
With[{h = 1/5 (* offset *), n = 30 (* iterations *)},
BlockRandom[SeedRandom[42, Method -> "Rule30CA"]; (* for reproducibility *)
pts = RandomReal[{-1, 1}, {50, 2}];
Graphics[{FaceForm[], EdgeForm[AbsoluteThickness[1/5]],
NestList[# /. Polygon[p_] :>
Polygon[Transpose[Partition[p, 2, 1, 1], {1, 3, 2}].
{1 - h, h}] &,
Map[RandomChoice[{Identity, Reverse}][#] &,
MeshPrimitives[VoronoiMesh[pts], 2], {2}], n]}]]]
After seeing your awesome contributions I really wanted to do it myself, and I'm pretty happy with the result:
It took me quite a bit of time because I'm very rusty when it comes to progamming. Also, the code is probably highly inefficient, so any suggestion will be very appreciated.
The main idea to genetare this is to first draw some random quadrilaterals:
ClearAll["Global`*"]
a = .25; (*side length*)
c:=.15 RandomReal[{-1, 1}]; (*random shifting*)
d = .15;
n = 3; (*n+1 rectangles in the x direc.*)
m = 2; (*m+1 rectangles in the y direc.*)
s = NestList[{#[[2]],#[[2]]+{a+c,0},#[[2]]+{a+c,a+c},#[[3]],#[[2]]} &,{{0,0},{a+c,0},{a+c,a+c},{0,a+c},{0,0}},n];
AppendTo[s,{#[[2]],#[[2]]+{a,0},#[[2]]+{a,a},#[[3]],#[[2]]}&[Last[s]]];
f[x_] := Module[{k=FoldList[{#1[[2]],#2[[3]],#2[[3]]+{c,a+c},#1[[3]],#1[[2]]}&,{#[[4]],#[[3]],#[[3]]+{c,a+c},#[[4]]+{c,a+c},#[[4]]}&[x[[1]]],Rest@x]},
k[[1,4,1]]=0;
k[[n+2,3,1]]=x[[-1,2,1]];
k];
q = NestList[f,s,m];
Table[q[[-1,j,3,2]]=q[[-1,j,4,2]]=(m+1)a,{j,1,n+2}];
q = Partition[#,2]&/@Partition[Flatten[q],10];
ListPlot[q,Joined->True,Axes->False]
The, I randomly turn some of these quadrilaterals into triangles:
Table[q=ReplacePart[q,i->Sequence@@{q[[i]][[{1,2,3,1}]],q[[i]][[{3,4,1,3}]]}];
,{i,RandomSample[Range[Length[q]],Floor[(n+1)(m+1)/3]]}];
Table[q=ReplacePart[q,i->Sequence@@{q[[i]][[{1,2,4,1}]],q[[i]][[{2,3,4,2}]]}];
,{i,RandomSample[Range[Length[q]],Floor[(n+1)(m+1)/3]]}];
And finally, I generate the spirals inside each polygon:
g[x_]:=Fold[Append[#1,BSplineFunction[#1[[#2]],SplineDegree->1][d]]&,x,Partition[Range[150],2,1]]
ListPlot[g/@q,Joined->True,Axes->False,PlotStyle->Black,ImageSize->Large]
This approach has many flaws compared to the other answers but the most important one is that one has to execute the code many times to get a decent result (because most of the times the polygons overlap).