# Help with Halloween costumes

GROUPS:
 Todd Rowland 2 Votes Every year our family makes costumes, and this time we are making "the world" and an "oak tree". Does anyone have any ideas for doing these in Wolfram Language?Maybe for the world, I am thinking of projecting the map of the world onto two halves of an icosahedron. One half attached to the front of a shirt and the other half attached to the back. I am close on this part, but maybe it has become too complicated. Something Is wrong here, and this approach also involves more cutting and taping than I would prefer. ToMapCoordinates[v_] := N[ToPolarCoordinates[v][[{3, 2}]]/Degree] verts = Map[ToMapCoordinates, PolyhedronData["Icosahedron", "VertexCoordinates"]]; GeoTriangle[{a_, b_, c_}] := GeoGraphics[Polygon[{a, b, c}]] GeoTriangle[verts[[#]]] & /@ PolyhedronData["Icosahedron", "FaceIndices"] For the oak tree, I was trying to make oak leaves and acorns using PolarPlot. Does anyone have an Oak leaf? Here is my attempt at an acorn. PolarPlot[1.4 - CubeRoot[1 + Sin[x]], {x, 0, 2 Pi}] 
2 years ago
10 Replies
 Udo Krause 4 Votes Does anyone have an Oak leaf? Note: WolframAlpha has popular curves, but no leaf curves, seemingly ... but right now leafs are popular.First shot: Get an oak leaf from the webnow get it's outline In[23]:= pic = Import[FileNameJoin[{NotebookDirectory[], "test", "oak-leaf1.jpg"}]] In[36]:= Export[FileNameJoin[{NotebookDirectory[], "test", "oak-edge.png"}], EdgeDetect[ColorNegate[pic]]] Out[36]= "N:\\Udo\\Abt_N\\test\\oak-edge.png" In[39]:= Clear[pic2] pic2 = Import[FileNameJoin[{NotebookDirectory[], "test", "oak-edge.png"}], "Data"] In[62]:= toddLeaf[p_?MatrixQ] := Block[{o1 = Length[p], o2 = Length[First[p]], l, ll = {}, cr, lr = {}}, For[i1 = 1, i1 <= o1, i1++, l = p[[i1]]; cr = 0; For[i2 = 1, i2 <= o2 && cr == 0, i2++, cr = l[[i2]] ]; If[i2 < o2, ll = Join[ll, {{i1, i2}}] ]; cr = 0; For[i2 = o2, i2 >= 1 && cr == 0, i2--, cr = l[[i2]] ]; If[i2 > 1, lr = Join[lr, {{i1, i2}}] ] ]; Flatten[{Reverse[lr], ll}, 1] ] /; Union[Flatten[p]] == {0, 1} In[63]:= Graphics[Line[toddLeaf[pic2]]] to seeit does not follow the fingers inwards because only the first and the last 1 on a row has been stored ... room for improvement ... but this way each leaf half is a function over x which can be used for further work on it.
2 years ago
 Udo Krause 3 Votes This is going to go much easier pic = Import[FileNameJoin[{NotebookDirectory[], "test", "oak-leaf1.jpg"}]] Export[FileNameJoin[{NotebookDirectory[], "test", "oak-edge.png"}], EdgeDetect[ColorNegate[pic]]] Clear[pic3, pts, sTour] pic3 = Import[FileNameJoin[{NotebookDirectory[], "test", "oak-edge.png"}]]; pts = PixelValuePositions[pic3, 1]; sTour = FindShortestTour[pts]; Graphics[Line[pts[[Last[sTour]]]]] giving a real graphical Oak leafif one searches for two points with the greatest position difference on sTour but the smallest euclidean distance it is possible to cut the inner part of the tour out to get the contour.
2 years ago
 Thanks Udo. I guess I was expecting some sort of trig polynomial. I did try the shape you made, and tried to fit it to a simple trig polynomial but without any luck.
2 years ago
 Udo Krause 1 Vote Ok, here is the trig polynomial. First get rid of the inner structure with a little unprofessional hand testing Graphics[{Line[pts[[Last[sTour]]]], {Red, Disk[pts[[Last[sTour][[1]]]], 7]}, {Blue, Disk[pts[[Last[sTour][[4170]]]], 10]}, {Green, Disk[pts[[Last[sTour][[1028]]]], 7]}}] showing the outline is approximately Clear[sOak] sOak = Join[Take[Last[sTour], {1, 1028}], Take[Last[sTour], {4170, Length[Last[sTour]]}]]; Graphics[Line[pts[[sOak]]]] Now one makes usage of Michael Trott's blog post Making Formulas… for Everything—From Pi to the Pink Panther to Sir Isaac Newton. Copied the relevant functions right off the CDF file of this post, calling them fCs = fourierComponents[{pts[[sOak]]}, "OpenClose" -> Table["Closed", {Length[{pts[[sOak]]}]}]]; ParametricPlot[Evaluate[makeFourierSeries[#, t, 100] & /@ Cases[fCs, {"Closed", _}]], {t, -Pi, Pi}] and the result ispretty well shaped, I would say; and this is the Fourier series Short[makeFourierSeries[#, t, 100] & /@ Cases[fCs, {"Closed", _}], 20] must be given as picture because of the box formatting issuesWithout Michael's functions you have a really bad time; most other explanations all over the web do not work very well.Have fun with your family fête - the notebook is appended.Consider to include the leaf curves into WolframAlpha if this is something people like to do at this time in the year. Attachments:
2 years ago
 Halloween fly-by: 2015 TB145 will pass about 1.27 lunar distance from Earth on 31 October 2015 at about 17:00 UT.
2 years ago
 Thanks, I am sure it will be fun. Every holiday should have a little math, and Halloween especially for anything scary (Some say math is scary, hah).Udo, do you have a link to any Wolfram Alpha leaf shapes?Next I need to make the world. Maybe I will try a stereographic projection onto the faces of the icosahedron instead of relying on the defaults.
2 years ago
 do you have a link to any Wolfram Alpha leaf shapes? No, I don't because WolframAlpha does not have leaf shapes, up to now (at least I did not find one for 10 minutes). That's why I had to start from a jpg picture.Searching the web gives morphological information
 The world was not as easy as I expected. Here are the steps I took to map it into the flattened icosahedron so I can print it out, cut it out, fold it and tape it to my shirt for Halloween.Start out with the world in lat-long. world2d = CountryData["World", "Polygon"]; Convert to 3d. world3d = N[world2d[[1, 1]]] /. {x_Real, y_Real} :> ({Cos[#2] Cos[#], Sin[#2] Cos[#], Sin[#]} &[x*Degree, y*Degree]); Some modified data from PolyhedronData giving the two and three dimensional coordinates of the vertices and face indices. v3 = PolyhedronData["Icosahedron", "VertexCoordinates"]; i3 = PolyhedronData["Icosahedron", "FaceIndices"]; f3 = v3[[#]] & /@ i3; v2 = PolyhedronData["Icosahedron", "NetCoordinates"]; i2b = {{1, 6, 7}, {13, 6, 12}, {2, 7, 8}, {14, 7, 13}, {3, 8, 9}, {15, 8, 14}, {4, 9, 10}, {16, 9, 15}, {5, 10, 11}, {17, 10, 16}, {6, 13, 7}, {13, 12, 18}, {7, 14, 8}, {14, 13, 19}, {8, 15, 9}, {15, 14, 20}, {9, 16, 10}, {16, 15, 21}, {10, 17, 11}, {17, 16, 22}} f2b = v2[[#]] & /@ i2b; f3tof2b = {1, 3, 5, 7, 9, 18, 20, 12, 14, 16, 11, 13, 15, 17, 19, 8, 10, 2, 4, 6}; Convert 3d coordinates to the face index and local face 2d coordinates. FacePlanes = Apply[Function[{a, b, c}, {Cross[a, b], Cross[b, c], Cross[c, a]}], N@f3, {1}]; FaceMeans = Apply[Function[{a, b, c}, Mean[{a, b, c}]], N@f3, {1}]; FaceInverses = Apply[Function[{a, b, c}, Inverse[{Mean[{a, b, c}], b - a, c - a}][[All, 2 ;; 3]]], N@f3, {1}]; FaceCoord[p_] := With[{coords = Select[Table[{i, FacePlanes[[i]].p}, {i, 20}], Min[#[[2]]] >= 0 &,1][[1]]}, {coords[[1]], p.FaceInverses[[coords[[1]]]] (.571175/(p.FaceMeans[[coords[[1]]]]))}] worldpattern0 = world3d /. {x_Real, y_Real, z_Real} :> FaceCoord[{x, y, z}]; Convert the index plus coordinates to the plane. Also split the lists of coordinates so that lines don't cross faces weirdly. ProjCoord[{ind_, {x_, y_}}] := x (#2 - #) + y (#3 - #) + Mean[{##}] & @@ f2b[[f3tof2b[[ind]]]] worldpattern1b = worldpattern0 /. list : {{_Integer, {__Real}} ..} :> Map[ProjCoord[#] {1, -1} &, SplitBy[list, First], {2}]; And finally, Graphics[{Line /@ worldpattern1b, {Red, Point[{1, -1} # & /@ v2]}}] Just cut the shape out, fold between the red dots which are the vertices, and tape it together. Does anyone know how to find a map of the Moon or Mars or Pluto?