Triangular mesh of random points on a sphere

Question

My employer has a new logo (shown below). I do not have information on how this was created (as it was done by an outside company), though I'm fairly sure it was not done in any formal mathematical way:

It appears to be a triangular mesh of randomly spaced points, projected onto a sphere (at least to my eye, the points seem randomly distributed). I'd like to create something like this in Mathematica using built-in commands.

My first attempt was to generate a list of random points:

SeedRandom[10220];

pts = RandomReal[{-100, 100}, {200, 2}];

And then generate a DelaunayMesh:

d = DelaunayMesh[pts];
h = HighlightMesh[d, {Style[0, Directive[PointSize[Large], Darker[Green]]],
                  Style[1, Directive[Darker[Green]]], Style[2, Opacity[0]]}];

And map this texture onto a sphere:

sphere = SphericalPlot3D[1, {theta, 0, Pi}, {phi, 0, 2 Pi}, 
  Mesh -> None, TextureCoordinateFunction -> ({#5, 1 - #4} &), 
  PlotStyle -> Directive[Texture[h]], Lighting -> "Neutral", 
  Axes -> False, Boxed -> False]

This is going in the right direction, but I'm hoping for a way to do this more efficiently.

Thanks,

Mark

Answer 1

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.

Answer 2

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

Answer 3

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

Answer 4

Not quite what you asked for, but here is a non-random approximation:

Needs["PolyhedronOperations`"]

Graphics3D[{
  Style[Sphere[{0, 0, 0}, 0.95], Opacity[0.5], Lighting -> None, Glow[White]],
  FaceForm[], EdgeForm[Darker@Green], PointSize[Large], Darker@Green,
  N[Geodesate[PolyhedronData["Icosahedron", "Faces"], 2]] /.
   p_Polygon :> {p, Point[Flatten @@ p]}},
 Boxed -> False, BoxRatios -> {1, 1, 2}]

Answer 5

It took a while from the first time I saw this question, but only because I only realized now that I had eventually built all the tools I thought I needed. Thus, this will link to a lot of my previous answers.

First, I'll use the Lloyd algorithm to generate a bunch of equidistributed points:

n = 50; (* number of points *)
BlockRandom[SeedRandom[1337, Method -> "MersenneTwister"];
            sp = Normalize /@ RandomVariate[NormalDistribution[], {n, 3}]];

With[{maxit = 45, (* maximum iterations *)
      tol = 0.001 (* distance tolerance *)}, 
     lp = FixedPoint[Function[pts, 
                     Block[{ch, polys, verts, vor},
                           ch = ConvexHullMesh[pts];
                           verts = MeshCoordinates[ch];
                           polys = First /@ MeshCells[ch, 2];
                           vor = Normalize[Cross[verts[[#2]] - verts[[#1]], 
                                                 verts[[#3]] - verts[[#1]]]] &
                                 @@@ polys;
                           SphericalPolygonCentroid[vor[[#]]] & /@ 
                           ch["VertexFaceConnectivity"]]], sp, maxit, 
                     SameTest -> (Max[MapThread[cosDistance, {#1, #2}]] < tol &)]];

(The associated auxiliary routines will lengthen this answer, so just refer to my previous answer to get them.)

From these points, generate the convex hull and extract the corresponding points and edges:

ch = ConvexHullMesh[lp];
pts = MeshCoordinates[ch];
edges = First /@ MeshCells[ch, 1];

Finally, to render the picture, we need two NURBS-based primitives:

(* https://mathematica.stackexchange.com/a/10994 *)
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}]]

(* https://mathematica.stackexchange.com/a/128496 *)
sphericalCap[{θ_, φ_}, α_] := With[{c = Cos[α/2]},
         Style[BSplineSurface[Map[RotationTransform[{{0, 0, 1}, 
                                  Append[{Cos[θ], Sin[θ]} Sin[φ], Cos[φ]]}], 
               Map[Function[pt, Append[#1 pt, #2]],
                   {{1, 0}, {1, 1}, {-1, 1}, {-1, 0}, {-1, -1}, {1, -1}, {1, 0}}] & @@@
                   {{0, 1}, {Sin[α/2]/c, 1}, {Sin[α], Cos[α]}}], 
               SplineClosed -> {False, True}, SplineDegree -> 2, 
               SplineKnots -> {{0, 0, 0, 1, 1, 1},
                               {0, 0, 0, 1/4, 1/2, 1/2, 3/4, 1, 1, 1}}, 
               SplineWeights -> Outer[Times, {1, c, 1}, {1, 1/2, 1/2, 1, 1/2, 1/2, 1}]], 
               BSplineSurface3DBoxOptions -> {Method -> {"SplinePoints" -> 25}}]]

Now, generate the picture:

Graphics3D[{{ColorData["Legacy", "Honeydew"], 
             Tube[arc[{0, 0, 0}, 0.98 pts[[#]]], 1/150] & /@ edges}, 
            {ColorData["Legacy", "ForestGreen"], Glow[ColorData["Legacy", "Chartreuse"]],
             EdgeForm[Directive[AbsoluteThickness[1/4],
                                ColorData["Legacy", "CobaltGreen"]]], 
             sphericalCap[{ArcTan @@ Most[#], ArcCos[Last[#]/Norm[#]]}, π/60] & /@ pts}},
           Background -> ColorData["Legacy", "Gainsboro"],
           Boxed -> False, Lighting -> "Neutral"]