Surface of Octahedron to Surface of Terahedron Dissection

vertices={{0,0,0},{1,0,0},{2,0,0},{0.5,Sqrt[3]/2,0},{1.5,Sqrt[3]/2,0},{2.5,Sqrt[3]/2,0},{1,Sqrt[3],0},{2,Sqrt[3],0},{3,Sqrt[3],0}};

lat1=GraphicsComplex[vertices,Polygon[{{1,2,4},{4,2,5},{2,3,5},{5,3,6},{4,5,7},{7,5,8},{8,5,6},{8,6,9}}]];

vertices2={{0,0,0},{Sqrt[2],0,0},{2Sqrt[2],0,0},{Sqrt[2]/2,Sqrt[6]/2,0},{3Sqrt[2]/2,Sqrt[6]/2,0},{5Sqrt[2]/2,Sqrt[6]/2,0}};

lat2=GraphicsComplex[vertices2,{Red,Line[{{1,2,4,1},{4,2,5,4},{2,3,5,2},{5,3,6,5}}]}];

intersection2lines[r1_,e1_,r2_,e2_]:=First[(r1+t e1)/.Solve[r1+t e1==r2+u e2,{t,u}]];

pt1=intersection2lines[vertices2[[4]],vertices2[[4]]-vertices[[3]],{2Sqrt[2]-2,0,0},vertices2[[4]]];

pt2=intersection2lines[vertices2[[4]],vertices2[[4]]-vertices[[3]],vertices2[[2]],vertices2[[4]]];

smalltr={Blue,Thickness[0.01],Line[{vertices2[[4]],vertices2[[4]]+{1,0,0}(2Sqrt[2]-2),pt1,vertices2[[4]]}]};

pt1N=vertices[[3]]+vertices2[[4]]-pt1;

pt2N=vertices2[[4]]+pt2-pt1;

pt3N=intersection2lines[pt2N,vertices2[[4]],vertices[[7]],{1,0,0}];

pt4N=intersection2lines[pt1N,{1,0,0},vertices[[3]],vertices[[4]]];

vr={vertices2[[1]],vertices2[[2]],vertices[[3]],pt2,pt1N,pt4N,pt2N,vertices2[[4]],vertices[[7]],pt3N,vertices[[9]]};

pla1=intersection2lines[vertices2[[4]],vertices2[[4]]-vertices2[[2]],vertices[[2]],vertices[[4]]];

pla2=intersection2lines[vertices2[[4]],vertices2[[4]]-vertices[[3]],vertices[[2]],vertices[[4]]];
pla3=intersection2lines[vertices2[[4]],vertices2[[4]]-vertices2[[2]],vertices[[4]],vertices[[2]]];
pla4=intersection2lines[vr[[3]],vr[[3]]-vr[[9]],vr[[5]],vr[[5]]-vr[[6]]];

pla5=intersection2lines[vr[[6]],vr[[10]]-vr[[6]],vertices[[4]],{1,0,0}];

pla6=intersection2lines[vr[[3]],vr[[3]]-vr[[9]],vr[[7]],vr[[10]]-vr[[7]]];

pla7=intersection2lines[vr[[6]],vr[[10]]-vr[[6]],vertices[[2]],vertices[[4]]];

vertn=Join[vr,{pla1,pla2,pla3,pla4,pla5,pla6,pla7,vertices[[2]],vertices[[4]],vertices[[5]],vertices[[6]],vertices[[8]]}];

p1p1={Red,Polygon[{vertn[[1]],vertn[[19]],vertn[[20]]}]};
p2p1={RGBColor[0.105882, 0.105882, 0.537255],Polygon[{vertn[[20]],vertn[[19]],vertn[[12]],vertn[[14]]}]};
p2p2={RGBColor[0.156863, 0.156863, 0.792157],Polygon[{vertn[[14]],vertn[[12]],vertn[[13]],vertn[[7]]}]};
p2p3={RGBColor[0.345098, 0.345098, 0.870588],Polygon[{vertn[[7]],vertn[[13]],vertn[[21]]}]};
p3p1={RGBColor[0.133333, 0.403922, 0.0941176],Polygon[{vertn[[12]],vertn[[19]],vertn[[2]]}]};
p3p2={RGBColor[0.211765, 0.643137, 0.14902],Polygon[{vertn[[12]],vertn[[2]],vertn[[4]],vertn[[13]]}]};
p3p3={RGBColor[0.345098, 0.835294, 0.27451],Polygon[{vertn[[2]],vertn[[3]],vertn[[4]]}]};
p3p4={RGBColor[0.490196, 0.870588, 0.439216],Polygon[{vertn[[5]],vertn[[3]],vertn[[15]]}]};
p3p5={RGBColor[0.717647, 0.929412, 0.686275],Polygon[{vertn[[5]],vertn[[15]],vertn[[21]],vertn[[13]]}]};
p4p1={RGBColor[0.403922, 0.129412, 0.203922],Polygon[{vertn[[15]],vertn[[3]],vertn[[6]]}]};
p4p2={RGBColor[0.780392, 0.313725, 0.443137],Polygon[{vertn[[15]],vertn[[6]],vertn[[16]],vertn[[21]]}]};
p4p3={RGBColor[0.854902, 0.537255, 0.623529],Polygon[{vertn[[16]],vertn[[6]],vertn[[22]]}]};
p5p1={RGBColor[0.52549, 0.372549, 0.0823529],Polygon[{vertn[[20]],vertn[[14]],vertn[[8]]}]};
p5p2={RGBColor[0.8, 0.560784, 0.12549],Polygon[{vertn[[8]],vertn[[14]],vertn[[7]]}]};
p5p3={RGBColor[0.886275, 0.670588, 0.270588],Polygon[{vertn[[8]],vertn[[7]],vertn[[17]],vertn[[9]]}]};
p5p4={RGBColor[0.917647, 0.760784, 0.47451],Polygon[{vertn[[7]],vertn[[21]],vertn[[17]]}]};
p6p1={RGBColor[0, 0.541176, 0.541176],Polygon[{vertn[[9]],vertn[[17]],vertn[[10]]}]};
p6p2={RGBColor[0, 0.866667, 0.866667],Polygon[{vertn[[17]],vertn[[21]],vertn[[18]],vertn[[10]]}]};
p6p3={RGBColor[0.384314, 1, 1],Polygon[{vertn[[10]],vertn[[18]],vertn[[23]]}]};
p7p1={RGBColor[1, 0.258824, 0.258824],Polygon[{vertn[[21]],vertn[[16]],vertn[[18]]}]};
p7p2={RGBColor[1, 0.541176, 0.541176],Polygon[{vertn[[18]],vertn[[16]],vertn[[22]],vertn[[23]]}]};
p8p1={RGBColor[0.843137, 0.843137, 0],Polygon[{vertn[[22]],vertn[[11]],vertn[[23]]}]};

al2=Pi-1.9106332362490186`;

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

octahedron[r1_,r2_]:=Module[{},Graphics3D[{Rotate[{Rotate[{Rotate[p1p1,r2 al2,vertn[[20]]-vertn[[19]],vertn[[19]]],Rotate[{p5p1,p5p2,p5p3,p5p4},r2 al2,vertn[[21]]-vertn[[20]],vertn[[20]]],p2p1,p2p2,p2p3},r2 al2,vertn[[21]]-vertn[[19]],vertn[[19]]],p3p1,p3p2,p3p3,p3p4,p3p5},r2 al2,vertn[[21]]-vertn[[3]],vertn[[3]]],p4p1,p4p2,p4p3,Rotate[{Rotate[Translate[{p6p1,p6p2,p6p3},r1(vertn[[3]]-vertn[[9]])],-r2 al2,vertn[[19]]-vertn[[1]],vertn[[3]]],Rotate[Rotate[{p7p1,p7p2},-Pi r1,{0,0,1},vertn[[22]]],-r2 al2,vertn[[20]]-vertn[[19]],vertn[[22]]],Rotate[p8p1,-Pi r1,{0,0,1},vertn[[22]]]},-r2 al2,vertn[[22]]-vertn[[3]],vertn[[3]]]},ImageSize->{480,450},ViewPoint->{0,0,5},ViewVertical->{0,1,0},PlotRange->{{-0.1,3.6},{-2,3.5},{-2,3.5}},Boxed->False]];

tetrahedron[r1_,r2_]:=Module[{},Graphics3D[{Rotate[{Rotate[{p1p1,p2p1,p3p1,p5p1},r2 al1,vertn[[8]]-vertn[[2]],vertn[[2]]],{Translate[p3p4,r1(vertn[[8]]-vertn[[5]])],Translate[p4p1,r1(vertn[[8]]-vertn[[5]])],p2p2,p3p2,p5p2,Translate[{p5p3,p6p1},r1(vertn[[3]]-vertn[[5]])]}},r2 al1,vertn[[4]]-vertn[[2]],vertn[[2]]],{p3p3,Translate[{p2p3,p3p5,p4p2,p5p4,p6p2,p7p1},r1(vertn[[3]]-vertn[[5]])]},Rotate[Translate[{p4p3,p6p3,p7p2,p8p1},r1(vertn[[3]]-vertn[[5]])],-r2 al1,vertices2[[5]]-vertices2[[3]],vertices2[[3]]]},ImageSize->{480,450},ViewPoint->{0,0,5},ViewVertical->{0,1,0},PlotRange->{{-0.1,3.6},{-2,3.5},{-2,3.5}},Boxed->False]];

Manipulate[If[poly==1,octahedron[r1,r2],tetrahedron[r1,r2]],Control[{{poly,1,""},{1->"Octahedron",2->"Tetrahedron"}}],{{r1,0,"make net"},0,1,0.01,Enabled->r2==0},{{r2,0,"fold/unfold"},0,1,Enabled->r1==1},SaveDefinitions->True]

The Demonstration shows surface of octahedron to surface of tetrahedron dissection.

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

Contributed by: Izidor Hafner