Surface of a Cube to Surface of Tetrahedron Dissection

orthon[r_]:=Normalize[{r[[2]],-r[[1]],r[[3]]}];intersection2lines[r1_,e1_,r2_,e2_]:=First[(r1+t e1)/.Solve[r1+t e1==r2+u e2,{t,u}]];transl[v1_][r_]:=r+v1;cubenet=GraphicsComplex[{{-4,3,0},{-2,3,0},{0,3,0},{-4,1,0},{-2,1,0},{0,1,0},{2,1,0},{-2,-1,0},{0,-1,0},{2,-1,0},{4,-1,0},{0,-3,0},{2,-3,0},{4,-3,0}},Polygon[{{1,4,5,2},{2,5,6,3},{5,8,9,6},{6,9,10,7},{9,12,13,10},{10,13,14,11}}]];

al1=Pi-ArcSec[3]//N;

pt=cubenet[[1]];

b=Sqrt[8Sqrt[3]]//N;

p1={-Sqrt[b^2-3^2],3,0};

p2={0,0,0};
p3={Sqrt[b^2-3^2],-3,0};

p4=p1/2+orthon[p1]b Sqrt[3]/2;

p5=p3/2+orthon[p1]b Sqrt[3]/2;

p6=p5+p3;

p7=intersection2lines[p1,p2-p1,{-2,1,0},{0,1,0}];

p8=intersection2lines[p1,p2-p1,{0,1,0},{1,0,0}];

p9=intersection2lines[p1,p2-p1,{0,-1,0},{1,0,0}];

p10=intersection2lines[p1,p2-p1,{2,-1,0},{0,1,0}];

p11=intersection2lines[p4,p2-p1,{0,3,0},{1,0,0}];

p12=intersection2lines[p4,p2-p1,{2,1,0},{0,1,0}];

p13=intersection2lines[p4,p2-p1,{0,1,0},{1,0,0}];

p14={4,0,0};

p15=intersection2lines[p4,p2-p1,{0,-1,0},{1,0,0}];

p16=intersection2lines[p4,p2-p1,{6,0,0},{0,1,0}];

p17=intersection2lines[p4,p2-p1,{0,-3,0},{1,0,0}];

p18=intersection2lines[p6,p2-p4,{0,-3,0},{1,0,0}];

p19=intersection2lines[p4,p2-p4,{0,3,0},{1,0,0}];

p20=intersection2lines[p4,p2-p4,{0,1,0},{1,0,0}];

p21=intersection2lines[p5,p2-p5,{2,-1,0},{0,1,0}];

p22=intersection2lines[p5,p3-p5,{0,-1,0},{1,0,0}];

p23=intersection2lines[p6,p3-p6,{4,-3,0},{0,1,0}];

p23B=p23+{-4,0,0};

p22B=transl[{-4,0,0}][p22];

p21B=transl[{-4,0,0}][p21];

p20B=transl[{-4,0,0}][p20];

p19B=transl[{-4,0,0}][p19];

p18B=transl[{-4,0,0}][p18];p17B=transl[{-4,0,0}][p17];p16B=transl[{-4,0,0}][p16];p15B=transl[{-4,0,0}][p15];p14B=transl[{-4,0,0}][p14];p13B=transl[{-4,0,0}][p13];p12B=transl[{-4,0,0}][p12];p11B=transl[{-4,0,0}][p11];
p4B=transl[{-4,0,0}][p4];p5B=transl[{-4,0,0}][p5];p6B=transl[{-4,0,0}][p6];

tetranet=GraphicsComplex[{p1,p2,p3,p4,p5,p6},Polygon[{{1,2,4},{4,2,5},{2,3,5},{3,6,5}}]];

Manipulate[If[poly==1,Module[{},Graphics3D[{Rotate[{Rotate[{Rotate[{a1,a2,a3},r1 Pi/2,{0,1,0},{-2,1,0}],{b1,b2}},r1 Pi/2,{1,0,0},{-2,1,0}],{c1,c2,c3,c4}},r1 Pi/2,{0,1,0},{0,0,0}],{d1,d2,d3,d4},Rotate[{{e1,e2,e3,e4},Rotate[{f1,f2,f3,f4},-r1 Pi/2,{0,1,0},{2,-3,0}]},-r1 Pi/2,{1,0,0},{0,-1,0}]},ImageSize->{480,420},PlotRange->6,SphericalRegion->True,Boxed->False]],Module[{},Graphics3D[{Rotate[{Rotate[{Translate[a1,4k {1,0,0}],a3,b1,c3,d1,Translate[Translate[e2,4k {1,0,0}],k(p1-p3)],Translate[f4,k(p1-p3)]},r1 al1,p4-p2,p2],{Translate[a2,4k {1,0,0}],Translate[b2,4k {1,0,0}],Translate[c1,4k {1,0,0}],d3,Translate[Translate[e3,4k {1,0,0}],k(p1-p3)],Translate[Translate[f2,4k {1,0,0}],k(p1-p3)]}},r1 al1,p5-p2,p2],{Translate[c2,4k {1,0,0}],d4,e4,f1},Rotate[{Translate[c4,4k {1,0,0}],Translate[d2,4k {1,0,0}],Translate[e1,4k {1,0,0}],f3},-r1 al1,p5-p3,p3]},ImageSize->{480,420},Boxed->False,PlotRange->6,SphericalRegion->True]]],Control[{{poly,1,""},{1->"Cube",2->"Tetrahedron"}}],{{k,0,"cube net into tetrahedron net"},0,1,Enabled->poly==2},{{r1,0,"fold/unfold"},0,1,Enabled->Implies[poly==2,k==1]},SaveDefinitions->True,Initialization:>(a1={Red,Polygon[{pt[[1]],pt[[4]],p20B,p19B}]};a2={Blue,Polygon[{p20B,pt[[5]],p7,p1,p19B}]};a3={Yellow,Polygon[{p1,p7,pt[[2]]}]};b1={Magenta,Polygon[{pt[[2]],p7,p8,pt[[6]],pt[[3]]}]};b2={Brown,Polygon[{p7,pt[[5]],p8}]};c1={Pink,Polygon[{pt[[5]],p21B,p5B,p8}]};c2={LightBlue,Polygon[{p5B,p21B,pt[[8]],p22B}]};c3={Orange,Polygon[{pt[[6]],p8,p2}]};c4={Green,Polygon[{p5B,p22B,pt[[9]],p2}]};d1={RGBColor[0, 0.25098, 0.501961],Polygon[{p20,pt[[6]],p2}]};d2={RGBColor[0.25098, 0.501961, 0.501961],Polygon[{p2,pt[[9]],p9}]};d3={RGBColor[1, 0, 0.501961],Polygon[{pt[[7]],p20,p2,p21}]};d4={RGBColor[0, 0.501961, 0.25098],Polygon[{p21,p2,p9,pt[[10]]}]};e1={RGBColor[0, 1, 1],Polygon[{p9,pt[[9]],p23B,p6B}]};e2={RGBColor[0.733333, 0.254902, 0.745098],Polygon[{p23B,pt[[12]],p18B,p6B}]};e3={RGBColor[0.501961, 0.501961, 0],Polygon[{p6B,p18B,pt[[13]],p10}]};e4={RGBColor[0.501961, 0, 0.25098],Polygon[{p9,p10,pt[[10]]}]};f1={RGBColor[0, 0.501961, 0.501961],Polygon[{p22,pt[[10]],p10,p3}]};f2={RGBColor[0.756863, 0.517647, 0.517647],Polygon[{p10,pt[[13]],p3}]};f3={RGBColor[0.25098, 0.501961, 0.501961],Polygon[{p22,p3,p23,pt[[11]]}]};f4={RGBColor[1, 0.32549, 1],Polygon[{p23,p3,pt[[14]]}]};)]

The Demonstration shows  dissection of a surface of a cube to a surface of a tetrahedron.

G. N. Frederickson, Dissections: Plane & Fancy, New York: Cambridge University Press, 2002 p. 246.

Contributed by: Izidor Hafner