To give some context to the problem, I was walking in the neighborhood and I found this spikey.
I had been trying to get something similar to this in Mathematica. Literally, you will find spikeys everywhere in the company. It seems spikeys, or in general platonic solids are the foundations of Mathematica, well that and pattern matching. So, just as a disclaimer, nothing in this post is an original implementation, it is based on the 25 year anniversary celebration of Mathematica notebook.
Wolfram Research just celebrated it’s 33 year anniversary, thus the recreated spikey should have 33 points in it. To create a polyhedron with 33 faces, I decided to revisit the above post, to essentially get a surface that “sort of mimics” a regular polyhedron. Most of the steps are a repetition of the original problem, hence I will be very brief and non-technical in the description.
Use classic minimization method to solve the 33 point Thomson problem, which gives the points.
In[]:=
point[j_]:={Cos[φ[j]]Sin[ϑ[j]],Sin[φ[j]]Sin[ϑ[j]],Cos[ϑ[j]]};totalEnergy=Sum[1/Sqrt[(point[j]-point[k]).(point[j]-point[k])],{j,33},{k,j+1,33}];
In[]:=
SeedRandom[123];fm=FindMinimum[Evaluate[totalEnergy],Evaluate[Join[Table[{φ[j],RandomReal[{0,2Pi}]},{j,33}],Table[{ϑ[j],RandomReal[{0,Pi}]},{j,33}]]],MaxIterations10000,PrecisionGoal6,WorkingPrecision20];pts=First[Table[point[j],{j,33}]/.Rest[fm]];
Now computing the polygons in a very similar fashion:
In[]:=
distancetriangleorigin[pt1_,pt2_,pt3_]:=Abs[Det[{pt1,pt2,pt3}]/Sqrt[Sum[Det[ReplacePart[{pt1,pt2,pt3},{{1,c},{2,c},{3,c}}1]]^2,{c,1,3}]]];max=33;polygons={};Do[If[d>e>i&&distancetriangleorigin[pts[[d]],pts[[e]],pts[[i]]]>1-3.4/max,polygons=Append[polygons,{d,e,i}]],{d,3,max},{e,2,max},{i,1,max}];
Somehow the number 33 simplified the problem of “same handedness” and we did not need to drop any polygons. Finally the details of the spikey creation are very similar to the original post, except we have simplified the process further, and made changes to account for increase in spikey points.
In[]:=
hyperbolice[r_?VectorQ,α_]:=r(r.r)^αmp[n_]:=mp[n]=Mean[pts[[polygons[[n]]]]];p1[n_]:=p1[n]=pts[[polygons[[n,1]]]];p2[n_]:=p2[n]=pts[[polygons[[n,2]]]];p3[n_]:=p3[n]=pts[[polygons[[n,3]]]];
In[]:=
Graphics3D[{FaceForm[Brown],EdgeForm[None],Table[With[{jj=Table[Evaluate[hyperbolice[mp[n]+s((1-t)(#1[n]-mp[n])+t(#2[n]-mp[n])),2.4]],{s,.6,1,.1},{t,0,1,.1}]&@@@{{p1,p2},{p2,p3},{p3,p1}}},With[{r1=Sequence[1,5],r2=Sequence[6,10]},{Function[{v,f},Polygon/@Table[f@{v[[g,a+#1,b+#2]],v[[g,a+#3,b+#4]],v[[g,a+#5,b+#6]]},{a,1,4},{b,##7}]&@@@{{0,0,1,0,0,1,r2},{1,0,1,1,0,1,r2},{0,0,1,1,0,1,r1},{0,0,1,0,1,1,r1}}]@@@{{jj,Identity}},Polygon/@Table[Reverse[{jj[[g,1,b]],jj[[g,1,b]],jj[[g,1,b+1]],jj[[g,1,b+1]]}],{b,1,10}]}]],{g,1,3},{n,1,64}]},BoxedFalse,SphericalRegionTrue,ViewAnglePi/10,ImageSize{400,400}]
Out[]=
In conclusion, it is sometimes a fun activity to revisit some solutions, apply it to your own problems and in the process simplify the process of the previous solution for your use case. Happy Anniversary Mathematica and Happy Birthday to everyone who are still in their 33rd year of life! You share your birthday with this company :)