64
$\begingroup$

The figure is

the figure

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.

$\endgroup$
  • 1
    $\begingroup$ This is related. $\endgroup$ – J. M. is away Mar 24 '16 at 0:22
  • $\begingroup$ Fun question. I still can't get over people spend their free time trying to draw things like this. $\endgroup$ – William Mar 24 '16 at 3:00
  • 6
    $\begingroup$ @William, they spend the time because it is, as you say, fun. $\endgroup$ – J. M. is away Mar 24 '16 at 3:15
  • $\begingroup$ Those are art forms. Mathematica can make a stunning variety of them. Over the past year I have been using Mathematica to design geometric sculptures. Part of the process is looking for attractive 3D graphics which are made up of elements that I can put together in the real world. I recently saw an unanticipated Graphics3D result that I have been able to make in solid form. The result has energetic beauty. $\endgroup$ – Ralph Dratman Mar 29 '16 at 21:04
92
$\begingroup$

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]

enter image description here

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

enter image description here

$\endgroup$
  • 1
    $\begingroup$ wow really cool :) thank you! is there any parameter I can play with to get different results? $\endgroup$ – AccidentalFourierTransform Mar 23 '16 at 22:44
  • $\begingroup$ Yes, try changing the scaling and rotating arguments in the function. $\endgroup$ – M.R. Mar 23 '16 at 23:46
42
$\begingroup$
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]))}]

Mathematica graphics

$\endgroup$
  • $\begingroup$ an arc length parametrization would be better $\endgroup$ – Dr. belisarius Mar 23 '16 at 22:32
  • 1
    $\begingroup$ it looks really nice :) thank you! what parameters could I change to get different results? (such as more/less spirals) $\endgroup$ – AccidentalFourierTransform Mar 23 '16 at 22:46
  • $\begingroup$ @AccidentalFourierTransform The 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$ – Dr. belisarius Mar 23 '16 at 22:52
33
$\begingroup$

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

whirls all around


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

spinning here or there

$\endgroup$
  • $\begingroup$ Maybe it's just a matter of perception, but I like this the best. I think (could be wrong), that the other answers have the lines simply spiraling into the center of the mesh cell, whereas they ought to hit the boundary before turning and heading to the next edge. +1 $\endgroup$ – LLlAMnYP Mar 24 '16 at 8:19
  • $\begingroup$ Very perceptive of you! :) That's why I used linear interpolation over each polygon edge instead of scaling + rotating; that other approach will inevitably have corners jutting out of the spiral for some irregular polygons. $\endgroup$ – J. M. is away Mar 24 '16 at 8:22
  • $\begingroup$ I wonder if it would be possible to make the edges of the Voronoi mesh less visible. In the original image the polygon edges are barely noticeable because the lines on either side start have a very uniform density, whereas here those edges are quite pronounced. $\endgroup$ – Martin Ender Mar 24 '16 at 9:07
  • $\begingroup$ @Martin, the other thing contributing to that illusion is that the polygons were not all rotated in the same direction. That I think takes more work to do. $\endgroup$ – J. M. is away Mar 24 '16 at 9:14
  • $\begingroup$ @J.M. Oh, I just noticed that this solution doesn't do that yet. Yeah, that definitely helps with the uniform density, but I think even when the direction on two adjacent polygons is the same, is looks a bit more homogeneous. I'm not entirely sure how to go about that though... I'll see if I come up with anything. $\endgroup$ – Martin Ender Mar 24 '16 at 9:18
12
$\begingroup$

After seeing your awesome contributions I really wanted to do it myself, and I'm pretty happy with the result:

enter image description here

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]

enter image description here

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

enter image description here

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).

$\endgroup$
  • 1
    $\begingroup$ They are just quadrilaterals, not rectangles. :) (A rectangle is a parallelogram with a right angle.) $\endgroup$ – J. M. is away Apr 1 '16 at 13:43

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.