34
$\begingroup$

How to make a soccer ball $3D$ graphic?

The following image is from Wikipedia, Spherical polyhedron:

soccer ball

Truncated icosahedron (left) and standard soccer ball (right)

PolyhedronData["TruncatedIcosahedron"]

How do I make an orthographic projection of the truncated icosahedron on the sphere?

How do I show the net of a ball in $3D$ like this:

PolyhedronData["TruncatedIcosahedron", "NetImage"]

a net

$\endgroup$
0

5 Answers 5

45
$\begingroup$

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.

$\endgroup$
9
  • 2
    $\begingroup$ Nice! A note: Norm /@ PolyhedronData["TruncatedIcosahedron", "VertexCoordinates"] // First can just be PolyhedronData["TruncatedIcosahedron", "Circumradius"], and Norm /@ Differences@CirclePoints[n] // First is just 2 Sin[π/n], so crad[n_] := PolyhedronData["TruncatedIcosahedron", "Circumradius"] Csc[π/n]/2 $\endgroup$ Commented Jun 18, 2016 at 1:24
  • $\begingroup$ @J.M. Thanks. I look at the list of "Properties", and when I try them, most of them don't work. It just feels easier to compute everything. $\endgroup$
    – Michael E2
    Commented Jun 18, 2016 at 1:57
  • $\begingroup$ wow, nice! It IS a soccer! $\endgroup$
    – Wjx
    Commented Jun 18, 2016 at 1:59
  • 2
    $\begingroup$ @MichaelE2 This is impressive! $\endgroup$
    – MarcoB
    Commented Jun 18, 2016 at 13:32
  • 2
    $\begingroup$ @J.M. Thanks! I think I'm done now. The only thing left is to stamp it with the MSE logo. ;-) $\endgroup$
    – Michael E2
    Commented Jun 19, 2016 at 1:35
27
$\begingroup$

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

$\endgroup$
2
  • $\begingroup$ Very pretty! It's only fair that you get to use your own function after all :-) (+1 of course) $\endgroup$
    – MarcoB
    Commented Jun 17, 2016 at 1:28
  • $\begingroup$ Thanks @Marco, I'm also glad you found arc to be very handy. :) $\endgroup$ Commented Jun 17, 2016 at 4:32
20
$\begingroup$

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

$\endgroup$
1
  • 1
    $\begingroup$ beautiful +1 :) $\endgroup$
    – ubpdqn
    Commented Jun 17, 2016 at 5:26
17
$\begingroup$

The approach that David took here can be reused in this context like so:

vertices[faceIndex_] := N@Part[
   PolyhedronData["TruncatedIcosahedron", "VertexCoordinates"],
   PolyhedronData["TruncatedIcosahedron", "FaceIndices"][[faceIndex]]
   ]

rf[faceIndex_] := Module[{cp},
  cp = Cross @@@ Partition[vertices[faceIndex], 2, 1, {1, 1}];
  Function[{x, y, z}, And @@ (Dot[{x, y, z}, #] < 0 & /@ cp)]
  ]

face[faceIndex_] := ContourPlot3D[
  x^2 + y^2 + z^2 == 1
  , {x, -1, 1}
  , {y, -1, 1}
  , {z, -1, 1}
  , ContourStyle -> If[faceIndex <= 12, Black, White]
  , RegionFunction -> rf[faceIndex]
  , Mesh -> None
  , PlotPoints -> 50
  , Boxed -> False
  , Axes -> False
  , Lighting -> {{"Directional", White, {{0, 0, 1}, {0, 0, 0}}}}
  , ContourStyle -> {Specularity[Black], Glow[Black]}
  ]

Array[face, 32] // Show

Mathematica graphics

$\endgroup$
5
  • $\begingroup$ This is very very nice! The visuals are particularly fetching. (+1) $\endgroup$
    – MarcoB
    Commented Jun 17, 2016 at 1:29
  • $\begingroup$ An alternative: With[{polys = First[Normal[PolyhedronData["TruncatedIcosahedron", "Faces"]]]}, vertices[faceIndex_] := N[polys[[faceIndex, 1]]]] $\endgroup$ Commented Jun 17, 2016 at 4:39
  • $\begingroup$ @C.E very nice +1. but why is there a dark side on the ball? $\endgroup$
    – vito
    Commented Jun 17, 2016 at 8:42
  • $\begingroup$ @vito Because there is only one light in one direction, so it only covers half of the ball. To fix it you can either add more lights or return to the default lighting setup with Lighting -> "Neutral", but this setup doesn't look very good. $\endgroup$
    – C. E.
    Commented Jun 17, 2016 at 9:01
  • 1
    $\begingroup$ @J.M. I find that a lot harder to read/understand. My solution is of the form Part[coordinates, indices] and the words coordinates and indices actually appear in the arguments themselves :) $\endgroup$
    – C. E.
    Commented Jun 17, 2016 at 9:07
1
$\begingroup$

Using SphericalPolygon by Jan Mangaldan

SphericalPolygon = ResourceFunction["SphericalPolygon"];

The following example was taken from its documentation ("Neat Examples") with some changes for better readability:

poly = PolyhedronData["TruncatedIcosahedron", "GraphicsComplex"];

faces = First /@ First @ Normal @ N @ MapAt[Map @ Normalize, poly, 1];

Graphics3D[
 Map[{
    GrayLevel[If[Length[#] == 5, 0, 0.8]],
    SphericalPolygon[#, "EdgeStyle" -> GrayLevel[0.4], "ShowEdges" -> True]} &, faces],
 Boxed -> False,
 Lighting -> "Neutral"]

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.