How to produce a Calder mobile?

Question

Alexander Calder (1898 - 1976) was an American artist known for for his mobiles and his public sculptures.

Here are two examples of his mobiles which I want to approximately reproduce with Mathematica:

The second example has different colors:

We can use BSplineCurve to draw a Calder-like rounded shape:

gr = Graphics[BSplineCurve[{{0, 0}, {1, 0}, {2.5, 0.5}, {1, 0.5}, {0, 1}}, SplineClosed -> True]]

and this answer of kglr: How to draw a colored curved shape to fill it:

BoundaryDiscretizeGraphics[gr, MeshCellStyle -> {2 -> Darker @ Red}]

Maybe one could proceed with TreePlot, but with our rounded red shapes as VertexShapeFunction.

TreePlot[{1 -> 2, 2 -> 3, 3 -> 4, 4 -> 0, 5 -> 1, 6 -> 2, 7 -> 3, 8 -> 4, 9 -> 0},
 VertexShapeFunction -> "RoundedTriangle",
 VertexSize -> 0.2]

Or would it be easier to use Graphics- directives (slightly curved connected lines with randomized Calder-shapes)?

I don't know how to proceed and thank you in advance for any suggestions or, hopefully, a Calder-like solution.

Answer 1

With minor modifications of gr in OP:

ClearAll[randomLeaf]

randomLeaf  := Module[{tip = {RandomReal[{2, 5}], RandomReal[{-1/2, 0}]}}, 
  Graphics[
   BSplineCurve[{{0, 0}, {0, 0},  {1, -1/2}, tip, tip,
      {RandomReal[{1, 3}], RandomReal[{0, 1/3}]}, {0, 1/2}}, 
    SplineClosed -> True]]]


SeedRandom[1];

Row @ Table[Show[randomLeaf, ImageSize -> 200], 5]

We can use randomLeaf as custom arrowhead in a custom EdgeShapeFunction as follows:

ClearAll[calderESF]

calderESF[leaflist_, sizes_: {.05,.2},curvature_ : {-.2, .2}] := 
 {Arrowheads[{{If[MemberQ[leaflist, #2[[2]]], 
     RandomReal[sizes], 0], 1.,
     Show @ BoundaryDiscretizeGraphics[randomLeaf, 
       MeshCellStyle -> {2 -> RandomColor[]}]}}], 
   GraphComputation`GraphElementData["CurvedEdge", 
     "Curvature" -> RandomReal[curvature]][##]} &

Examples:

branches = 
  Map[Reverse]@{1 -> 2, 2 -> 3, 3 -> 4, 4 -> 0, 5 -> 1, 6 -> 2, 
    7 -> 3, 8 -> 4, 9 -> 0};

leaves = GraphComputation`SinkVertexList @ Graph @ branches;

SeedRandom[1];

Graph[branches, 
 PerformanceGoal -> "Quality", 
 EdgeShapeFunction -> calderESF[leaves],
 VertexSize -> 0,
 VertexShapeFunction -> None, 
 GraphLayout -> "LayeredDigraphEmbedding", 
 ImagePadding -> {{50, 50}, {100, 10}}]

SeedRandom[1];

branches2 = EdgeList@IndexGraph@RandomTree@20;

leaves2 = GraphComputation`SinkVertexList @ Graph @ branches2;

SeedRandom[444];

Graph[branches2, 
 PerformanceGoal -> "Quality", 
 EdgeShapeFunction -> calderESF[leaves2], 
 VertexSize -> 0,
 VertexShapeFunction -> None, 
 GraphLayout -> "LayeredDigraphEmbedding", 
 ImageSize -> 700, 
 ImagePadding -> {{220, 150}, {200, 10}}]

Replace "LayeredDigraphEmbedding" with "RadialEmbedding" and, ImagePadding -> ... with ImagePadding -> 200 to get

Answer 2

This answer is quite lacking, and there's a lot of improvements to be made. Maybe someone can improve on this however.

Using kirma's answer here (and modifying the parameters a little), we can get shapes (smoothed random polygons) that kind of look like Calder shapes.

We can then assign the VertexShapes to be these random smooth polygons:

SeedRandom[1234];
{minPolySides, maxPolySides} = {3, 6};
mobileStructure = {1 -> 2, 2 -> 3, 3 -> 4, 4 -> 0, 5 -> 1, 6 -> 2, 
   7 -> 3, 8 -> 4, 9 -> 0};
numberofThings = 10;

randomPolys = 
  Table[With[{coords = 
      Append[#, #[[1]]] &@
       RandomPolygon[{"Convex", 
          RandomInteger[{minPolySides, maxPolySides}]}][[1]]}, 
    With[{ip = 
       Interpolation[
        Transpose@{Rescale@
           Accumulate@
            Prepend[EuclideanDistance @@@ Partition[coords, 2, 1], 0],
           coords}, InterpolationOrder -> 1]}, 
     Graphics[{FaceForm@Red, 
       Polygon@Table[
         Mean@Table[ip[Mod[t + t0, 1]], {t0, 0, 0.3, .01}], {t, 0, 
          1., .01}]}]]], numberofThings];

vs = Thread[Range[0, numberofThings - 1] -> randomPolys];
TreePlot[mobileStructure,
 VertexShape -> vs, VertexSize -> 0.5, EdgeStyle -> Thick, 
 BaseStyle -> Black]

This is still missing some critical properties of your two examples though:

1. It looks like in your examples of Calder's mobiles, some tree vertices do not have a "shape" on them, and are instead just branching points for multiple shapes to hang off of.
2. The shapes are really not perfect still, I think I may have made them too smooth

Answer 3

Simple example that you can play with.

vf[{xc_, yc_}, name_, {w_, h_}] := 
 Module[{rr = RandomReal[{-1/4, 0}]}, 
  BoundaryDiscretizeGraphics[
   BSplineCurve[{xc, yc} + RotationMatrix[rr*\[Pi]] . # & /@ {{0, 
       0}, {RandomReal[{0.5, 1}], 
       RandomReal[{-1, 0}]}, {RandomReal[{1, 2}], 
       RandomReal[{-1, 0}]}, {RandomReal[{1, 2}], 
       RandomReal[{1, 0}]}, {RandomReal[{0.5, 1}], 
       RandomReal[{1, 0}]}, {0, 0}}], 
   MeshCellStyle -> {2 -> ColorData[97, RandomInteger[15]]}]]

ef[pts_List, e_] := 
 BSplineCurve[{pts[[1]], Mean[pts] + RandomReal[{-1, 1}, 2], pts[[2]]}]

Graph[{1 -> 2, 2 -> 3}, VertexCoordinates -> {{0, 0}, {0, 2}, {0, 4}},
  VertexShapeFunction -> 1 | 2 | 3 -> vf, 
 EdgeShapeFunction -> (# -> ef & /@ {1 -> 2, 2 -> 3})]