18
$\begingroup$

I came across this post while messying around the StackExchange mobile. I think this thing can be easily done by Mathematica as well but I'm not an expert in geometric field. Can anyone give some solutions?

This problem is open to all kinds of answers at all times!

desired image

related link that may help when creating points: click me click me~

$\endgroup$
5
  • $\begingroup$ Note the icosahedral symmetry of the object. A possible solution might involve the use of Geodesate[] on an icosahedron. Alternatively, look up Goldberg polyhedra. $\endgroup$ Commented Jun 25, 2016 at 5:11
  • $\begingroup$ How many spikes do you need? $\endgroup$
    – yarchik
    Commented Jun 25, 2016 at 12:27
  • 3
    $\begingroup$ enough spikes to make the image cool~ $\endgroup$
    – Wjx
    Commented Jun 25, 2016 at 12:54
  • $\begingroup$ I'm also working on this~ $\endgroup$
    – Wjx
    Commented Jun 25, 2016 at 12:54
  • $\begingroup$ A related thread. $\endgroup$ Commented Aug 12, 2016 at 15:24

3 Answers 3

36
$\begingroup$

This is probably too slow to get a decent image, but here's a simple attempt. As JM suggests, you can use Geodesate to get a good set of points on the sphere. I used ContourPlot3D to plot a sphere whose radius increases in the vicinity of one of those points.

Needs["PolyhedronOperations`"]

pts = Geodesate[PolyhedronData["Icosahedron"], 2][[1, 1, 14 ;;]];

nf = Nearest[N@pts];

f[x_?NumericQ, y_, z_] :=
 With[{d = Normalize[{x, y, z}] - First[nf[{x, y, z}]]},
  1 + 0.5 Exp[-300 (d.d)]]

ContourPlot3D[x^2 + y^2 + z^2 == f[x, y, z], 
  {x, -1.2, 1.2}, {y, -1.2, 1.2}, {z, -1.2, 1.2}, Mesh -> None, ContourStyle -> Green]

enter image description here

The surface has some holes, and obviously there are not enough spikes (increase the geodesation order to get more). You can fiddle with the lighting and surface specularity to make it look more shiny.

update

It is faster to use SphericalPlot3D of course:

pts = Geodesate[PolyhedronData["Icosahedron"], 4][[1, 1, 14 ;;]];
nf = Nearest[N@pts];
f[x_?NumericQ, y_, z_] := With[{d = Normalize[{x, y, z}] - First[nf[{x, y, z}]]}, 
  1 + 0.25 Exp[-300 (d.d)]]
g[θ_, ϕ_] := f[Sin[θ] Cos[ϕ], Sin[θ] Sin[ϕ], Cos[θ]]

SphericalPlot3D[g[θ, ϕ], {θ, 0, Pi}, {ϕ, 0, 2 Pi}, 
 PlotPoints -> 100, Mesh -> None, 
 PlotStyle -> Directive[Darker@Green, Specularity[White, 30]], 
 Lighting -> "Neutral", Background -> Black, Boxed -> False, Axes -> False]

enter image description here

$\endgroup$
5
  • $\begingroup$ I was momentarily confused, but then realized your convention for $\theta$ and $\varphi$ is opposite to mine. :D $\endgroup$ Commented Jun 25, 2016 at 14:27
  • $\begingroup$ It's wierd that I cannot do the same plotting with my data......How can I solve this problem? my data can be get via visiting the link I've posted. If you can explain this, I will have no hesitation to select your question. :) Thanks! $\endgroup$
    – Wjx
    Commented Jun 25, 2016 at 14:55
  • $\begingroup$ @Wjx, I'm not sure what the problem is. With pts = Normalize /@ pt my visualisation works fine with your points? $\endgroup$ Commented Jun 25, 2016 at 15:11
  • $\begingroup$ oops, sorry, my fault that I didn't normalize that before using it. Silly mistake. :P thank you verrrry much! $\endgroup$
    – Wjx
    Commented Jun 25, 2016 at 15:13
  • 2
    $\begingroup$ (+1) Instead of using PolyhedronOperations`Geodesate, you could do pts = MeshCoordinates[DiscretizeGraphics[Sphere[], MaxCellMeasure -> .01]]; and get very similar results. $\endgroup$
    – Greg Hurst
    Commented Oct 7, 2016 at 20:35
20
$\begingroup$

A mathematical approach using $A_\text{g}$ irreps of $I_h$ symmetry group expressed in terms of spherical harmonics. First some data

l[1] = 6;
mlist[1] = {-5, 0, 5};
slist[1] = {Sqrt[7]/5, Sqrt[11]/5, -(Sqrt[7]/5)};

l[2] = 10;
mlist[2] = {-10, -5, 0, 5, 10};
slist[2] = {Sqrt[187/3]/25, -(Sqrt[209]/25), Sqrt[247/3]/25, Sqrt[
   209]/25, Sqrt[187/3]/25};

l[3] = 12;
mlist[3] = {-10, -5, 0, 5, 10};
slist[3] = {Sqrt[741/5]/25, Sqrt[286/5]/25, (3 Sqrt[119/5])/
   25, -(Sqrt[(286/5)]/25), Sqrt[741/5]/25};

l[4] = 16;
mlist[4] = {-15, -10, -5, 0, 5, 10, 15};
slist[4] = {Sqrt[34017/5]/
   250, -(Sqrt[(84847/30)]/125), -(Sqrt[6851]/250), (4 Sqrt[589/3])/
   125, Sqrt[6851]/
   250, -(Sqrt[(84847/30)]/125), -(Sqrt[(34017/5)]/250)};

l[5] = 18;
mlist[5] = {-15, -10, -5, 0, 5, 10, 15};
slist[5] = {Sqrt[17081/5]/125, Sqrt[4389/5]/125, (6 Sqrt[38])/125, 
   Sqrt[4301]/125, -((6 Sqrt[38])/125), Sqrt[4389/5]/
   125, -(Sqrt[(17081/5)]/125)};

l[6] = 20;
mlist[6] = {-20, -15, -10, -5, 0, 5, 10, 15, 20};
slist[6] = {Sqrt[164021/5]/625, -((2 Sqrt[12958/5])/625), (
   41 Sqrt[323/5])/625, -(Sqrt[(206074/5)]/625), Sqrt[4669]/625, Sqrt[
   206074/5]/625, (41 Sqrt[323/5])/625, (2 Sqrt[12958/5])/625, Sqrt[
   164021/5]/625};

Now the actual computation

Do[ySAF[h, \[Theta]_, \[Phi]_] = 
   ComplexExpand[
     Re@Dot[slist[h], 
       SphericalHarmonicY[l[h], mlist[h], \[Theta], \[Phi]]]] // 
    Simplify;
 , {h, 1, 6}]

and plotting

g = Table[SphericalPlot3D[(3 + ySAF[h, a, b]), {a, 0, \[Pi]}, {b, 0, 2 \[Pi]},
    PlotPoints -> 30, Mesh -> None, Axes -> False, 
   ColorFunction -> (ColorData["BlueGreenYellow"][1 - #6] &)], {h, 1, 6}]

with the following result

enter image description here

$\endgroup$
4
  • 1
    $\begingroup$ I upvoted it because it's beautiful, but it is not quite spikey~ $\endgroup$
    – Wjx
    Commented Jun 25, 2016 at 13:27
  • $\begingroup$ @Wjx I know, I hope someone here can apply some transformations to these functions to make them more spiky, have little time to do that. I do not mind though if it is posted as a separate answer $\endgroup$
    – yarchik
    Commented Jun 25, 2016 at 13:32
  • $\begingroup$ Maybe for completeness, you can show how to generate the irreducible representations of the $I_h$ group from scratch. :) $\endgroup$ Commented Jun 25, 2016 at 14:29
  • $\begingroup$ @J.M. It is not very hard. One can start for instance with L=6 (this irrep can be generated using usual group theory approach). Then for not very high angular momentum other irreps can be extracted from the products. For instance, $6\times6 = 10+12$, $12\times12=16+18+20+22+24$, and so on. At L=30 there are more than 1 Ag, and the things get complicated... $\endgroup$
    – yarchik
    Commented Jun 25, 2016 at 16:35
7
$\begingroup$
test = points[70];

With somewhat equally spaced points on the sphere from this answer.

Graphics3D[{Sphere[],
  test /. r : {x_, y_, z_} :> Cone[{.95 r, 1.25 r}, .1]},
 ImageSize -> Medium,
 Boxed -> False]

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.