DUAL POLYHEDRA

Author's notice

This tutorial was written by 

Fred Goodman
Department of Mathematics
University of Iowa
Iowa City, IA 52242
goodman@math.uiowa.edu

This material may be freely copied and used for non-commercial purposes.
Please retain this author's notice, and do not distribute any altered version
of this material without the author's permission  (unless  the material is altered beyond recognition).


This material  supplements  the text  Algebra:  Groups, Rings, and Fields,
Prentice-Hall, 1997.


I have used elements of the package Polyhdra.m  which is circulated with Mathematica, but have determined the dual polyhedron by what seems to me a more straightforward algorithm.  (That is to say,  I couldn't understand the  circulated algorithm until I had rewritten it.
The dual polyhedron is normalized by placing its vertices at the barycenter of the faces of the original polyhedron.

Programming

DualVertices[polyhedron_] := 
      Module[{vertices, faces, edges, k}, vertices = Vertices[polyhedron]; 
        faces = Faces[polyhedron]; edges = Edges[polyhedron]; 
        k = Length[faces[[1]]]; 
        Apply[Plus, 
            (vertices[[#1]]&)/@
              faces, 1]/k]

DualFace[v0_, polyhedron_] := 
      Module[{vertices, faces, tempfacelist, newface, facelist, newvertex}, 
        vertices = Vertices[polyhedron]; faces = Faces[polyhedron]; 
        tempfacelist = Select[faces, MemberQ[#1, v0]&]; 
        newface = tempfacelist[[1]]; 
        facelist = {newface}; 
        tempfacelist = Complement[tempfacelist, facelist]; 
        newvertex = 
          RotateLeft[newface, 
              Position[newface, v0][[1, 1
                  ]] - 1][[2
            ]]; 
        While[tempfacelist ≠ {}, 
          newface = 
            Select[tempfacelist, MemberQ[#1, v0] && MemberQ[#1, newvertex]&]
                [[1]]; 
          facelist = Append[facelist, newface]; 
          tempfacelist = Complement[tempfacelist, facelist]; 
          newvertex = 
            Module[{}, 
              rotate = 
                RotateLeft[newface, 
                  Position[newface, v0][[1, 1
                      ]] - 1]; 
              If[rotate[[2]] ≠ 
                  newvertex, 
                rotate[[2]], 
                rotate[[Length[rotate]
                    ]]]]; ]; 
        (Position[faces, #1][[1, 1
                ]]&)/@facelist]

DualFaces[polyhedron_] := 
      Module[{vertices, faces}, vertices = Vertices[polyhedron]; 
        faces = Faces[polyhedron]; 
        Table[DualFace[i, polyhedron], {i, Length[vertices]}]]

DualEdges[polyhedron_] := 
      Module[{vertices, faces, edges, k, facesIncidentOn}, 
        vertices = Vertices[polyhedron]; faces = Faces[polyhedron]; 
        edges = Edges[polyhedron]; 
        k = Length[faces[[1]]]; 
        facesIncidentOn[edge_] := 
          Select[faces, 
              MemberQ[#1, edge[[1]]] && 
                  MemberQ[#1, 
                    edge[[2]]]&] /; 
            ListQ[edge]; 
        DualEdge[edge_] := 
          (Position[faces, #1][[1, 1
                  ]]&)/@facesIncidentOn[edge]; 
        DualEdge/@edges]

red = RGBColor[.8, 0, 0]; blue = RGBColor[0, 0, .8]; \(black = RGBColor[0, 0, 0]; 
green\  = \ RGBColor[0, .8, 0]; \)

skeleton[poly_, vertexcolor_, edgecolor_] := 
      Module[{vertices, edges, lines, points}, vertices = Vertices[poly]; 
        edges = Edges[poly]; 
        lines = Line/@
            (vertices[[#1]]&)/@
              edges; points = Point/@vertices; 
        Graphics3D[{{Thickness[.001], edgecolor, lines}, {PointSize[.02], 
              vertexcolor, points}}]]

surface[poly_] := 
      Module[{vertices, faces}, vertices = Vertices[poly]; 
        faces = Faces[poly]; 
        faces = Map[Polygon, 
            (vertices[[#1]]&)/@
              faces, {1}]; Graphics3D[faces]]faceToEdges[face_] := 
      Module[{edgelist, n, i}, edgelist = {}; n = Length[face]; 
        For[i = 1, i < n, i++, 
          edgelist = 
            Append[edgelist, 
              If[face[[i]] < 
                  face[[i + 1]], {
                  face[[i]], 
                  face[[i + 1]]}, {
                  face[[i + 1]], 
                  face[[i]]}]]]; 
        edgelist = 
          Append[edgelist, 
            If[face[[1]] < 
                face[[n]], {
                face[[1]], 
                face[[n]]}, {
                face[[n]], 
                face[[1]]}]]]

Data

Hexahedron /: 
      Faces[Hexahedron]
         = {{1, 2, 3, 4}, {1, 4, 6, 7}, {1, 7, 8, 2}, {2, 8, 5, 3}, {5, 8, 7, 
          6}, {3, 5, 6, 4}}; Hexahedron /: 
      Vertices[Hexahedron]
         = {{1, 1, 1}, {-1, 1, 1}, {-1, -1, 1}, {1, -1, 1}, {
          -1, -1, -1}, {1, -1, -1}, {1, 1, -1}, {
          -1, 1, -1}}; Cube /: Faces[Cube] := Faces[Hexahedron]Cube /: Vertices[Cube] := Vertices[Hexahedron]Cube /: 
      Edges[Cube]
         = {{1, 2}, {2, 3}, {3, 4}, {1, 4}, {4, 6}, {6, 7}, {1, 7}, {7, 8}, {
          2, 8}, {5, 8}, {3, 5}, {5, 6}}; Cube /: TripleAxes[Cube] = {{1, 5}, {2, 6}, {3, 7}, {4, 8}}; SphericalToCartesian[{theta_, phi_}] := {Sin[theta] Cos[phi], 
        Sin[theta] Sin[phi], Cos[theta]}; Icosahedron /: 
      Faces[Icosahedron]
         = {{1, 3, 2}, {1, 4, 3}, {1, 5, 4}, {1, 6, 5}, {1, 2, 6}, {2, 3, 
          7}, {3, 4, 8}, {4, 5, 9}, {5, 6, 10}, {6, 2, 11}, {7, 3, 8}, {8, 4, 
          9}, {9, 5, 10}, {10, 6, 11}, {11, 2, 7}, {7, 8, 12}, {8, 9, 12}, {
          9, 10, 12}, {10, 11, 12}, {11, 7, 12}}; Icosahedron /: Vertices[Icosahedron] := 
      (Icosahedron /: Vertices[Icosahedron] = 
          N[N[SphericalToCartesian/@{{0, 0}, {ArcTan[2], 0}, {ArcTan[2], 
                      ((2 π)/5)}, {ArcTan[2], ((4 π)/5)}, {
                      ArcTan[2], ((6 π)/5)}, {ArcTan[2], 
                      ((8 π)/5)}, {π - ArcTan[2], (π/5)}, {
                      π - ArcTan[2], ((3 π)/5)}, {
                      π - ArcTan[2], ((5 π)/5)}, {
                      π - ArcTan[2], ((7 π)/5)}, {
                      π - ArcTan[2], ((9 π)/5)}, {π, 0}}/
                ((Sqrt[(1/2) + (1/2) Cos[ArcTan[2]]])), 2 Precision[1.0]]])
        ; If[! (ValueQ[Edges[Icosahedron]]), 
      Icosahedron /: Edges[Icosahedron] = 
        Union[Flatten[faceToEdges/@Faces[Icosahedron], 1]]]Dodecahedron /: Vertices[Dodecahedron] = DualVertices[Icosahedron]; 
    Dodecahedron /: Faces[Dodecahedron] := DualFaces[Icosahedron]; Dodecahedron /: Edges[Dodecahedron] = DualEdges[Icosahedron];

Introduction

For each convex polyhedron, there is a dual polyhedron, regualar if the original polyehedron is regular.   The vertices of the dual are located at the centroid of the faces of the original polyhedron.  An edge connect two vertices of the dual if 
the corresponding faces of the original polyhedron are adjacent.  It follows that faces of the dual polyhedron correspond to vertices of the original polyhedron.

The dual of the dual is the original polyhedron  (scaled).

The cube and octahedron are dual, as are the dodecahedron and icosahedron.
The tetrahedron is its own dual.  

The following graphics display these dualities.

Display of  dual polyhedra

data

Tetrahedron /: 
      Faces[Tetrahedron] = {{1, 2, 3}, {1, 3, 4}, {1, 4, 2}, {2, 4, 3}}; Tetrahedron /: 
      Edges[Tetrahedron] = {{1, 2}, {1, 3}, {1, 4}, {2, 3}, {2, 4}, {3, 4}}; 
    Tetrahedron /: Vertices[Tetrahedron] = 
      N[{{0, 0, (Sqrt[3])}, {0, ((2 (Sqrt[2]) (Sqrt[3]))/3), -((Sqrt[3])/3)}, {-(Sqrt[2]), 
            -(1/3) ((Sqrt[2]) (Sqrt[3])), -((Sqrt[3])/3)}, {(Sqrt[2]), 
            -(1/3) ((Sqrt[2]) (Sqrt[3])), -((Sqrt[3])/3)}}]; Hexahedron /: 
      Faces[Hexahedron]
         = {{1, 2, 3, 4}, {1, 4, 6, 7}, {1, 7, 8, 2}, {2, 8, 5, 3}, {5, 8, 7, 
          6}, {3, 5, 6, 4}}; Hexahedron /: 
      Vertices[Hexahedron]
         = {{1, 1, 1}, {-1, 1, 1}, {-1, -1, 1}, {1, -1, 1}, {
          -1, -1, -1}, {1, -1, -1}, {1, 1, -1}, {
          -1, 1, -1}}; Cube /: Faces[Cube] := Faces[Hexahedron]Cube /: Vertices[Cube] := Vertices[Hexahedron]Cube /: 
      Edges[Cube]
         = {{1, 2}, {2, 3}, {3, 4}, {1, 4}, {4, 6}, {6, 7}, {1, 7}, {7, 8}, {
          2, 8}, {5, 8}, {3, 5}, {5, 6}}; Cube /: TripleAxes[Cube] = {{1, 5}, {2, 6}, {3, 7}, {4, 8}}; SphericalToCartesian[{theta_, phi_}] := {Sin[theta] Cos[phi], 
        Sin[theta] Sin[phi], Cos[theta]}; Icosahedron /: 
      Faces[Icosahedron]
         = {{1, 3, 2}, {1, 4, 3}, {1, 5, 4}, {1, 6, 5}, {1, 2, 6}, {2, 3, 
          7}, {3, 4, 8}, {4, 5, 9}, {5, 6, 10}, {6, 2, 11}, {7, 3, 8}, {8, 4, 
          9}, {9, 5, 10}, {10, 6, 11}, {11, 2, 7}, {7, 8, 12}, {8, 9, 12}, {
          9, 10, 12}, {10, 11, 12}, {11, 7, 12}}; Icosahedron /: Vertices[Icosahedron] := 
      (Icosahedron /: Vertices[Icosahedron] = 
          N[N[SphericalToCartesian/@{{0, 0}, {ArcTan[2], 0}, {ArcTan[2], 
                      ((2 π)/5)}, {ArcTan[2], ((4 π)/5)}, {
                      ArcTan[2], ((6 π)/5)}, {ArcTan[2], 
                      ((8 π)/5)}, {π - ArcTan[2], (π/5)}, {
                      π - ArcTan[2], ((3 π)/5)}, {
                      π - ArcTan[2], ((5 π)/5)}, {
                      π - ArcTan[2], ((7 π)/5)}, {
                      π - ArcTan[2], ((9 π)/5)}, {π, 0}}/
                ((Sqrt[(1/2) + (1/2) Cos[ArcTan[2]]])), 2 Precision[1.0]]])
        ; If[! (ValueQ[Edges[Icosahedron]]), 
      Icosahedron /: Edges[Icosahedron] = 
        Union[Flatten[faceToEdges/@Faces[Icosahedron], 1]]];

dualcube /: Vertices[dualcube] = DualVertices[Cube]; dualcube /: Faces[dualcube] = DualFaces[Cube]; dualcube /: Edges[dualcube] = DualEdges[Cube];

Show[{skeleton[Cube, blue, black], surface[dualcube]}, 
      Boxed -> False, ViewPoint -> {0.744, -3.088, 1.168}]

dualdualcube /: Vertices[dualdualcube] = DualVertices[dualcube]; dualdualcube /: Faces[dualdualcube] = DualFaces[dualcube]; dualdualcube /: Edges[dualdualcube] = DualEdges[dualcube]; Show[{{skeleton[dualcube, blue, black], surface[dualdualcube]}}, 
      Boxed -> False, ViewPoint -> {0.744, -3.088, 1.168}]

Null

Dodecahedron /: Vertices[Dodecahedron] = DualVertices[Icosahedron]; 
    Dodecahedron /: Faces[Dodecahedron] = DualFaces[Icosahedron]; Dodecahedron /: Edges[Dodecahedron] = DualEdges[Icosahedron];

Show[{{skeleton[Icosahedron, green, red], surface[Dodecahedron]}}, 
      Boxed -> False]

dualdodecahedron /: Vertices[dualdodecahedron] = 
      DualVertices[Dodecahedron]; dualdodecahedron /: Faces[dualdodecahedron] = 
      DualFaces[Dodecahedron]; dualdodecahedron /: Edges[dualdodecahedron] = 
      DualEdges[Dodecahedron];

Show[{{skeleton[Dodecahedron, blue, black], 
          surface[dualdodecahedron]}}, Boxed -> False]

dualtetrahedron /: Vertices[dualtetrahedron] = 
      DualVertices[Tetrahedron]; dualtetrahedron /: Faces[dualtetrahedron] = DualFaces[Tetrahedron]; 
    dualtetrahedron /: Edges[dualtetrahedron] = DualEdges[Tetrahedron];

Show[{{skeleton[Tetrahedron, blue, black], surface[dualtetrahedron]}}, 
      Boxed -> False]