Polyeder-Werkstatt mit Mathematica

Eine Illustration der Möglichkeiten auf der Basis der Theorie im Script über Architekturmaterial, abrufbar über die Home-Page des Autors

Script vgl. unter  ===>   http://www.hta-bi-bfh.ch/~wir/Scripts/Scripts.html

von Rolf Wirz

A. Generieren von Polytopen mit dem Mathematica-Package

Off[General::spell]

Package laden zu Polyedern und Sternformen und anwenden

<<Graphics`Polyhedra`

?*hedoron

?Graphics`Polyhedra`*

Tetraeder

Show[Polyhedron[Tetrahedron]];

Show[Polyhedron[Tetrahedron], 
        ViewPoint -> {-0.0,  -0.0, 1000}];

Hexaeder

Show[Polyhedron[Hexahedron]];

Show[Polyhedron[Hexahedron], 
        ViewPoint -> {-0.0,  -0.0, 1000}];

Oktaeder

Show[Polyhedron[Octahedron], ViewPoint -> {50, 35, 30}];

Show[Polyhedron[Octahedron]];

Show[Polyhedron[Octahedron], 
        ViewPoint -> {-0.0,  -0.0, 1000}];

Dodekaeder

Show[Polyhedron[Dodecahedron]];

Show[Polyhedron[Dodecahedron], 
        ViewPoint -> {-0.0,  -0.0, 5}];

Show[Polyhedron[Dodecahedron], 
        ViewPoint -> {0.0,  0.0, 1000}];

Show[Polyhedron[Dodecahedron], 
        ViewPoint -> {0.0,  0.0, -1000}];

Umhülltes Ikosaeder (Dodekaederstern ???)

Show[Polyhedron[GreatDodecahedron]];

Keplerstern

Show[Polyhedron[SmallStellatedDodecahedron]];

Ikosaederstern ???

Show[Polyhedron[GreatStellatedDodecahedron]];

Ikosaeder

Show[Polyhedron[Icosahedron]];

Show[Polyhedron[Icosahedron], 
        ViewPoint -> {0.0,  0.0, 1000}];

Show[Polyhedron[Icosahedron], 
        ViewPoint -> {0.0,  0.0, -1000}];

Poinsots Vielflächenstern

Show[Polyhedron[GreatIcosahedron]];

? Bindelstern ???

? Paravallestern ???

? Tetraederfümfling ???

? Weitere Fümflinge ???

? Hüllsterne ???

Spezialitäten und Animationen

?Geodesate

?Stellate

?Truncate

?OpenTruncate

?*hedoron

Show[Geodesate[Polyhedron[Dodecahedron], 4]];

Show[Geodesate[Polyhedron[Dodecahedron], 5]];

Animationen: ===> Animate selected Graphics in "Cell"   !!!!

Table[
        Show[Stellate[Polyhedron[Icosahedron], 0.2 k]], {k, 0, 
          30}];

Table[
        Show[Truncate[Polyhedron[Dodecahedron], 0.5/30 k]], {k, 0, 
          30}];

Table[
        Show[OpenTruncate[Polyhedron[Dodecahedron], 1.0/ k]], {k, 2, 
          15}];

Show[OpenTruncate[Polyhedron[Dodecahedron], 1.0/ 2]];

Show[OpenTruncate[Polyhedron[Icosahedron], 1.0/ 2]];

ViewPoint-Animation: Flug über das Objekt

Table[
        Show[Polyhedron[GreatDodecahedron], 
          ViewPoint -> {5 Sin[2 Pi/20 k], 5 Cos[2 Pi/20 k], 
              2 + Cos[2 Pi/20 k]}], {k, 0, 19}];

Package laden zu Polytopen (n-Ecke)

<< Geometry`Polytopes`

?Geometry`Polytopes`*

$Packages

$Path

$BaseDirectory

$UserBaseDirectory

Flächen

<< Graphics`Shapes`

?Graphics`Shapes`*

B. Eigenbau, Verständnis der Zusammenhänge beim Generieren, mit vielen Entwicklungsschritten, die später weggelassen werden können

Achtung: Warnmeldungen wegen ähnlichen Variablennamen, nicht gefährlich!

Darstellungsarten:

Eckenmodelle

Kantenmodelle

Diagonalenmodelle

Aussenflächenmodelle

Symmetreieflächenmodelle

Sehnenflächenmodelle

Sternformenmodelle

Durchdringungsmodelle

Schnittmodelle

Hüllenmodelle von Sternformen

Kombinationen solcher Möglichkeiten

Projektionen, Animationen, ......

Abwicklungen

Modelle nach eigene Ideen

Einfache Möglichkeit: Würfel aus dem Prisma heraus

Berechnungen zum Würfel:

sW = Kantenlänge

volW = sW^3; 
diagFW = Sqrt[2] sW;  
diagVW = Sqrt[3] sW; 
rUW =  diagVW/2;
rIW = sW/2;
 rKW =  diagVW/2;  obW = 6 sW^2;

Graphik

pB[k_] := {(-1)^(Floor[(k + 1)/
                2]), (-1)^(Floor[k/2])}

taG = Table[pB[k], {k, 0, 3}]

lift[k_, vec_] := Append[vec, k]

taW = 
      Flatten[Table[
          Append[taG[[n]], k], {n, 1, Length[taG]}, {k, -1, 1, 2}], 
        1]

taW = 
      Join[Table[Append[taG[[n]], -1], {n, 1, Length[taG]}], 
        Table[Append[taG[[n]], 1], {n, 1, Length[taG]}]]

wue = Wuerfel; tet = Tetraeder; tetN = TetraederNeg; okt = Oktaeder; 
    dod = Dodekaeder; iko = Ikosaeder;

p[k_, wue] := taW[[k]];
pointW = 
      Prepend[Table[Point[p[k, wue]], {k, 1, Length[taW]}], 
        PointSize[0.03]]

pz[k_, wue, z_] := taW[[k]] z;
pointWz[z_] := 
      Prepend[Table[Point[pz[k, wue, z]], {k, 1, Length[taW]}], 
        PointSize[0.03]]

lW = Table[p[k, wue], {k, 1, Length[taW]}]

Show[Graphics3D[{pointW, Line[lW]}]];

Options[Graphics3D]

lin2[n_, m_, u_] := Line[{p[n, u], p[m, u]}]; 
    lin3[n_, m_, k_, u_] := Line[{p[n, u], p[m, u], p[k, u]}]; 
    lin4[n_, m_, k_, s_, u_] := Line[{p[n, u], p[m, u], p[k, u], p[s, u]}];  
    lin5[n_, m_, k_, s_, t_, u_] := 
      Line[{p[n, u], p[m, u], p[k, u], p[s, u], p[t, u]}]; 
    lin6[n_, m_, k_, s_, t_, v_, u_] := 
      Line[{p[n, u], p[m, u], p[k, u], p[s, u], p[t, u], 
          p[v, u]}];
linz2[n_, m_, u_, z_] := Line[{p[n, u], p[m, u]} z]; 
    linz3[n_, m_, k_, u_, z_] := Line[{p[n, u], p[m, u], p[k, u]} z]; 
    linz4[n_, m_, k_, s_, u_, z_] := 
      Line[{p[n, u], p[m, u], p[k, u], p[s, u]} z];  
    linz5[n_, m_, k_, s_, t_, u_, z_] := 
      Line[{p[n, u], p[m, u], p[k, u], p[s, u], p[t, u]} z];

wuerfel1 = 
        Show[Graphics3D[{pointW, lin5[1, 2, 3, 4, 1, wue], 
              lin5[5, 6, 7, 8, 5, wue], lin2[1, 5, wue], lin2[2, 6, wue], 
              lin2[3, 7, wue], lin2[4, 8, wue]}, Axes -> False, 
            AxesEdge -> None, Boxed -> False]];

nimm1 = wuerfel1;

wuerfelF1 = 
        Show[Graphics3D[{pointW, lin5[1, 2, 3, 4, 1, wue], 
              lin5[5, 6, 7, 8, 5, wue], lin2[1, 5, wue], lin2[2, 6, wue], 
              lin2[3, 7, wue], lin2[4, 8, wue], lin2[1, 3, wue], 
              lin2[2, 4, wue], 
lin2[1, 6, wue], 
              lin2[2, 5, wue], 
lin2[2, 7, wue], 
              lin2[3, 6, wue], 
lin2[3, 8, wue], 
              lin2[4, 7, wue], 
lin2[4, 5, wue], 
              lin2[1, 8, wue], 
lin2[5, 7, wue], 
              lin2[6, 8, wue]}, 
Axes -> False, 
            AxesEdge -> None, Boxed -> False]];

Tetraeder aus dem Würfel heraus

Berechnungen zum Tetraeder:

{Sqrt[1^2 - (1/2)^2], 
      Sqrt[1^2 - (2/3 Sqrt[3]/2)^2]}

sT = Kantenlänge

HoeheFT = sT Sqrt[3]/2; 
    HoeheVT = sT Sqrt[2/3];
sT = diagFW; diagFT = HoeheFT;  rUT = 2/3  HoeheVT; 
    rIT = 1/4 *HoeheVT;  rK = Sqrt[rIT^2 + (1/3  HoeheFT^2)]; 
    volT = sT *HoeheFT/2  *HoeheVT/3;  
    obT =  4 *sT *HoeheFT/2;
volT1 = sW^3 - 4*sW*sW/2*sW/3;

Graphik zum Tetraeder:

p[k_ /; k < 3, tet] := p[2 k, wue]; 
    p[k_ /; k >= 3, tet] := p[2 k - 1, wue];
p[k_ /; k < 3, tetN] := p[2 k - 1, wue]; 
    p[k_ /; k >= 3, tetN] := p[2 k, wue];
p2m[n_, m_, u_] := (p[n, u] + p[m, u])/2;  
    p3m[n_, m_, s_, u_] := (p[n, u] + p[m, u] + p[s, u])/3; 
    p4m[n_, m_, s_, t_, u_] := (p[n, u] + p[m, u] + p[s, u] + p[t, u])/4; 
    p5m[n_, m_, s_, t_, q_, 
        u_] := (p[n, u] + p[m, u] + p[s, u] + p[t, u] + p[q, u])/5; 
    lin2m[t_, n_, m_, u_] := Line[{p2m[n, m, u], p[t, u]}];

pointT = 
      Prepend[Table[Point[p[k, tet]], {k, 1, 4}], PointSize[0.04]]

pointTNeg = 
      Prepend[Table[Point[-p[k, tet]], {k, 1, 4}], 
        PointSize[0.04]]

tetraeder1 = 
        Show[Graphics3D[{pointT, lin5[1, 2, 3, 4, 1, tet], lin2[1, 3, tet], 
              lin2[2, 4, tet]}, Axes -> False, AxesEdge -> None, 
            Boxed -> False]];

tetraeder2 = 
        Show[Graphics3D[{pointTNeg, lin5[1, 2, 3, 4, 1, tetN], 
              lin2[1, 3, tetN], lin2[2, 4, tetN]}, Axes -> False, 
            AxesEdge -> None, Boxed -> False]];

Show[tetraeder1, wuerfel1];

Show[tetraeder1, tetraeder2, wuerfel1];

Show[tetraeder1, tetraeder2];

pointTNegIn = 
      Prepend[Table[Point[-p[k, tet]/3], {k, 1, 4}], 
        PointSize[0.04]]

tetraeder3 = 
        Show[Graphics3D[{pointT, pointTNegIn, lin5[1, 2, 3, 4, 1, tet], 
              lin2[1, 3, tet], lin2[2, 4, tet], 
              linz5[1, 2, 3, 4, 1, tetN, 1/3], linz2[1, 3, tetN, 1/3], 
              linz2[2, 4, tetN, 1/3]}, Axes -> False, 
            AxesEdge -> None, Boxed -> False]];

tetraeder4 = 
        Show[Graphics3D[{pointT, pointTNegIn, lin5[1, 2, 3, 4, 1, tet], 
              lin2[1, 3, tet], lin2[2, 4, tet], 
              linz5[1, 2, 3, 4, 1, tetN, 1/3], linz2[1, 3, tetN, 1/3], 
              linz2[2, 4, tetN, 1/3], lin2m[1, 2, 3, tet], 
              lin2m[1, 2, 4, tet], lin2m[1, 3, 4, tet], lin2m[2, 1, 3, tet], 
              lin2m[2, 1, 4, tet], lin2m[2, 3, 4, tet], lin2m[3, 1, 2, tet], 
              lin2m[3, 1, 4, tet], lin2m[3, 2, 4, tet], lin2m[4, 1, 2, tet], 
              lin2m[4, 1, 3, tet], lin2m[4, 2, 3, tet]}, Axes -> False, 
            AxesEdge -> None, Boxed -> False]];

sW = 2;
zW = 1/( diagVW/2) *rIT

wuerfelT2 = 
        Show[Graphics3D[{pointWz[zW], linz5[1, 2, 3, 4, 1, wue, zW], 
              linz5[5, 6, 7, 8, 5, wue, zW], linz2[1, 5, wue, zW], 
              linz2[2, 6, wue, zW], linz2[3, 7, wue, zW], 
              linz2[4, 8, wue, zW], 
lin2m[1, 2, 3, tet], 
              lin2m[1, 2, 4, tet], lin2m[1, 3, 4, tet], lin2m[2, 1, 3, tet], 
              lin2m[2, 1, 4, tet], lin2m[2, 3, 4, tet], lin2m[3, 1, 2, tet], 
              lin2m[3, 1, 4, tet], lin2m[3, 2, 4, tet], lin2m[4, 1, 2, tet], 
              lin2m[4, 1, 3, tet], lin2m[4, 2, 3, tet]}, Axes -> False, 
            AxesEdge -> None, Boxed -> False]];

Show[tetraeder1, wuerfelT2];

Oktaeder aus dem Würfel heraus

Berechnungen zum Oktaeder:

sO = Sqrt[2]/2 sW;  diagVO = sW; 
    diagFO =  Sqrt[3]/2 sO;
rUO = sW/2;    HoeheVO = diagVO/2 ;  volO = 2 sO^2  HoeheVO/3; 
    obO = 8 sO diagFO /2;  HoeheFO = sO Sqrt[1^2 - (1/2)^2]; 
    rIO =  Sqrt[(sO/2)^2 - ( HoeheFO/3)^2];  
    rKO = sO/2;

Graphik zum Oktaeder:

p[1, okt] = p4m[1, 2, 3, 4, wue]; p[2, okt] = p4m[1, 2, 6, 5, wue]; 
    p[3, okt] = p4m[2, 3, 7, 6, wue]; p[4, okt] = p4m[3, 4, 8, 7, wue]; 
    p[5, okt] = p4m[4, 1, 5, 8, wue]; 
    p[6, okt] = p4m[5, 6, 7, 8, wue];

pointO = 
      Prepend[Table[Point[p[k, okt]], {k, 1, 6}], PointSize[0.04]]

oktaeder1 = 
        Show[Graphics3D[{pointO, lin6[1, 2, 3, 4, 5, 6, okt], 
              lin2[1, 3, okt], lin2[1, 4, okt], lin2[1, 5, okt], 
              lin2[2, 5, okt], lin2[2, 6, okt], lin2[3, 6, okt], 
              lin2[4, 6, okt]}, Axes -> False, AxesEdge -> None, 
            Boxed -> False]];

oktaeder2 = 
        Show[Graphics3D[{pointO, lin6[1, 2, 3, 4, 5, 6, okt], 
              lin2[1, 3, okt], lin2[1, 4, okt], lin2[1, 5, okt], 
              lin2[2, 5, okt], lin2[2, 6, okt], lin2[3, 6, okt], 
              lin2[4, 6, okt], lin2[1, 6, okt], lin2[2, 4, okt], 
              lin2[3, 5, okt]}, Axes -> False, AxesEdge -> None, 
            Boxed -> False]];

Show[oktaeder1, wuerfel1];

Show[oktaeder2, wuerfel1];

Show[oktaeder2, wuerfel1, tetraeder1];

Show[oktaeder2, wuerfelF1];

sW = 2;
zW = 1/(diagVW/2) *rIO

HoeheVO

rIO

pmm[1] = p4m[1, 2, 3, 4, wue]; pmm[3] = p4m[1, 2, 5, 6, wue]; 
    pmm[5] = p4m[2, 3, 6, 7, wue]; pmm[4] = p4m[3, 4, 7, 8, wue]; 
    pmm[6] = p4m[4, 1, 8, 5, wue]; 
    pmm[2] = p4m[5, 6, 7, 8, wue];
lin3mm[n_, m_] := Line[{pmm[n], pmm[m]}];

wuerfelO2 = 
        Show[Graphics3D[{pointWz[zW], linz5[1, 2, 3, 4, 1, wue, zW], 
              linz5[5, 6, 7, 8, 5, wue, zW], linz2[1, 5, wue, zW], 
              linz2[2, 6, wue, zW], linz2[3, 7, wue, zW], 
              linz2[4, 8, wue, zW], lin3mm[1, 2], lin3mm[3, 4], 
              lin3mm[5, 6]}, Axes -> False, AxesEdge -> None, 
            Boxed -> False]];

Show[oktaeder2, wuerfelO2];

Oktaeder aus dem Tetraeder heraus

lin2mT[n_, m_] := Line[{pTm[n], pTm[m]}];

pTm[1] = p2m[1, 2, tet]; pTm[2] = p2m[1, 3, tet]; 
    pTm[3] = p2m[1, 4, tet]; pTm[4] = p2m[2, 3, tet]; 
    pTm[5] = p2m[2, 4, tet]; pTm[6] = p2m[3, 4, tet];

pointTm = 
        Prepend[Table[Point[pTm[k]], {k, 1, 6}], 
          PointSize[0.05]];

tetraeder1 = 
        Show[Graphics3D[{pointT, lin5[1, 2, 3, 4, 1, tet], lin2[1, 3, tet], 
              lin2[2, 4, tet], pointTm, 
lin2mT[1, 2], 
              lin2mT[1, 3], lin2mT[1, 4], lin2mT[1, 5], lin2mT[2, 3], 
              lin2mT[2, 4], lin2mT[3, 5], lin2mT[4, 5], lin2mT[2, 6], 
              lin2mT[3, 6], lin2mT[4, 6], lin2mT[5, 6]}, Axes -> False, 
            AxesEdge -> None, Boxed -> False]];

Dodekaeder aus dem Würfel heraus

sD = sW  (Sqrt[5] - 1)/2;   
Print["sW = ", sW // N];

    
s5Dod = sD;    
Print["s5Dod=sD = ", 
      sD // N];

diag2Dod = 
      s5Dod (1 + Sqrt[5])/2;     
Print["diag2Dod = \
", diag2Dod // N];

s6Dod = 
      s5Dod/Sqrt[1 + ((Sqrt[5] - 1)/2)^2];    
Print["s6Dod = ", 
      s6Dod // N];

rFDod = s6Dod;    
Print["rFDod = ", 
      rFDod // N];

Hs6Dod = 
      Sqrt[s6Dod^2 - (s5Dod/
                2)^2];     
Print["Hs6Dod = ", 
      Hs6Dod // N];

Hs2Dod = 
      Sqrt[s5Dod ^2 - (diag2Dod/
                2)^2];   
Print["Hs2Dod = ", 
      Hs2Dod // N];

dKipp = 
        s6Dod - Hs2Dod; 
  
Print["dKipp = ", dKipp // N];

    
φ1 = ArcSin[dKipp/(diagFW/2)] // Simplify // 
          N;
φ = 
        ArcSin[dKipp/(diagFW/2)];

      
Print["φ Winkeldifferenz = ", (φ1 /(2  
                    Pi) 360. ) // 
          N, " Grad"];

    
φ2 = -Pi/4 + φ;
Print["φ2 Kipp = ", (φ2 /(2  
                    Pi) 360. ) // 
          N, " Grad"];

  
Print["Halbe Flächendiagonale Würfel = ", 
        diagFW/2 // N];

N[%]

{{1, 0, 0}, {0, 
              Cos[- φ2], -Sin[- φ2]}, {0, 
              Sin[- φ2], Cos[- φ2]}} // N // 
        MatrixForm;

{{Cos[α], -Sin[α], 0}, {Sin[α], 
              Cos[α], 0}, {0, 0, 1}} // N // 
        MatrixForm;

pKipp[k_, α_, 
          wue] := {{Cos[α], -Sin[α], 0}, {Sin[α], 
              Cos[α], 0}, {0, 0, 
              1}} . ({{1, 0, 0}, {0, 
                  Cos[-φ2], -Sin[-φ2]}, {0, 
                  Sin[-φ2], Cos[-φ2]}} . 
              p[k, wue]);

p[1, wue];

pointWKipp[α_] := 
        Prepend[Table[Point[pKipp[k, α, wue]], {k, 1, Length[taW]}], 
          PointSize[0.03]];

pointWKipp[0] // N;

pointD = Table[pointWKipp[k 2  Pi/5], {k, 1, 1}] // N;

Show[
        Graphics3D[{pointD}, Axes -> False, AxesEdge -> None, 
          Boxed -> False]];

pointD = Table[pointWKipp[α 2  Pi/5], {α, 1, 5}]; 
    Show[Graphics3D[{pointD}, Axes -> False, AxesEdge -> None, 
        Boxed -> False]];

?Round

pointWKipp1[α_] := 
      Prepend[Table[
          Point[Round[10. ^6 pKipp[k, α, wue]]/(10. ^6)], {k, 1, 
            Length[taW]}], PointSize[0.03]]

pointD1 = 
        Union[Flatten[
            Table[pointWKipp1[k 2  Pi/5], {k, 1, 5}]]];

Length[pointD1]

pointNumD[k_] := pointD1[[k]][[1]]; 
    Table[Print["Punkt ", k, " = ",  pointNumD[k]], {k, 1, 20}]; 
    pointD2 = Table[pointNumD[k], {k, 1, 20}];

TabPointNumbD2 = Table[ pointNumD[k], {k, 1, 20}];  
    TabPointNumbD2 // MatrixForm

?Select

DodTest = 
      Select[TabPointNumbD2, (#[[1]] > 0   &&  #[[2]] > 
                0) &]

DodFuenf[1] = 
        Select[TabPointNumbD2, (#[[3]] > 
                1) &];
DodFuenf[7] = 
        Select[TabPointNumbD2, (#[[3]] < -1) &];

DodFuenf[2] = 
        Select[TabPointNumbD2, (#[[1]] > 0   &&  #[[2]] < 
                  1  &&  #[[3]] > -0.4) &];
DodFuenf[8] = 
        Select[TabPointNumbD2, (#[[1]] < 
                  0   &&  #[[2]] > -1 &&  #[[3]] < 
                  0.4) &];

DodFuenf[3] = 
        Select[TabPointNumbD2, (#[[1]] >= 
                  0   &&  #[[2]] ≥ 
                  0  &&  #[[3]] > -0.4) &];
DodFuenf[9] = 
        Select[TabPointNumbD2, (#[[1]] <= 
                  0   &&  #[[2]] ≤ 0  &&  #[[3]] < 
                  0.4) &];

DodFuenf[4] = 
        Select[TabPointNumbD2, (#[[1]] ≤ 
                  0   &&  #[[2]] > -0.3 &&  #[[3]] > -0.4) &];
DodFuenf[10] = 
        Select[TabPointNumbD2, (#[[1]] >= 0   &&  #[[2]] < 
                  0.3  &&  #[[3]] < 0.4) &];

DodFuenf[5] = 
        Select[TabPointNumbD2, (#[[1]] < -0.3   &&  #[[2]] ≤  
                  0.6 &&  #[[3]] > -0.4) &];
DodFuenf[11] = 
        Select[TabPointNumbD2, (#[[1]] > 
                  0.3   &&  #[[2]] ≥ -0.6  &&  #[[3]] < 0.4) &];

DodFuenf[6] = 
        Select[TabPointNumbD2, (#[[2]] < -0.7  &&  #[[3]] > -0.4) &];
DodFuenf[12] = 
        Select[TabPointNumbD2, ( #[[2]] > 0.7  &&  #[[3]] < 
                  0.4) &];

prnt[k_] := 
      Table[pDodNum[k, n] = DodFuenf[k][[n]]; 
        Print["Punkt[", k, ",", 
          n, "] =  ", DodFuenf[k][[n]]], {n, 1, 5}]

DodFuenf[1][[5]];

DodWowrk[u_] := 
        Table[{DodFuenf[u][[k]], DodFuenf[u][[m]]}, {k, 1, 
            5}, {m, 1, 5}];

DodWowrkTest1 = 
        Flatten[Table[{DodFuenf[1][[k]], DodFuenf[
                  1][[m]]}, {k, 1, 5}, {m, 1, 5}], 1];

vLen[DodWowrkTest1[[5]][[1]] - DodWowrkTest1[[5]][[2]]];

vLen[u_] := Sqrt[u . u];

Union[
        Flatten[Table[
            If[s5Dod - 0.1 < 
                  vLen[DodWowrkTest1[[k]][[1]] - DodWowrkTest1[[k]][[2]]]  &&  
                s5Dod + 0.1 > 
                  vLen[DodWowrkTest1[[k]][[1]] - DodWowrkTest1[[k]][[2]]], DodWowrkTest1[[k]], zZZZ], {k, 1, 
              Length[DodWowrkTest1]}], 1]];

Table[prnt[k], {k, 1, 12}]

kk = 1; 
    DodFuenfNeu[kk] = {pDodNum[kk, 1], pDodNum[kk, 2], pDodNum[kk, 4], 
        pDodNum[kk, 5], pDodNum[kk, 3], 
        pDodNum[kk, 1]};
kk = 7; 
    DodFuenfNeu[kk] = {pDodNum[kk, 1], pDodNum[kk, 2], pDodNum[kk, 4], 
        pDodNum[kk, 5], pDodNum[kk, 3], 
        pDodNum[kk, 1]};
kk = 2; 
    DodFuenfNeu[kk] = {pDodNum[kk, 1], pDodNum[kk, 2], pDodNum[kk, 4], 
        pDodNum[kk, 5], pDodNum[kk, 3], 
        pDodNum[kk, 1]};
kk = 8; 
    DodFuenfNeu[kk] = {pDodNum[kk, 1], pDodNum[kk, 2], pDodNum[kk, 4], 
        pDodNum[kk, 5], pDodNum[kk, 3], 
        pDodNum[kk, 1]};
kk = 3; 
    DodFuenfNeu[kk] = {pDodNum[kk, 1], pDodNum[kk, 2], pDodNum[kk, 4], 
        pDodNum[kk, 5], pDodNum[kk, 3], 
        pDodNum[kk, 1]};
kk = 9; 
    DodFuenfNeu[kk] = {pDodNum[kk, 1], pDodNum[kk, 2], pDodNum[kk, 4], 
        pDodNum[kk, 5], pDodNum[kk, 3], 
        pDodNum[kk, 1]};
kk = 4; 
    DodFuenfNeu[kk] = {pDodNum[kk, 1], pDodNum[kk, 2], pDodNum[kk, 4], 
        pDodNum[kk, 5], pDodNum[kk, 3], 
        pDodNum[kk, 1]};
kk = 10; 
    DodFuenfNeu[kk] = {pDodNum[kk, 1], pDodNum[kk, 2], pDodNum[kk, 4], 
        pDodNum[kk, 5], pDodNum[kk, 3], 
        pDodNum[kk, 1]};
kk = 6; 
    DodFuenfNeu[kk] = {pDodNum[kk, 1], pDodNum[kk, 2], pDodNum[kk, 4], 
        pDodNum[kk, 5], pDodNum[kk, 3], 
        pDodNum[kk, 1]};
kk = 12; 
    DodFuenfNeu[kk] = {pDodNum[kk, 1], pDodNum[kk, 2], pDodNum[kk, 4], 
        pDodNum[kk, 5], pDodNum[kk, 3], pDodNum[kk, 1]};

lDod[k_] := Line[DodFuenfNeu[k]]; 
    lDodAll = 
      Table[lDod[k], {k, 1, 
          12}];

sehnenDodAll = Table[lDod[k], {k, 1, 12}];

pointDLTestEinzeln[k_] := 
        Show[Graphics3D[{pointD,   
lDod[k]}], 
          Axes -> True, 
          ViewPoint -> {100, 10, 10}];

    
pointDLTestEinzeln[6];

pointDL = 
        Show[Graphics3D[{pointD, 
              Line[{pDodNum[1, 1], pDodNum[1, 2]}], 
lDod[
                1], lDod[2], lDod[3], lDod[4], lDod[5], lDod[6], lDod[7], 
              lDod[8], lDod[9], lDod[10], lDod[11], lDod[12]}, 
            Axes -> False, AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {100, 10, 10}];

pointDL = 
        Show[Graphics3D[{pointD, 
              Line[{pDodNum[1, 1], pDodNum[1, 2]}], 
lDod[
                1], lDod[2], lDod[3], lDod[4], lDod[5], lDod[6], lDod[7], 
              lDod[8], lDod[9], lDod[10], lDod[11], lDod[12]}, 
            Axes -> False, AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {2.726,  -1.531,  1.294}];

nimm2 = pointDL;

zeig1 = Show[nimm1, nimm2];

pointDL = 
        Show[Graphics3D[{pointD, lDodAll}, Axes -> False, 
            AxesEdge -> None, Boxed -> False]];

allLinesDod = 
        Flatten[Table[
            Flatten[Table[
                Line[{pDodNum[j, i], pDodNum[k, n]}], {j, 1, k}, {i, 1, n}], 
              1], {k, 1, 12}, {n, 1, 5}]];

pointDL = 
        Show[Graphics3D[{pointD, allLinesDod}, Axes -> False, 
            AxesEdge -> None, Boxed -> False]];

pointDL = 
        Show[Graphics3D[{pointD, allLinesDod}, Axes -> False, 
            AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {5, 7, 5}];

pointDL = 
        Show[Graphics3D[{pointD, allLinesDod}, Axes -> False, 
            AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {0, 0, 100}];

pointDL = 
        Show[Graphics3D[{pointD, allLinesDod}, Axes -> False, 
            AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {0, 100, 0}];

pointDL = 
        Show[Graphics3D[{pointD, allLinesDod}, Axes -> False, 
            AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {100, 0, 0}];

Kanten und Flächenwinkel am Dodekaeder

TabPointNumbD2 // MatrixForm

vLen[v_] := Sqrt[v . v];

angle[v1_, v2_] := 
      ArcCos[(v1 . v2)/(vLen[v1] vLen[v2]) ] 360/(2  
              Pi)

{pointNumD[5], pointNumD[7], pointNumD[11], pointNumD[13], 
        pointNumD[17]} // MatrixForm

{angle[pointNumD[11], {0, 0, 1}], 
      angle[pointNumD[11], pointNumD[12]]}

angle[
      pointNumD[11] - pointNumD[12], {0, 0, 1} - pointNumD[11]]

pointNumD[work] = (pointNumD[7] + pointNumD[13])/2

{angle[pointNumD[work], {0, 0, 1}], 
      angle[pointNumD[work], pointNumD[9]]}

angle[pointNumD[9] - pointNumD[work], 
      pointNumD[work] - {0, 0, 1}]

Ikosaeder aus den Seitenmittelpunkten des Dodekaeders heraus

Achtung: In Mathematica Version 5.0 ist die Funktion "Total" im Kern eingebaut !!!!!!

Total[x_] := Sum[x[[k]], {k, 1, Length[x]}]

Achtung: In Mathematica Version 5.0 ist die Funktion "Total" im Kern eingebaut !!!!!!

Total[{1, 2, 3, 4, 5}]

Total[DodFuenfNeu[7]];

pDodNum = Table[Total[DodFuenf[k]]/5, {k, 1, 12}];

allLinesIkos = 
        Flatten[Table[
            Table[Line[{pDodNum[[j]], pDodNum[[k]]}], {j, 1, k}], {k, 
              1, 12}]];

pointIL = 
        Show[Graphics3D[{pointD, allLinesIkos, lDodAll}, Axes -> False, 
            AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {100, 10, 10}];

pointIL = 
        Show[Graphics3D[{allLinesIkos}, Axes -> False, 
            AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {100, 60, 10}];

pointIL = 
        Show[Graphics3D[{allLinesIkos}, Axes -> False, 
            AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {100, 40, 10}];

pointIL = 
        Show[Graphics3D[{allLinesIkos}, Axes -> False, 
            AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {100, 10, 10}];

pointsI = Prepend[Map[Point, pDodNum], PointSize[0.03]];

pointIL = 
        Show[Graphics3D[{pointsI, allLinesIkos}, Axes -> False, 
            AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {100, 20, 10}];

pointIL = 
        Show[Graphics3D[{pointsI, allLinesIkos}, Axes -> False, 
            AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {0.5, 0.5, 100}];

allDiffIkos = 
        Flatten[Table[
            Table[pDodNum[[j]] - pDodNum[[k]], {j, 1, k}], {k, 1, 
              12}], 1];
Table[vLen[allDiffIkos[[k]]], {k, 1, Length[allDiffIkos]}] // 
      Union

sIkos = 1.4472135923940044

seitenIkos = 
      Map[Line, 
        Drop[Union[
            Flatten[Table[
                Table[If[
                    vLen[pDodNum[[j]] - pDodNum[[k]]] > 1.4  &&  
                      vLen[pDodNum[[j]] - pDodNum[[k]]] < 
                        1.5, {pDodNum[[j]], pDodNum[[k]]}, 
                    hallo], {j, 1, k}], {k, 1, 12}], 1]], 1]]

pointIL = 
        Show[Graphics3D[{pointsI, seitenIkos}, Axes -> False, 
            AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {100, 20, 10}];

pointILDL = 
        Show[Graphics3D[{pointsI, seitenIkos, pointD, lDodAll}, 
            Axes -> False, AxesEdge -> None, Boxed -> False], 
          ViewPoint -> {100, 20, 10}];

Andere Programmiertechnik:
Dodekaeder aus dem Würfel durch Aufsetzen des goldenen Daches

rho = (Sqrt[5] + 1)/2;

sW = 2;  sD = sW/rho;

p[1] := {1, 1, 1}; p[2] := {-1, 1, 1}; p[3] := {-1, -1, 1}; 
    p[4] := {1, -1, 1};

a = (sW - sD)/2; b = 1; c = Sqrt[a^2 + b^2]; h = Sqrt[sD^2 - c^2]; 
    h // N;

p[5] = {0, sD/2, 1 + h};  p[6] = {0, -sD/2, 1 + h}; 
    p[7] = {0, sD/2, 1};

A[fi1_] := {{1, 0, 0}, {0, Cos[fi1], -Sin[fi1]}, {0, Sin[fi1], 
          Cos[fi1]}}; 
    B[fi2_] := {{Cos[fi2], 0, -Sin[fi2]}, {0, 1, 0}, {Sin[fi2], 0, 
          Cos[fi2]}};

A[fi] // MatrixForm;

B[f] // MatrixForm;

fi1 = Pi/2; fi2 = fi1;
f[k_, 1] := p[k];
f[k_, 2] := 
        B[fi1] . (A[fi1] . p[k]);
f[k_, 3] := 
        A[fi1] . (B[fi1] . p[k]);
f[k_, 4] := -f[k, 1];
f[k_, 5] := -f[k, 2];
f[k_, 6] := -f[k, 3];

f[3, 1];

point[t_] := Table[f[k, t], {k, 1, 6}]; point[1] // N;

pointsP[t_] := Prepend[Map[Point, point[t]], PointSize[0.03]]; 
    pointsP[1] // N;

linesP1[t_] := 
      Map[Line, {{f[1, t], f[2, t], f[3, t], f[4, t], f[1, t]}, {f[1, t], 
            f[5, t], f[6, t], f[4, t]}, {f[2, t], f[5, t], f[6, t], 
            f[3, t]}}]; linesP[1] // N;

linesP[t_] := 
      Map[Line, {{f[2, t], f[3, t]}, {f[4, t], f[1, t]}, {f[1, t], f[5, t], 
            f[6, t], f[4, t]}, {f[2, t], f[5, t], f[6, t], f[3, t]}}]; 
    linesP[1] // N;

Show[
        Graphics3D[{pointsP[1], linesP1[1], 
            Line[{f[1, 1], f[7, 1], f[5, 1]}]}, Axes -> None, 
          Boxed -> False]];

sh[k_] := 
        Show[Graphics3D[{pointsP[k], linesP1[k]}, Axes -> None, 
            Boxed -> False], 
          DisplayFunction -> Identity];
Show[Evaluate[Flatten[Table[sh[k], {k, 1, 6}]]], 
        DisplayFunction -> $DisplayFunction, 
        ViewPoint -> {2, 1, 7}];

Würfelfünfling ohne Durchdringung

sW = 2;

volW = sW^3; 
diagFW = Sqrt[2] sW;  
diagVW = Sqrt[3] sW; 
rUW =  diagVW/2;
rIW = sW/2;
 rKW =  diagVW/2;  obW = 6 sW^2;

sD = sW  (Sqrt[5] - 1)/2;   
Print["sW = ", sW // N];

    
s5Dod = sD;    
Print["s5Dod=sD = ", 
      sD // N];

diag2Dod = 
      s5Dod (1 + Sqrt[5])/2;     
Print["diag2Dod = \
", diag2Dod // N];

s6Dod = 
      s5Dod/Sqrt[1 + ((Sqrt[5] - 1)/2)^2];    
Print["s6Dod = ", 
      s6Dod // N];

rFDod = s6Dod;    
Print["rFDod = ", 
      rFDod // N];

Hs6Dod = 
      Sqrt[s6Dod^2 - (s5Dod/
                2)^2];     
Print["Hs6Dod = ", 
      Hs6Dod // N];

Hs2Dod = 
      Sqrt[s5Dod ^2 - (diag2Dod/
                2)^2];   
Print["Hs2Dod = ", 
      Hs2Dod // N];

dKipp = 
        s6Dod - Hs2Dod; 
  
Print["dKipp = ", dKipp // N];

    
φ1 = ArcSin[dKipp/(diagFW/2)] // Simplify // 
          N;
φ = 
        ArcSin[dKipp/(diagFW/
                2)];
  
Print["φ Winkeldifferenz = ", (φ1 /(2  
                    Pi) 360. ) // 
          N, " Grad"];

    
φ2 = -Pi/4 + φ;
Print["φ2 Kipp = ", (φ2 /(2  
                    Pi) 360. ) // 
          N, " Grad"];

  
Print["Halbe Flächendiagonale Würfel = ", 
        diagFW/2 // N];

p[1] := {1, 1, 1}; p[2] := {-1, 1, 1}; p[3] := {-1, -1, 1}; 
    p[4] := {1, -1, 1};
p[5] := {1, 1, -1}; p[6] := {-1, 1, -1}; 
    p[7] := {-1, -1, -1}; 
    p[8] := {1, -1, -1};

pKipp[
        k_, α_] := {{Cos[α], -Sin[α], 
            0}, {Sin[α], Cos[α], 0}, {0, 0, 
            1}} . ({{1, 0, 0}, {0, 
                Cos[-φ2], -Sin[-φ2]}, {0, 
                Sin[-φ2], Cos[-φ2]}} . p[k]); 
    pKipp[1, 0] // N;

pointsPNew[α_] := 
      Prepend[Map[Point, Table[pKipp[k, α], {k, 1, 8}]], 
        PointSize[0.03]]; pointsPNew[0] // N;

linesPNew[α_] := 
      Map[Line, {{pKipp[1, α], pKipp[2, α], pKipp[3, α], 
            pKipp[4, α], pKipp[1, α]}, {pKipp[5, α], 
            pKipp[6, α], pKipp[7, α], pKipp[8, α], 
            pKipp[5, α]}, {pKipp[1, α], 
            pKipp[5, α]}, {pKipp[2, α], 
            pKipp[6, α]}, {pKipp[3, α], 
            pKipp[7, α]}, {pKipp[4, α], pKipp[8, α]}}]; 
    linesPNew[0] // N;

Show[
        Graphics3D[{pointsPNew[1], linesPNew[1]}, Axes -> None, 
          Boxed -> False], 
        ViewPoint -> {2, 100, 100}];

sh[k_] := 
        Show[Graphics3D[{pointsPNew[k], linesPNew[k]}, Axes -> None, 
            Boxed -> False], 
          DisplayFunction -> Identity];
Show[Evaluate[Flatten[Table[sh[k 2  Pi/5], {k, 1, 5}]]], 
        DisplayFunction -> $DisplayFunction, 
        ViewPoint -> {2, 100, 100}];

Show[nimm1, nimm2, sh[3]];

Show[Evaluate[Flatten[Table[sh[k 2  Pi/5], {k, 1, 5}]]], 
        DisplayFunction -> $DisplayFunction, 
        ViewPoint -> {2, 500, 100}];

Show[Evaluate[Flatten[Table[sh[k 2  Pi/5], {k, 1, 5}]]], 
        DisplayFunction -> $DisplayFunction, 
        ViewPoint -> {2, 5, 100}];

Show[Evaluate[Flatten[Table[sh[k 2  Pi/5], {k, 1, 5}]]], 
        DisplayFunction -> $DisplayFunction, 
        ViewPoint -> {60, 100, 100}];

Tetraederfünfling ohne Durchdringung

pointsPNew1[α_] := 
      Prepend[Map[
          Point, {pKipp[1, α], pKipp[3, α], pKipp[6, α], 
            pKipp[8, α]}], PointSize[0.03]]; 
    pointsPNew1[0] // N;

linesPNew1[α_] := 
      Map[Line, {{pKipp[1, α], pKipp[3, α], pKipp[6, α], 
            pKipp[8, α], pKipp[1, α]}, {pKipp[1, α], 
            pKipp[6, α]}, {pKipp[3, α], pKipp[8, α]}}]; 
    linesPNew1[0] // N;

Show[
        Graphics3D[{pointsPNew1[1], linesPNew1[1]}, Axes -> None, 
          Boxed -> False], 
        ViewPoint -> {2, 100, 100}];

sh[k_] := 
        Show[Graphics3D[{pointsPNew1[k], linesPNew1[k]}, Axes -> None, 
            Boxed -> False], 
          DisplayFunction -> Identity];
Show[Evaluate[Flatten[Table[sh[k 2  Pi/5], {k, 1, 5}]]], 
        DisplayFunction -> $DisplayFunction, 
        ViewPoint -> {60, 100, 100}];

Show[Evaluate[Flatten[Table[sh[k 2  Pi/5], {k, 1, 5}]]], 
        DisplayFunction -> $DisplayFunction, 
        ViewPoint -> {0, 0, 100}];

Show[Evaluate[Flatten[Table[sh[k 2  Pi/5], {k, 1, 5}]]], 
        DisplayFunction -> $DisplayFunction, 
        ViewPoint -> {0, 100, 0}];

Show[Evaluate[Flatten[Table[sh[k 2  Pi/5], {k, 1, 5}]]], 
        DisplayFunction -> $DisplayFunction, 
        ViewPoint -> {100, 5, 0}];

Weitere gegenseitige Beziehungen und Durchdringungen

Selbst probieren

Platonische Körper

Alle Ecken, Kanten und Flächen gleich

Archimedische Körper

Alle Ecken gleich, 2 oder 3 verschiedene regelmässige n-Eck-Flächen

Gewinnung aus den platonischen Körpern durch Abschleifen der Ecken

Gewinnung aus den platonischen Körpern durch Abschleifen der Kanten

Gewinnung aus den platonischen Körpern mittels Kantenmittlepunkten

Gewinnung aus schon vorhandenen archimedischen Körpern

Selbst probieren

Johnsonkörper

Selbst probieren

Prismen und Antiprismen

Selbst probieren