Der Dodekaeder

Clear[HomogeneRotation]
HomogeneRotation[α_, {nx_, ny_, nz_}] := 
      Module[{ca, sa}, 
ca = 
          Cos[α]; 
sa = 
          Sin[α]; 
{{(nx^2) + 
              ca*(1 - (nx^2)), (1 - ca)*nx*ny + 
              sa*nz, -sa*ny + (1 - ca) nx*nz, 
            0}, 
{(1 - ca)*nx*ny - sa*nz, 
            (ny^2) + ca*(1 - (ny^2)), sa*nx + (1 - ca)*ny*nz, 
            0}, 
{sa*ny + (1 - ca) nx*nz, -sa*
                nx + (1 - ca)*ny*nz, (nz^2) + ca*(1 - (nz^2)), 
            0}, 
{0, 0, 0, 
            1}}
]

HomogeneDot[m_?MatrixQ, p_List  /;  Length[p] === 4] := 
      m . p
HomogeneDot[m_?MatrixQ, p_List /; Length[p] === 3] := 
      Drop[m . Append[p, 1], -1]
HomogeneDot[lst : {__?MatrixQ}, p_] := HomogeneDot[#, p]  &  /@  
        lst

Clear[CyclicGroup]
CyclicGroup[m_?MatrixQ, degree_Integer] := 
      Simplify  /@  
        NestList[m . #  &, IdentityMatrix[4], degree - 1]

CyclicGroup[HomogeneRotation[2  Pi/3, {1, 1, 1}/Sqrt[3]], 3]

Dpoints1 = {{1, 0, GoldenRatio^-2}, {-1, 0, 
            GoldenRatio^-2}, {-1, 0, -GoldenRatio^-2}, {1, 
            0, -GoldenRatio^-2}};

Dpoints2 = 
        Flatten[HomogeneDot[
                CyclicGroup[HomogeneRotation[2  Pi/3, {1, 1, 1}/Sqrt[3]], 
                  3], #]  &  /@  Dpoints1, 1];

\(\($dodecaPoints = 
        Join[Dpoints2, {
{GoldenRatio^\(-1\), 
              GoldenRatio^\(-1\), \ 
              GoldenRatio^\(-1\)}, 
\ \ \ \ \ \ \ \ \ \ {GoldenRatio^\(-1\), 
              GoldenRatio^\(-1\), \ \(-GoldenRatio^\(-1\)\)}, 
\ \ \ \ \ \ \ \ \ \ {GoldenRatio^\(-1\), \(-GoldenRatio^\(-1\)\), \ \(-GoldenRatio^\(-1\)\)}, 
\ \ \ \ \ \ \ \ \ {\(-GoldenRatio^\(-1\)\), \(-GoldenRatio^\(-1\)\), \ \(-GoldenRatio^\(-1\)\)}, 
\ \ \ \ \ \ \ \ \ {\(-GoldenRatio^\(-1\)\), \(-GoldenRatio^\(-1\)\), \ 
              GoldenRatio^\(-1\)}, 
\ \ \ \ \ \ \ \ \ {\(-GoldenRatio^\(-1\)\), GoldenRatio^\(-1\), \ 
              GoldenRatio^\(-1\)}, 
\ \ \ \ \ \ \ \ \ {\(-GoldenRatio^\(-1\)\), GoldenRatio^\(-1\), \ \(-GoldenRatio^\(-1\)\)}, 
\ \ \ \ \ \ \ \ \ {GoldenRatio^\(-1\), \(-GoldenRatio^\(-1\)\), \ 
              GoldenRatio^\(-1\)}}];\)\)

$dodecaPoints

labelgr = 
        Show[Graphics3D[{MapIndexed[{AbsolutePointSize[6], Point[#1], 
                    Text[First[#2], #1, {1, 0}, 
                      TextStyle -> {FontFamily -> "Helvetica", 
                          FontSize -> 
                            14}]} &, $dodecaPoints]}]];

$dodecaPoly = {{2, 11, 20, 1, 13}, {2, 18, 4, 17, 11}, {11, 17, 9, 6, 
            20}, {13, 3, 12, 18, 2}, {4, 18, 12, 19, 7}, {19, 12, 3, 14, 
            5}, {1, 13, 3, 14, 10}, {17, 4, 7, 16, 9}, {7, 19, 5, 8, 16}, {8, 
            15, 10, 14, 5}, {20, 1, 10, 15, 6}, {9, 6, 15, 8, 
            16}};
dodecaGraph[] := 
        Polygon  /@  
          Map[$dodecaPoints[[#]] &, $dodecaPoly, {2}];
Show[Graphics3D[dodecaGraph[]], labelgr, 
      ViewPoint -> {1.300,  -2.400,  2.000}]

S

Clear[HomogeneRotation]
HomogeneRotation[α_, {nx_, ny_, nz_}] := 
      Module[{ca, sa}, 
ca = 
          Cos[α]; 
sa = 
          Sin[α]; 
{{(nx^2) + 
              ca*(1 - (nx^2)), (1 - ca)*nx*ny + 
              sa*nz, -sa*ny + (1 - ca) nx*nz, 
            0}, 
{(1 - ca)*nx*ny - sa*nz, 
            (ny^2) + ca*(1 - (ny^2)), sa*nx + (1 - ca)*ny*nz, 
            0}, 
{sa*ny + (1 - ca) nx*nz, -sa*
                nx + (1 - ca)*ny*nz, (nz^2) + ca*(1 - (nz^2)), 
            0}, 
{0, 0, 0, 
            1}}
]

HomogeneDot[m_?MatrixQ, p_List  /;  Length[p] === 4] := 
      m . p
HomogeneDot[m_?MatrixQ, p_List /; Length[p] === 3] := 
      Drop[m . Append[p, 1], -1]
HomogeneDot[lst : {__?MatrixQ}, p_] := HomogeneDot[#, p]  &  /@  
        lst

Clear[CyclicGroup]
CyclicGroup[m_?MatrixQ, degree_Integer] := 
      Simplify  /@  
        NestList[m . #  &, IdentityMatrix[4], degree - 1]

CyclicGroup[HomogeneRotation[2  Pi/3, {1, 1, 1}/Sqrt[3]], 3]

Spoints1  =  {{1, 0, GoldenRatio}}

Spoints2 = 
        Flatten[HomogeneDot[
                  CyclicGroup[HomogeneRotation[2  Pi/3, {1, 1, 1}/Sqrt[3]], 
                    3], #]  &  /@  Spoints1 1, 1];

\($Spoints = 
      Join[Spoints2, {
{GoldenRatio^2, GoldenRatio^2, \ 
            GoldenRatio^2}, 
\ \ \ \ \ \ \ \ \ \ {GoldenRatio^\(-1\), 
            GoldenRatio^\(-1\), \ GoldenRatio^\(-1\)}}]\)

labelgr = 
        Show[Graphics3D[{MapIndexed[{AbsolutePointSize[6], Point[#1], 
                    Text[First[#2], #1, {1, 0}, 
                      TextStyle -> {FontFamily -> "Tahoma", 
                          FontSize -> 
                            14}]} &, $Spoints]}]];

$Spoly = {{2, 1, 5}, {1, 5, 3}, {2, 5, 3}, {2, 4, 3}, {2, 1, 4}, {1, 
            3, 4}};
Sgraph[] := 
        Polygon  /@  
          Map[$Spoints[[#]] &, $Spoly, {2}];
Show[Graphics3D[Sgraph[]], labelgr, 
      ViewPoint -> {1.300,  -2.400,  2.000}]

W

$Wpoints = {{1, 0, GoldenRatio}, {-1, 0, GoldenRatio}, {0, 
          GoldenRatio^-2, 1}, {0, -GoldenRatio^-2, 1}}

labelgr = 
        Show[Graphics3D[{MapIndexed[{AbsolutePointSize[6], Point[#1], 
                    Text[First[#2], #1, {1, 0}, 
                      TextStyle -> {FontFamily -> "Helvetica", 
                          FontSize -> 
                            14}]} &, $Wpoints]}]];

$dodecaPoly = {{2, 3, 4}, {1, 3, 4}, {1, 2, 3}, {1, 2, 
            4}};
dodecaGraph[] := 
        Polygon  /@  
          Map[$Wpoints[[#]] &, $dodecaPoly, {2}];
Show[Graphics3D[dodecaGraph[]], labelgr, 
      ViewPoint -> {2.008,  -2.171,  -1.645}]

C

$Cpoints = {{1, 0, GoldenRatio}, {-1, 0, GoldenRatio}, {0, 
          GoldenRatio,  GoldenRatio^3},  {0, -GoldenRatio,  
          GoldenRatio^3},  {-1, 0, GoldenRatio + 2},  {1, 0,  
          GoldenRatio + 2}}

labelgr = 
        Show[Graphics3D[{MapIndexed[{AbsolutePointSize[6], Point[#1], 
                    Text[First[#2], #1, {1, 0}, 
                      TextStyle -> {FontFamily -> "Helvetica", 
                          FontSize -> 
                            14}]} &, $Cpoints]}]];

$Cpoly = {{2, 5, 3}, {2, 5, 4}, {3, 4, 5}, {1, 2, 4}, {1, 2, 3}, {1, 
            6, 4}, {1, 6, 3}, {3, 4, 6}};
Cgraph[] := 
        Polygon  /@  
          Map[$Cpoints[[#]] &, $Cpoly, {2}];
Show[Graphics3D[Cgraph[]], labelgr, 
      ViewPoint -> {2.312,  -0.255,  2.458}]

H

Clear[HomogeneRotation]
HomogeneRotation[α_, {nx_, ny_, nz_}] := 
      Module[{ca, sa}, 
ca = 
          Cos[α]; 
sa = 
          Sin[α]; 
{{nx^2 + 
              ca*(1 - nx^2), (1 - ca)*nx*ny + 
              sa*nz, -sa*ny + (1 - ca) nx*nz, 
            0}, 
{(1 - ca)*nx*ny - sa*nz, 
            ny^2 + ca*(1 - ny^2), sa*nx + (1 - ca)*ny*nz, 
            0}, 
{sa*ny + (1 - ca) nx*nz, -sa*
                nx + (1 - ca)*ny*nz, nz^2 + ca*(1 - nz^2), 
            0}, 
{0, 0, 0, 
            1}}
]

HomogeneDot[m_?MatrixQ, p_List  /;  Length[p] === 4] := 
      m . p
HomogeneDot[m_?MatrixQ, p_List /; Length[p] === 3] := 
      Drop[m . Append[p, 1], -1]
HomogeneDot[lst : {__?MatrixQ}, p_] := HomogeneDot[#, p]  &  /@  
        lst

Clear[CyclicGroup]
CyclicGroup[m_?MatrixQ, degree_Integer] := 
      Simplify  /@  
        NestList[m . #  &, IdentityMatrix[4], degree - 1]

CyclicGroup[HomogeneRotation[2  Pi/5, {1, 0, GoldenRatio}/Sqrt[5]], 
      5]

Hpoints1 = {{GoldenRatio^-1, GoldenRatio^-1, 
          GoldenRatio^-1}}

Hpoints2 = 
        Flatten[HomogeneDot[
                CyclicGroup[
                  HomogeneRotation[2  Pi/5, {1, 0, GoldenRatio}/Sqrt[5]], 
                  5], #]  &  /@  Hpoints1, 1];

Hpoints2

Length[Hpoints2]

$Hpoints = Join[Hpoints2, {{1, 0, GoldenRatio}}];

Length[$Hpoints]

$Hpoints

Length[$Hpoints]

labelgr = 
        Show[Graphics3D[{MapIndexed[{AbsolutePointSize[6], Point[#1], 
                    Text[First[#2], #1, {1, 0}, 
                      TextStyle -> {FontFamily -> "Helvetica", 
                          FontSize -> 14}]} &, $Hpoints]}], 
          ViewPoint -> {1.411,  1.690,  -2.570}, 
          PlotRange -> All];

$Hpoly = {{1, 2, 3, 4, 5}};
Hgraph[] := 
        Polygon  /@  
          Map[$Hpoints[[#]] &, $Hpoly, {2}];
Show[Graphics3D[Hgraph[]], labelgr, 
      ViewPoint -> {0.045,  0.001,  3.383}, 
      PlotRange -> All]

dodecahedron small stellated

Clear[HomogeneRotation]
HomogeneRotation[α_, {nx_, ny_, nz_}] := 
      Module[{ca, sa}, 
ca = 
          Cos[α]; 
sa = 
          Sin[α]; 
{{(nx^2) + 
              ca*(1 - (nx^2)), (1 - ca)*nx*ny + 
              sa*nz, -sa*ny + (1 - ca) nx*nz, 
            0}, 
{(1 - ca)*nx*ny - sa*nz, 
            (ny^2) + ca*(1 - (ny^2)), sa*nx + (1 - ca)*ny*nz, 
            0}, 
{sa*ny + (1 - ca) nx*nz, -sa*
                nx + (1 - ca)*ny*nz, (nz^2) + ca*(1 - (nz^2)), 
            0}, 
{0, 0, 0, 
            1}}
]

HomogeneDot[m_?MatrixQ, p_List  /;  Length[p] === 4] := 
      m . p
HomogeneDot[m_?MatrixQ, p_List /; Length[p] === 3] := 
      Drop[m . Append[p, 1], -1]
HomogeneDot[lst : {__?MatrixQ}, p_] := HomogeneDot[#, p]  &  /@  
        lst

Clear[CyclicGroup]
CyclicGroup[m_?MatrixQ, degree_Integer] := 
      Simplify  /@  
        NestList[m . #  &, IdentityMatrix[4], degree - 1]

Clear[CyclicGroup]
CyclicGroup[m_?MatrixQ, degree_Integer] := 
      Simplify  /@  
        NestList[m . #  &, IdentityMatrix[4], degree - 1]

CyclicGroup[HomogeneRotation[2  Pi/3, {1, 1, 1}/Sqrt[3]], 3]

Dsmallpoints1 = {{1, 0, GoldenRatio}, {-1, 0, GoldenRatio}, {1, 
            0, -GoldenRatio}, {-1, 
            0, -GoldenRatio}};

$Dsmallpoints = 
        Flatten[HomogeneDot[
                CyclicGroup[HomogeneRotation[2  Pi/3, {1, 1, 1}/Sqrt[3]], 
                  3], #]  &  /@  Dsmallpoints1, 1];

$Dsmallpoints

Length[%]

labelgr = 
        Show[Graphics3D[{MapIndexed[{AbsolutePointSize[6], Point[#1], 
                    Text[First[#2], #1, {1, 0}, 
                      TextStyle -> {FontFamily -> "Helvetica", 
                          FontSize -> 
                            14}]} &, $Dsmallpoints]}]];

$Dsmallpoly = {{1, 2, 4}, {1, 4, 8}, {2, 4, 9}, {4, 9, 12}, {7, 10, 
            5}, {9, 10, 12}, {5, 9, 10}, {2, 5, 9}, {2, 5, 3}, {1, 2, 3}, {1, 
            3, 6}, {7, 3, 5}, {7, 3, 6}, {1, 8, 6}, {4, 8, 12}, {8, 11, 
            12}, {10, 11, 12}, {6, 8, 11}, {7, 10, 11}, {6, 7, 
            11}};
Dsmallgraph[] := 
        Polygon  /@  
          Map[$Dsmallpoints[[#]] &, $Dsmallpoly, {2}];
Show[Graphics3D[Dsmallgraph[]], labelgr, 
      ViewPoint -> {1.620,  2.828,  0.910}]

D3

Clear[HomogeneRotation]
HomogeneRotation[α_, {nx_, ny_, nz_}] := 
      Module[{ca, sa}, 
ca = 
          Cos[α]; 
sa = 
          Sin[α]; 
{{(nx^2) + 
              ca*(1 - (nx^2)), (1 - ca)*nx*ny + 
              sa*nz, -sa*ny + (1 - ca) nx*nz, 
            0}, 
{(1 - ca)*nx*ny - sa*nz, 
            (ny^2) + ca*(1 - (ny^2)), sa*nx + (1 - ca)*ny*nz, 
            0}, 
{sa*ny + (1 - ca) nx*nz, -sa*
                nx + (1 - ca)*ny*nz, (nz^2) + ca*(1 - (nz^2)), 
            0}, 
{0, 0, 0, 
            1}}
]

HomogeneDot[m_?MatrixQ, p_List  /;  Length[p] === 4] := 
      m . p
HomogeneDot[m_?MatrixQ, p_List /; Length[p] === 3] := 
      Drop[m . Append[p, 1], -1]
HomogeneDot[lst : {__?MatrixQ}, p_] := HomogeneDot[#, p]  &  /@  
        lst

Clear[CyclicGroup]
CyclicGroup[m_?MatrixQ, degree_Integer] := 
      Simplify  /@  
        NestList[m . #  &, IdentityMatrix[4], degree - 1]

CyclicGroup[HomogeneRotation[2  Pi/3, {1, 1, 1}/Sqrt[3]], 3]

D3points1 = {{GoldenRatio^3, 0, GoldenRatio}, {-GoldenRatio^3, 0, 
          GoldenRatio}, {GoldenRatio^3, 
          0, -GoldenRatio}, {-GoldenRatio^3, 
          0, -GoldenRatio}}

\(\($D3points = 
        Join[D3points2, {
{GoldenRatio^2, GoldenRatio^2, \ 
              GoldenRatio^2}, 
\ \ \ \ \ \ \ \ \ \ {GoldenRatio^2, 
              GoldenRatio^2, \ \(-GoldenRatio^2\)}, 
\ \ \ \ \ \ \ \ \ \ {GoldenRatio^2, \(-GoldenRatio^2\), \ \(-GoldenRatio^2\)}, 
\ \ \ \ \ \ \ \ \ {\(-GoldenRatio^2\), \(-GoldenRatio^2\), \ \(-GoldenRatio^2\)}, 
\ \ \ \ \ \ \ \ \ {\(-GoldenRatio^2\), \(-GoldenRatio^2\), \ 
              GoldenRatio^2}, 
\ \ \ \ \ \ \ \ \ {\(-GoldenRatio^2\), 
              GoldenRatio^2, \ 
              GoldenRatio^2}, 
\ \ \ \ \ \ \ \ \ {\(-GoldenRatio^2\), 
              GoldenRatio^2, \ \(-GoldenRatio^2\)}, 
\ \ \ \ \ \ \ \ \ {GoldenRatio^2, \(-GoldenRatio^2\), \ 
              GoldenRatio^2}}];\)\)
Length[$D3points]

labelgr = 
        Show[Graphics3D[{MapIndexed[{AbsolutePointSize[6], Point[#1], 
                    Text[First[#2], #1, {1, 0}, 
                      TextStyle -> {FontFamily -> "Helvetica", 
                          FontSize -> 
                            14}]} &, $D3points]}]];

$D3poly = {{5, 11, 15, 7, 14}, {5, 11, 16, 10, 19}, {15, 11, 16, 12, 
            6}, {14, 5, 19, 9, 3}, {7, 15, 6, 20, 1}, {18, 4, 10, 19, 9}, {7, 
            14, 3, 13, 1}, {20, 6, 12, 17, 8}, {16, 10, 4, 17, 12}, {3, 9, 
            18, 2, 13}, {1, 13, 2, 8, 20}, {2, 18, 4, 17, 
            8}};
D3graph[] := 
        Polygon  /@  
          Map[$D3points[[#]] &, $D3poly, {2}];
Show[Graphics3D[D3graph[]], labelgr, 
      ViewPoint -> {1.300,  -2.400,  2.000}]