# How to create this spikey in Mathematica?

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! related link that may help when creating points: click me click me~

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

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] 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] • I was momentarily confused, but then realized your convention for $\theta$ and $\varphi$ is opposite to mine. :D Jun 25 '16 at 14:27
• 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!
– Wjx
Jun 25 '16 at 14:55
• @Wjx, I'm not sure what the problem is. With pts = Normalize /@ pt my visualisation works fine with your points? Jun 25 '16 at 15:11
• oops, sorry, my fault that I didn't normalize that before using it. Silly mistake. :P thank you verrrry much!
– Wjx
Jun 25 '16 at 15:13
• (+1) Instead of using PolyhedronOperationsGeodesate, you could do pts = MeshCoordinates[DiscretizeGraphics[Sphere[], MaxCellMeasure -> .01]]; and get very similar results. Oct 7 '16 at 20:35

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

l = 6;
mlist = {-5, 0, 5};
slist = {Sqrt/5, Sqrt/5, -(Sqrt/5)};

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

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

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

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

l = 20;
mlist = {-20, -15, -10, -5, 0, 5, 10, 15, 20};
slist = {Sqrt[164021/5]/625, -((2 Sqrt[12958/5])/625), (
41 Sqrt[323/5])/625, -(Sqrt[(206074/5)]/625), Sqrt/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 • I upvoted it because it's beautiful, but it is not quite spikey~
– Wjx
Jun 25 '16 at 13:27
• @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 Jun 25 '16 at 13:32
• Maybe for completeness, you can show how to generate the irreducible representations of the $I_h$ group from scratch. :) Jun 25 '16 at 14:29
• @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... Jun 25 '16 at 16:35
test = points;


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] 