Net for Schwarz's Polyhedron

antiprismDoub[r_,h_,n_]:={Join[Table[{i,Mod[i+1,n,1],n+i},{i,1,n}],Table[{i,Mod[n+i,2n,1],If[i==1,2n,n+i-1]},{i,1,n}],Table[{If[i==1,2n,n+i-1],Mod[n+i,2n,1],2n+i},{i,1,n}],Table[{n+i,If[i==n,2n+1,2n+i+1],Mod[2n+i,3n,1]},{i,1,n}]],Join[Table[{r Cos[2.Pi i/n],r Sin[2.Pi i/n],0},{i,0,n-1}],Table[{r Cos[2.Pi i/n+Pi/n],r Sin[2.Pi i/n+Pi/n],h},{i,0,n-1}],Table[{r Cos[2.Pi i/n],r Sin[2.Pi i/n],2h},{i,0,n-1}]]}

dod[a_][x_]:=a+x

antiprismDoub[r_,h_,n_,m_]:={Flatten[Table[Map[dod[2n (j-1)],antiprismDoub[1,1,n][[1]]],{j,1,m}],1],Flatten[Table[Table[{r Cos[2.Pi i/n+If[OddQ[j],0,Pi/n]],r Sin[2.Pi i/n+If[OddQ[j],0,Pi/n]],(j-1) h},{i,0,n-1}],{j,1,2m+1}],1]};

povprecje[list1_]:=Apply[Plus,list1]/Length[list1]

zapor1[n_,m_]:=Table[{1+n j,1+n (j+1)},{j,0,4m-2}]

zapor[n_,m_]:=Table[{1+n j,1+n (j+1)},{j,0,4m-2,2}]

nadalj[n_,m_,k_]:=If[OddQ[k],With[{p=First[zapor[n,m][[k]]],d=zapor[n,m][[k,2]]},Table[{{p+i,d+1+i},{d+1+i,p+1+i}},{i,0,n-2}]],With[{p=First[zapor[n,m][[k]]],d=zapor[n,m][[k,2]]},Table[{{d+i,p+1+i},{p+1+i,d+1+i}},{i,0,n-2}]]];

drevoS[n_,m_]:=Join[zapor1[n,m],Flatten[Table[nadalj[n,m,k],{k,1,Length[zapor[n,m]]}],2]];

AdjacencyPairsHI[lis_] := Cases[Union @@ Table[{a, b}, 
       {a, 1, Length[lis] - 1}, {b, a + 1, Length[lis]}], 
     {x_, y_} /; AdjacentHI[lis][x, y]];

AdjacentHI[lis_][a_, b_] := Length[Intersection[lis[[a]], lis[[b]]]] == 2;

TreeHI[pove_][n_][m_] := Module[{tr = {pove[[n]]}}, 
     While[ !MaksiTreeHIQ[tr, m], Do[If[DodajHIQ[tr, pove[[k]]], 
         tr = Append[tr, pove[[k]]]; Break[]], {k, 1, Length[pove]}]]; tr];

MaksiTreeHIQ[tr_,n_] := Module[{flag = True}, 
     Do[If[NiNode[i][tr], flag = False; Break[]], {i, 1,n}]; flag];

NiNode[a_][seznam_] := Module[{flag = True}, 
     Do[If[a == seznam[[i]][[1]] || a == seznam[[i]][[2]], 
        flag = False; Break[]], {i, 1, Length[seznam]}]; flag];

DodajHIQ[tr_, {a_, b_}] := JeNode[a][tr] && NiNode[b][tr] || 
     JeNode[b][tr] && NiNode[a][tr];

JeNode[a_][seznam_] := MemberQ[seznam, {a, x_}] || MemberQ[seznam, {y_, a}];

UrediTree2HI[drevo_] := Module[{drev = drevo, len = Length[drevo]}, 
     Do[Do[If[drev[[k]][[2]] == drev[[i]][[2]], 
         drev = ReplacePart[drev, {drev[[k]][[2]], drev[[k]][[1]]}, k]], 
        {i, 1, k - 1}], {k, 2, len}]; drev];

ChangeOrientation[pari_][lica_] := Module[{nnov,nprej,n, 
      len=Length[lica], ai, zi, indlicap, indlican, licep, licen, presek, 
      p1, p2, q1, q2, a1, ainov, r1, r2, aiprej, aikompl, aizaceten, qq1, 
      uni1, uni2, newfaces = lica, avindex, edges, q1n, q2n,m}, 
     Do[indlicap = pari[[m]][[1]]; indlican = pari[[m]][[2]]; 
        nnov = Length[lica[[indlican]]]; nprej = Length[lica[[indlicap]]]; 
        licep = newfaces[[indlicap]]; licen = newfaces[[indlican]]; 
        presek = Intersection[licep, licen]; {{p1}} = Position[licep, 
          presek[[1]]]; {{p2}} = Position[licep, presek[[2]]]; 
        {{q1}} = Position[licen, presek[[1]]]; 
        {{q2}} = Position[licen, presek[[2]]]; q1n = q1; q2n = q2; 
        If[PrejQHI[nprej][p1, p2] && PrejQHI[nnov][q1, q2] || 
          PrejQHI[nprej][p2, p1] && PrejQHI[nnov][q2, q1], 
         newfaces = ReplacePart[newfaces, Reverse[licen], indlican]; 
          q1n = nnov - q1; q2n = nnov - q2]; newfaces = ReplacePart[newfaces, 
          If[PrejQHI[nnov][q1n, q2n], RotateLeft[newfaces[[indlican]], 
            q1n - 1], RotateLeft[newfaces[[indlican]], q2n - 1]], indlican], 
       {m, 1, len - 1}]; newfaces];

PrejQHI[n_][p_, q_] := q == p + 1 || p == n && q == 1;

NetOfConvex3DS[solid_, facetree_, ulomek_,n_] := 
    Module[{linijaset, linija, poin1, poin2, d1, d2, len, p1, p2, indn, indp, 
      indlica, novatocka, len1, maksi, dih, afaces, vertis}, 
     afaces = solid[[1]]; vertis = solid[[2]];
      linijaset = Table[{}, {Length[afaces]}];
      normals = Table[{}, {Length[afaces]}];
      maksi = Table[0, {Length[afaces]}]; dih = DihedralS[solid,n]; 
      indlica = facetree[[1,1]]; maksi = ReplacePart[maksi, 
        Max[afaces[[indlica]]], indlica];  
      normal = ort[Cross[vertis[[afaces[[indlica]][[2]]]] - 
          vertis[[afaces[[indlica]][[1]]]], 
         vertis[[afaces[[indlica]][[3]]]] - vertis[[afaces[[indlica]][[
            1]]]]]]; normals = ReplacePart[normals, normal, indlica]; 
      len = Length[afaces[[indlica]]]; linija = (vertis[[#1]] & ) /@ 
        afaces[[indlica]];  linijaset = ReplacePart[linijaset, linija, 
        indlica]; len1 = Length[facetree]; linija = {};
      Do[indn = facetree[[i,2]]; indp = facetree[[i,1]]; 
        maksi = ReplacePart[maksi, Max[afaces[[indn]]], indn]; 
        {{p1}} = Position[afaces[[indp]], afaces[[indn,1]]]; 
        {{p2}} = Position[afaces[[indp]], afaces[[indn,2]]]; linija = {}; 
        poin1 = linijaset[[indp,p1]]; poin2 = linijaset[[indp,p2]]; 
        linija = Append[linija, poin1]; linija = Append[linija, poin2]; 
        len = Length[afaces[[indn]]]; edgeOrt = ort[poin2 - poin1]; 
        normalp = normals[[indp]]; edgs = EdgesOnFaces[afaces]; 
        {{indedge}} = Position[edgs, Sort[{afaces[[indn,1]], 
            afaces[[indn,2]]}]]; normaln = 
         Rot[edgeOrt,- ((Pi - dih[[indedge]])*ulomek)][normalp]; 
        normals = ReplacePart[normals, normaln, indn]; 
        Do[d1 = DistanceHI[vertis[[afaces[[indn,1]]]], 
            vertis[[afaces[[indn,k]]]]]; d2 = DistanceHI[
            vertis[[afaces[[indn,2]]]], vertis[[afaces[[indn,k]]]]]; 
          novatocka = TwoCirclesIntersectionNewHI3D[poin1, poin2, {d1, d2}, 
            normaln]; linija = Append[linija, novatocka], {k, 3,len}]; 
        linijaset = ReplacePart[linijaset, linija, indn], {i, 1, len1}]; 
      {linijaset, maksi}];

ort[x_] := x/Sqrt[x[[1]]^2 + x[[2]]^2 + x[[3]]^2];

DihedralS[telo_,n_] := Module[{c1, solid, f, edgs, v, e, i, pari,koor,normals,rezul,al,be}, 
     solid = telo; koor = solid[[2]]; c1 = solid[[1]]; f = Length[c1]; 
      normals = Table[ort[Cross[koor[[c1[[i]][[2]]]] - koor[[c1[[i]][[1]]]], 
          koor[[c1[[i]][[3]]]] - koor[[c1[[i]][[1]]]]]], {i, 1, f}];
      edgs = EdgesOnFaces[c1]; v = Length[Union[Flatten[c1]]];
      e = Length[edgs]; al=ArcCos[normals[[n+1]].normals[[2n+1]]];be=Pi-Chop[ArcCos[normals[[1]].normals[[n+1]]]];rezul= Table[If[Abs[(koor[[edgs[[i,1]]]]-koor[[edgs[[i,2]]]]).{0,0,1}]<0.0001,al+Pi,be], {i, 1, e}];rezul];

EdgesOnFaces[cic_] := Block[{edgs = {}, n = Length[cic], ed, i}, 
     Do[ed = EdgesOnFace[cic[[i]]]; edgs = Union[edgs, ed], {i, 1, n}]; 
      edgs = Union[Map[Sort, edgs, 1]]];

EdgesOnFace[lice_] := Module[{i,rez},rez= Table[{lice[[i]], lice[[i + 1]]}, 
       {i, 1, Length[lice] - 1}];AppendTo[rez, {Last[lice], First[lice]}]];

FacesOfEdge[{a_, b_}, c1_] := Module[{f, v, e}, f = Length[c1]; 
      v = Length[Union[Flatten[c1]]]; e = f + v - 2; 
      Select[Range[f], Length[Intersection[c1[[#1]], {a, b}]] == 2 & ]];

Rot[om_, al_][x_] := x . om*om + (x - x . om*om)*Cos[al] + 
     Cross[om, x]*Sin[al];

DistanceHI[{a_, b_, c_}, {x_, y_, z_}] := 
 Chop@ N[Sqrt[(a - x)^2 + (b - y)^2 + (c - z)^2]];

TwoCirclesIntersectionNewHI3D[{x1_, y1_, z1_}, {x2_, y2_, z2_}, {r1_, r2_}, 
     n_] := Module[{c, a, b, e}, 
     c = Sqrt[(x2 - x1)^2 + (y2 - y1)^2 + (z2 - z1)^2]; a = r2; b = r1; 
      e = ({x2, y2, z2} - {x1, y1, z1})/c; 
      ConstructTriangleHI3D[{x1, y1, z1}, e, n][a, b, c]];

ConstructTriangleHI3D[{x1_, y1_, z1_}, e_, n_][a_, b_, c_] := 
    Module[{p, hc, cosa, AB, x2, y2, x3, y3, z2, z3}, 
     p = (a + b + c)/2; hc = 2*(Chop@Sqrt[p*(p - a)*(p - b)*(p - c)]/c); 
      cosa = (b^2 + c^2 - a^2)/(2*b*c); AB = c*e; 
      {x2, y2, z2} = {x1, y1, y1} + AB; {x3, y3, z3} = 
       {x1, y1, z1} + (b*cosa)*e + Cross[n, e]*hc; {x3, y3, z3}];

ShowMrezaPS[p1_,drevo_,ulomek_,n_]:=Block[{tr2,lica3,stran,net},tr2=UrediTree2HI[drevo];stran=p1[[1]];
lica3=ChangeOrientation[tr2][stran];
net=NetOfConvex3DS[{lica3,p1[[2]]},tr2,ulomek,n];Map[Polygon,net[[1]]]];

telo1=antiprismDoub[1,0.03,5,3];drev=drevoS[5,3];

Manipulate[
With[{r=1,h=2},
Switch[act,
1,
With[{AB=Chop@Sqrt[r^2.(1-Cos[Pi/n])^2+(h/m)^2],bb=r Sin[Pi/n]},With[{aa=Line[{{0.,0},{r Sin[Pi/n],AB}}],cc=Line[{{2.r Sin[Pi/n],0},{r Sin[Pi/n],AB}}]},
Graphics[{Table[Translate[aa,i {2.bb,0}+j{0.,AB}+If[OddQ[j],{bb,0.},{0.,0}]],{i,0,n-1},{j,0,m-1}],
Table[Translate[cc,i {2bb,0.}+j{0.,AB}+If[OddQ[j],{-bb,0.},{0,0}]],{i,0,n-1},{j,0,m-1}],Table[Line[{{0,i AB},{n 2 bb,i AB}}],{i,1,m-1}],Line[{{0.,0},{2n bb,0.},{2 n bb,m AB},{0,m AB},{0.,0}}],Red,Line[{{0.,0},{2 Pi r,0},{2 Pi r, h},{0,h},{0,0}}]},ImageSize->{500,400}]]],
2,
Graphics3D[{ShowMrezaPS[telo1,drev,k1,n]},Boxed->False,ViewPoint->{4,1,1},PlotRange->All,ImageSize->{500,400},ViewAngle->15 Degree]
]],
Control[{{act,1,""},{1->"net comparison",2->"fold/unfold"}}],{{n,3,Row[{"units wide ",Style["n",Italic]}]},{3,4,5,6},Enabled->act==1},{{m,2,Row[{"units high ",Style["m",Italic]}]},2,40,1,Appearance->"Labeled",Enabled->act==1},{{k1,0,"fold/unfold"},0,1,0.001,Enabled->act==2},SaveDefinitions->True]

The 3D case has to allow n and m to vary, but there is an error. I added Chop in various place to get rid of the error but it didn't work. Please fix.

The 3D graphic was too small, so I made an exception and added PlotRange -> All.

Schwarz's polyhedron P is a stack of m n-antiprisms, each without a base. This Demonstration compares the net in the plane for P with the lateral side of the circumscribed cylinder (the red rectangle). For fixed n and m-> ∞, the area of the net (which equals the surface area of P) tends to ∞.

Cylinder Area Paradox

Contributed by: Izidor Hafner