Message Boards Message Boards

Help with Halloween costumes

Posted 9 years ago

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}]

acorn

POSTED BY: Todd Rowland
10 Replies

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]}}]

icosahedron world

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 BY: Todd Rowland

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 BY: Todd Rowland

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 BY: Sidney Sudberg

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 BY: Udo Krause

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 BY: Todd Rowland

Halloween fly-by: 2015 TB145 will pass about 1.27 lunar distance from Earth on 31 October 2015 at about 17:00 UT.

POSTED BY: Udo Krause

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]}}]

enter image description here

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 is

enter image description here

pretty 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 issues

enter image description here

Without 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 BY: Udo Krause

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.

POSTED BY: Todd Rowland

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 leaf

enter image description here

if 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.

POSTED BY: Udo Krause

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 web

enter image description here

now 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 see

enter image description here

it 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.

POSTED BY: Udo Krause
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract