$3D$ graphic of soccer ball

Here's my attempt at a soccer/foot ball, updated with an improved surface model:

Mathematica graphics

First create the patches (code below):

pl /@ {5, 6}

Mathematica graphics

Then stitch them together using FindGeometricTransform to help with the work.

The patches are made using NDSolve and simple PDE over a polygonal region. (Pretty cool, I thought.)

Then they have to be sized and "inflated" (i.e., the underlying element mesh is projected onto the sphere). There's some elementary geometry involved in that. The PDE surface represents the leather patch over the region, and the solution ends up being added to the height of the inflated element-mesh domain.

(* coverings of the patches of n = 5, 6 sides *)
Clear[sol];
sol[n_] := sol[n] = NDSolve[
   {Laplacian[u[x, y], {x, y}] - 400 u[x, y] == -20, (* can adjust coefficients *)
    DirichletCondition[u[x, y] == 0, True]},
   u,
   {x, y} ∈ Polygon@CirclePoints[n],
   Method -> {"FiniteElement", "MeshOptions" -> {MaxCellMeasure -> 0.001}}
   ]

(* circumradius of a CirclePoints[n] facet *)
crad[n_] := 2 Sin[π/n] PolyhedronData["TruncatedIcosahedron", "Circumradius"];

(* plots of the patches of n = 5, 6 sides *)
plotcolor[5] = Black;
plotcolor[6] = White;
Clear[pl];
pl[n_] := 
 pl[n] = ParametricPlot3D[
   crad[n] Normalize@{x, y, N@Sqrt[crad[n]^2 - 1]} + 
       {0, 0, u[x, y] - Sqrt[crad[n]^2 - 1]} /. sol[n] // Evaluate,
   {x, y} ∈ (u["ElementMesh"] /. First@sol[n]),
   Mesh -> None, 
   PlotStyle -> Directive[Specularity[White, 100], plotcolor[n]], 
   PlotRange -> 1, BoxRatios -> {1, 1, 1}, Lighting -> "Neutral"];

Graphics3D[
 MapThread[
  GeometricTransformation,
  {First /@ pl /@ {5, 6},
   Flatten /@ Last@Reap[
      Sow[
          Last@FindGeometricTransform[#, 
            PadRight[CirclePoints[Length@#], {Automatic, 3}], 
            Method -> "Linear"], Length@#]; & /@ 
       Cases[Normal@PolyhedronData["TruncatedIcosahedron"], 
        Polygon[p_] :> p, Infinity],
      {5, 6}]}
  ]]

(* picture shown above *)

There were gaps due to a stupid error in crad[], which are now fixed..


Update (new: gaps removed)

With DirichletCondition[u[x, y] == 0.01 Sin[60 ArcTan[x, y]], True], you get stitches!

Mathematica graphics

To remove the little gaps that result, I had to construct an element mesh whose points would line up when the patches are assembled and alter the expression plotted by pl[].

emesh[n_] :=
  With[{pts = 4 * 60},   (* 60 corresponds to the BC in sol below.
                            4 is the oversampling; 8 gives slightly better quality *) 
  ToElementMesh@ToBoundaryMesh[
    "Coordinates" -> With[{r = Cos[Pi/n] Sec[Mod[t + Pi/2, 2 Pi/n, -Pi/n]]},
       Most@Table[r {Cos[t], Sin[t]}, {t, 0, 2 Pi, 2 Pi/pts}]],
    "BoundaryElements" -> {LineElement[Partition[Range@pts, 2, 1, 1]]}
    ]
  ];

Clear[sol];
sol[n_] := sol[n] = NDSolve[
   {Laplacian[u[x, y], {x, y}] - 400 u[x, y] == -20, 
    DirichletCondition[u[x, y] == 0.01 Sin[60 ArcTan[x, y]], True]},
   u,
   {x, y} ∈ emesh[n]
   ];

And if in pl[] we plot

crad[n] (1 + u[x, y]) Normalize@{x, y, N@Sqrt[crad[n]^2 - 1]} -
  {0, 0, Sqrt[crad[n]^2 - 1]} /. First@sol[n]

then we get no gaps (although I get an extrapolation warning, it seems to be right next to the boundary). In a sense, this seems a better expression to plot anyway.


I am not sufficiently skilled to be able to fake the ridges along each polygon, so here is my modest attempt:

arc[center_?VectorQ, {start_?VectorQ, end_?VectorQ}] := Module[{ang, co, r},
    ang = VectorAngle[start - center, end - center];
    co = Cos[ang/2]; r = EuclideanDistance[center, start];
    BSplineCurve[{start, center + r/co Normalize[(start + end)/2 - center], end}, 
                 SplineDegree -> 2, SplineKnots -> {0, 0, 0, 1, 1, 1},
                 SplineWeights -> {1, co, 1}]]

With[{r = PolyhedronData["TruncatedIcosahedron", "Circumradius"]}, 
     Graphics3D[{EdgeForm[],
                 Normal @ N[PolyhedronData["TruncatedIcosahedron", "Faces"]] /. 
                 p : Polygon[l_] :> {If[Length[l] == 5, Black, White], 
                                     GraphicsComplex[r (Normalize /@ MeshCoordinates[#]),
                                                     MeshCells[#, 2]] & @
                                     DiscretizeRegion[p, MaxCellMeasure ->
                                                      {"Area" -> 0.01}]}, 
                 ColorData["Legacy", "Ivory"], 
                 Normal @ N[PolyhedronData["TruncatedIcosahedron", "Edges"]] /. 
                 Line[l_] :> Tube[arc[{0, 0, 0}, l], 1/50]},
                Boxed -> False, Lighting -> "Neutral"]]

fake soccer ball


Michael's beautiful solution has forced me to up the ante a bit. I had some difficulties coming up with a "puffed" version, and here is what I ended up with:

With[{r = PolyhedronData["TruncatedIcosahedron", "Circumradius"], 
      h = 1/10, s = 1/10 (* controls degree of puffing *)}, 
     Graphics3D[{{Directive[EdgeForm[], Specularity[0.9, 90.]], 
                  Normal @ N[PolyhedronData["TruncatedIcosahedron", "Faces"]] /. 
                  p : Polygon[l_] :> {GrayLevel[Boole[Length[l] != 5]], 
                  GraphicsComplex[(With[{dd = Clip[2 EuclideanDistance[#, Mean[l]]
                                                   Tan[π/Length[l]], {0, 1}]},
                                        (h + r + dd^2 ((2 dd - 3) h - (dd - 1) s))
                                        Normalize[#]] & /@ 
                                  MeshCoordinates[#]), MeshCells[#, 2]] & @
                  DiscretizeRegion[p, MaxCellMeasure -> {"Length" -> 0.05}]}},
                 {ColorData["Legacy", "Ivory"], 
                  Normal @ N[PolyhedronData["TruncatedIcosahedron", "Edges"]] /. 
                  Line[l_] :> Tube[arc[{0, 0, 0}, l], 0.01]}},
                Boxed -> False, Lighting -> "Neutral"]]

"puffed" fake soccer ball


Below I'll use @J.M. convenient arc function from his answer to this question:

Clear[arc]
arc[center_?VectorQ, {start_?VectorQ, end_?VectorQ}] := 
 Module[{ang, co, r}, ang = VectorAngle[start - center, end - center];
  co = Cos[ang/2]; r = EuclideanDistance[center, start];
  BSplineCurve[{start, center + r/co Normalize[(start + end)/2 - center], end}, 
   SplineDegree -> 2, SplineKnots -> {0, 0, 0, 1, 1, 1}, 
   SplineWeights -> {1, co, 1}]]

This allows me to easily generate curved arcs in 3D given a center and the two endpoints.

We can then get the coordinates and connectivity of the edges of your polyhedron directly from PolyhedronData. Those are returned as a GraphicsComplex, which I transform into a normal Graphics3D object, then replace Line with appropriate arc expressions:

curvedEdges = ReplaceAll[
    Normal@PolyhedronData["TruncatedIcosahedron", "Edges"],
    Line[coords_] :> arc[{0, 0, 0}, coords]
  ];

... and plot the results:

Graphics3D[
  {
   Opacity[0.7], White, PolyhedronData["TruncatedIcosahedron", "Circumsphere"],
   Thick, Darker@Green, curvedEdges
  }, 
  Lighting -> "Neutral", Boxed -> False
]

Mathematica graphics

Tags:

Graphics3D