$3D$ graphic of soccer ball
Here's my attempt at a soccer/foot ball, updated with an improved surface model:
First create the patches (code below):
pl /@ {5, 6}
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!
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"]]
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"]]
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
]
