14
$\begingroup$

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:

Sample Logo

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

Delaunay mesh

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]

Sphere

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

Thanks,

Mark

$\endgroup$
23
$\begingroup$

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

enter image description here

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

enter image description here

The result looks similar to the logo.

$\endgroup$
  • 4
    $\begingroup$ +1 The result looks better than the logo! $\endgroup$ – Simon Woods Feb 5 '15 at 22:54
  • $\begingroup$ Nice observation and execution! $\endgroup$ – Kuba Feb 6 '15 at 6:54
12
$\begingroup$

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[{#, Opacity@.2, 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[]]

enter image description here

$\endgroup$
10
$\begingroup$

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

enter image description here

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

enter image description here

$\endgroup$
9
$\begingroup$

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

enter image description here

$\endgroup$
4
$\begingroup$

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

spherical network

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.