# Help with Halloween costumes

Posted 3 years ago
6273 Views
|
10 Replies
|
12 Total Likes
|
 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}] 
10 Replies
Sort By:
Posted 3 years ago
 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?
Posted 3 years ago
 What I am trying to do is use Wolfram Language to print out some shapes to cut out for Halloween outfits. It makes it more fun to have some code and some math behind it.One outfit is an oak tree, which is where the discussion on the acorn and oak leaves began,Another is the world. I plan on printing out the PolyhedronData["Icosahedron", "NetFaces"] which I can fold along the edges and tape it together to become an icosahedron. The tricky part is projecting the world map onto the faces of the icosahedron.
Posted 3 years ago
 If you don't mind me asking, what is the reason/purpose for this 'study'? I too have an interest in this field, as well as the microscopic anatomical images of different plants for the purpose of identification of unknown plants vs. 'Authentic' plants. I am new to this Community, so am not sure if this is an appropriate inquiry, forgive me if not.Sidney
Posted 3 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
Posted 3 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.
Posted 3 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.
Posted 3 years ago
 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:
Posted 3 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.
 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.
 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.