Triangular mesh of random points on a sphere
It seems to me that the logo has three semitransparent layers of triangle meshes.
One can start with discretized sphere
reg = DiscretizeGraphics[Sphere[], MaxCellMeasure -> {"Length" -> 0.8}]
Or with Simon's Geodesate
. Then the function for disks in 3D is helpful
disk[pos_, {nx_, ny_, nz_}, r_, n_: 16] := With[{θ = ArcTan[Sqrt[nx^2 + ny^2], nz],
φ = ArcTan[nx, ny]}, Polygon@Table[pos + r {Cos[α] Cos[φ] Sin[θ] - Sin[α] Sin[φ],
Cos[φ] Sin[α] + Cos[α] Sin[φ] Sin[θ], -Cos[α] Cos[θ]}, {α, 2. π/n, 2 π, 2. π/n}]];
Several functions to draw randomly oriented mesh on sphere, disks on vertices and opacity sphere:
mesh[m_, z_] := GeometricTransformation[{Gray,
Normal@GraphicsComplex[MeshCoordinates@reg, MeshCells[reg, 1]] /.
Line[{a_, b_}] :> Line@Table[Normalize[a t + b (1 - t)], {t, 0, 1, 0.1}]}, {First@
QRDecomposition@m, {0, 0, z}}]
disks[m_, z_] := GeometricTransformation[{EdgeForm@Gray,
Glow@RGBColor[0.6, 0.75, 0.25], Black,
disk[#, #, 0.03] & /@ MeshCoordinates@reg}, {First@
QRDecomposition@m, {0, 0, z}}]
sphere[op_, z_] := {Opacity@op, Glow@White, Sphere[{0, 0, z - 0.01}, 1.01]};
ball[z_] := {mesh[#, z], disks[#, z + 0.01]} &@RandomReal[NormalDistribution[], {3, 3}];
Finally, we combine three randomly oriented layers with opacity and different z-position
Graphics3D[GeometricTransformation[{sphere[1, 0], ball[0.02], sphere[0.2, 0.04],
ball[0.06], sphere[0.2, 0.08], ball[0.10]},
ScalingTransform[{0.7, 1, 1}]], Boxed -> False, ImageSize -> 300,
ViewPoint -> {0, 0, ∞}, ViewVertical -> {0, 1, 0}]
The result looks similar to the logo.
Quite long since there are arcs not lines, here is the code for them:
An efficient circular arc primitive for Graphics3D
disk = Scale[Sphere[{0, 0, 1.02}, .05], {1, 1, .2}];
Composition[
Graphics3D[{#, [email protected], Sphere[{0, 0, 0}, 1]}, ImageSize -> 500,
Lighting -> "Neutral"] &
,
{
Green, GeometricTransformation[disk, RotationTransform[{{0, 0, 1}, First@#}]],
Gray, arc[{0, 0, 0}, #]
} & /@ # &
,
Extract[First@#, List /@ Last@#] &
,
{
Table[
RotationMatrix[RandomReal[.7], RandomReal[1, 3]].p, {p,
First@#}], Composition[
DeleteDuplicates,
Sort /@ # &,
Join @@ # &,
# /. Polygon -> (Partition[{##, #}, 2, 1] & @@ # &) &
]@Last[#]} &
,
{
MeshCoordinates[#],
MeshCells[#, 2]} &
,
DiscretizeGraphics[#, MaxCellMeasure -> {"Length" -> 0.6}] &
][Sphere[]]
A quick hack:
With[{mesh =
DiscretizeGraphics@PolyhedronData["TruncatedIcosahedron", "Edges"]},
Show[
Graphics3D[{Opacity[1/2], Sphere[{0, 0, 0}, 0.999]},
Lighting -> {{"Ambient", White}}, Boxed -> False],
MeshPrimitives[mesh, 0] /.
Point[p_] :>
Graphics3D[{Green, EdgeForm[None],
MeshPrimitives[
DiscretizeRegion@
RegionIntersection[Sphere[], Ball[Normalize@p, 1/20]], 2]},
Lighting -> {{"Ambient", White}}],
Graphics3D[{Green, Thick,
MeshPrimitives[mesh, 1] /.
Line[{a_, b_}] :>
Line[Table[Normalize[t a + (1 - t) b], {t, 0, 1, 1/50}]]}]
]]
For random mesh, one could use randomly sampled points on a sphere and construct either DelaunayMesh
or ConvexHullMesh
from point set and use BoundaryMesh
of that, but purely randomly sampled points don't actually produce aesthetic results. Thus, I use a truncated icosahedron data as an example.
EDIT
Inspired by ybeltukov, here's one with just a different mesh
,
mesh = DiscretizeRegion[Sphere[], MaxCellMeasure -> {"Length" -> 0.8}]