Which of the $43,380$ possible nets for a dodecahedron is the narrowest?

1.1k Views Asked by At

I want to fit multiple regular dodecahedron nets on to an infinitely long roll of paper. I want this to result in the largest possible dodecahedrons, for a roll of a given width.

My hunch is that the longer and narrower the net, the larger the dodecahedron I can produce; proving this one way or the other might be an interesting side-exercise.

My main question for now is simply: for a given size of pentagon, which of the $43,380$ possible nets for a regular dodecahedron fits into the narrowest rectangle?

1

There are 1 best solutions below

14
On BEST ANSWER

Just as a starter, I propose the most obvious one. Area of rectangle is 32.89 if every edge of dodecahedron is of unit length.

enter image description here

EDIT.

If one is interested in the narrowest possible net, I think the above disposition is still the best one. Because the central "belt" of six pentagons (yellow in the picture below) cannot be altered without widening the net, and the other surrounding pentagons can be moved to other positions, but this doesn't narrow (at best) the witdth of the net (see possible new positions, in blue, of three pentagons). The width of this net is $\sqrt{5+2\sqrt5}(3+\sqrt5)/4\approx4.02874$ times the length of a single edge.

enter image description here

EDIT 2.

Inspired by net n° 9383 in Horiyama's list I could find a strip slightly narrower than the above, at the expense of having its border not parallel to any pentagon side (see picture). Its width is $\approx 3.93448$.

enter image description here

EDIT 3.

Oolong discovered the best candidate, up to now: it is n° 43362 in the catalogue, corresponding to a width $\approx 3.66547$.

enter image description here

EDIT 4.

Oolong discovered an even narrower net: it is n° 36753 in the catalogue, corresponding to a width $\approx 3.3166$. enter image description here

EDIT 5.

I performed an exhaustive search, using Mathematica and the complete collection of dodecahedron net centers in Mathematica format, which can be found at Horiyama's site. For every net I checked all the lines passing through two vertices: in case all the other vertices lied on the same side of the line, I then computed the distance from the line to the farthest vertex. The shortest of those distances is the "width" of the net.

Here are a few of the best results.

WIDTH     NET NUMBERS
3.07768   41382, 32924, 32920, 32511, 32494, 32492

3.26889   26440, 23967, 23620, 20027, 19706, 19668

3.3166    42665, 42591, 42549, 42546, 39271, 39268, 36753, 36743, 36717,
          36716, 36607, 36598, 36581, 36445, 36439, 36408, 36390, 36304,
          36298, 36267, 36264, 36263, 29579, 28755, 28742, 28741, 28740,
          28734, 28496, 28489, 28488, 28456, 28434, 28433, 28432, 28416,
          27807, 27806, 27805, 27729, 27728, 27727, 27674, 27673, 27672

Notice that the narrowest width can be computed exactly: $3.07768=\sqrt{5+2\sqrt5}$. Here's a picture of n° 41382, which is one of the "winners": enter image description here

EDIT 6.

Here's the Mathematica code I used.

(* some definitions *)
lato=2Sin[Pi/5]//Simplify;
sqdist[a_,b_]:=(a-b).(a-b);
rot[a_,b_,t_]:=b+{{Cos[t],-Sin[t]},{Sin[t],Cos[t]}}.(a-b);
cross2[{ax_,ay_},{bx_,by_},{cx_,cy_}]:=(ax*by-ay*bx+bx*cy-cx*by+
      cx*ay-cy*ax)/Sqrt[sqdist[{ax,ay},{bx,by}]];

(* main loop; "r04_n.math" are Horiyama's files *)
all={};
Do[
  file="/path/r04_"<>ToString[n]<>".math";
  Get[file];
  net={};

  Do[
    If[sqdist[p[[i]],p[[k]]]==a^2//Simplify,
      cmid=p[[i]]+(p[[k]]-p[[i]])/a;
      start=rot[cmid,p[[i]],Pi/5]//Simplify;
      pent=Table[rot[start,p[[k]],2j*Pi/5]//FullSimplify,{j,0,5}];
      net=Append[net,pent];
      pent=Table[rot[start,p[[i]],2j*Pi/5]//FullSimplify,{j,0,5}];
      net=Append[net,pent]
      ],
    {i,1,Length[p]-1},
    {k,i+1,Length[p]}];

  pts=Flatten[net,1]//N;
  pts=Union[pts,SameTest -> (sqdist[#1,#2]<0.00001&)];

  best=1000;
  Do[
    wid=-1;
    flag=True;
    Do[
      t=cross2[pts[[i]],pts[[j]],pts[[k]]];
      If[Abs[t]<0.0000001,Continue[]];
      If[wid<0,wid0=Sign[t];wid=0];
      If[t*wid0<-0.0000001,flag=False;Break[]];
      If[Abs[t]>Abs[wid],wid=Abs[t]],
      {k,1,Length[pts]}];

    If[flag && wid/lato<best,best=wid/lato],
    {i,1,Length[pts]-1},
    {j,i+1,Length[pts]}];

  AppendTo[all,{n,best}],

  {n,1,43380}];

allsorted=Sort[all,#1[[2]]<#2[[2]]&]