6
$\begingroup$

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:

enter image description here

The second example has different colors:

enter image description here

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

enter image description here

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]

enter image description here

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.

$\endgroup$
7
  • $\begingroup$ So I suppose you also want these mobiles to be "physically" correct? Namely, when they are suspended, the forces and torques are in balance? :) $\endgroup$
    – Domen
    Nov 2, 2023 at 10:20
  • $\begingroup$ Nope - I'm more interested in an aesthetically appealing image. $\endgroup$
    – eldo
    Nov 2, 2023 at 10:23
  • $\begingroup$ What is the meaning of "mobile" here? Any synonyms? $\endgroup$ Nov 2, 2023 at 11:29
  • $\begingroup$ @azerbajdzan From the Cambridge Dictionary: "mobile: a decoration or work of art that has many parts that move freely in the air, for example hanging from threads" $\endgroup$
    – flinty
    Nov 2, 2023 at 11:40
  • $\begingroup$ @flinty: Yes, also a kinetic sculpture as I found on en.wikipedia.org/wiki/Mobile_(sculpture). $\endgroup$ Nov 2, 2023 at 11:43

3 Answers 3

3
$\begingroup$

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]

enter image description here

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

enter image description here

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

enter image description here

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

enter image description here

$\endgroup$
3
$\begingroup$

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]

Mathematica graphics

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
$\endgroup$
1
  • $\begingroup$ +1 - it's much more than just a promising start :) $\endgroup$
    – eldo
    Nov 2, 2023 at 16:40
2
$\begingroup$

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

enter image description here

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.