10
$\begingroup$

I want to include a figure in a paper I am writing on Combinatorial Geometry which features a non-convex polyhedron given by the following vertices,

EDIT: I was unaware that Mathematica could convert coordinates from spherical to Cartesian, so I will post the correct spherical coordinates as follows:

{{0, 0, 0}, {1, 0, 0}, {1, Pi/3, 0}, {1, Pi/3, ArcCos[1/3]},
 {1, Pi/3, 2 ArcCos[1/3]}, {1, Pi/3, 3 ArcCos[1/3]},
 {1, Pi/3, 4 ArcCos[1/3]}, {1, (2 Pi)/3, (ArcCos[1/3])/2},
 {1, (2 Pi)/3, (3 ArcCos[1/3])/2}, {1, (2 Pi)/3, (5 ArcCos[1/3])/2},
 {1, (2 Pi)/3, (7 ArcCos[1/3])/2}, {1, (2 Pi)/3, (9 ArcCos[1/3])/2}, {1, Pi, 0}}

Does anyone know how I can generate such a figure using Mathematica? I assume I will need to also somehow define which vertices are connected by an edge with a list, but I am unsure how I would do that as well. I have tried using the "Computational Geometry Package", and have been reading through the tutorial for about an hour, but I have no idea what a "vertex adjacency list" is or how I could make this work in 3-dimensions; the package tutorial seems to only comment on triangulations in the plane, etc.

Any help is greatly appreciated!

EDIT: I will attempt to describe this non-convex polyhedron and include pictures and a figure. Real image figure I will quote from my paper:

The inspiration for constructing a simplicial 3-complex $\mathcal{K}$ for which 12 tetrahedra touch at a vertex comes from the configuration of 4 tetrahedra sharing an edge; see Figure 3. Let $v_{0}=(0,0,0)$ be the origin and connect the two vertices $v_{1}=(1,0,0)$ and $v_{12} = (-1,0,0)$ to $v_{0}$ by an edge. Label these edges as $e(v_{0}v_{1})$ and $e(v_{0}v_{12})$ and notice that their union forms a straight line of length 2 in $\mathbb{E}^3$. Around each of these edges we arrange four tetrahedra as in Figure 3, and we rotate the cluster of four tetrahedra sharing edge $e(v_{0}v_{12})$ by $\pi/6$ in order to ensure that an extra four tetrahedra will fit in between the two clusters of 4 tetrahedra (explained in more detail later). Considering the vertices of these tetrahedra, we obtain a point set $P$ (with $|P|=12$) where the minimum distance which can occur any of the points is of unit length.

Figure 3: in the context of my paper, this figure shows that at most 4 tetrahedra can share an edge with conditions I impose. If you imagine one of the tetrahedra removed so that there is a bigger space, these are the "clusters of 4 tetrahedra" I described above. figure 3

(The bonus question was solved, thank you Mr. Wizard.)

BONUS: If anyone knows how to check with Mathematica if all of the points are at least a distance of 1 away from each other that would be very helpful.

Improve this question
$\endgroup$
8
  • $\begingroup$ For the bonus question: Map[# >= 1 &, Outer[EuclideanDistance, N[pts, 20], N[pts, 20], 1], {2}] has a good amount of off-diagonal False entries... $\endgroup$
    – J. M.'s missing motivation ♦
    Commented Jun 21, 2012 at 23:18
  • $\begingroup$ @J.M. doesn't Outer test many duplicates that way? $\endgroup$
    – Mr.Wizard
    Commented Jun 21, 2012 at 23:21
  • $\begingroup$ @J.M. I'm sorry I am not a Mathematica expert, I don't know what your answer means. $\endgroup$
    – Samuel Reid
    Commented Jun 21, 2012 at 23:21
  • 1
    $\begingroup$ Sam, what I did was to treat your list of points as a vector and construct the outer product of those two vectors, but I replaced multiplication with the Euclidean distance of two points. The outermost Map[] just checks your criterion. $\endgroup$
    – J. M.'s missing motivation ♦
    Commented Jun 21, 2012 at 23:26
  • 1
    $\begingroup$ I'm going according to what Mathematica states: "In the spherical coordinate system Spherical[r,theta,phi], the coordinate r gives the distance of the point from the origin, the coordinate [Theta] gives the angle measured from the positive z axis, and the coordinate [Phi] gives the angle measured in the x-y plane from the positive x axis, counterclockwise as viewed from the positive z axis. " $\endgroup$
    – Samuel Reid
    Commented Jun 22, 2012 at 1:18

3 Answers 3

Reset to default
10
$\begingroup$

As a starting point, you could generate an initial tetrahedralization of your points by using the TetGenLink` package:

pts = FullSimplify[TrigExpand[(#1 Append[Sin[#2]Through[{Cos, Sin}[#3]], Cos[#2]])]] & @@@
         {{0, 0, 0}, {1, 0, 0}, {1, Pi/3, 0}, {1, Pi/3, ArcCos[1/3]},
          {1, Pi/3, 2 ArcCos[1/3]}, {1, Pi/3, 3 ArcCos[1/3]},
          {1, Pi/3, 4 ArcCos[1/3]}, {1, (2 Pi)/3, (ArcCos[1/3])/2},
          {1, (2 Pi)/3, (3 ArcCos[1/3])/2}, {1, (2 Pi)/3, (5 ArcCos[1/3])/2},
          {1, (2 Pi)/3, (7 ArcCos[1/3])/2}, {1, (2 Pi)/3, (9 ArcCos[1/3])/2}, {1, Pi, 0}};

Needs["TetGenLink`"]

{tpts, tets} = TetGenDelaunay[pts];

TetrahedraWireframe[i_] := Line[Flatten[i[[All, #]] & /@
                                {{1, 2}, {2, 3}, {3, 1}, {1, 4}, {2, 4}, {3, 4}}, 1]]

Graphics3D[GraphicsComplex[tpts, TetrahedraWireframe[tets]]]

Delaunay tetrahedralization of Sam's points

Here's a version with labeled points, for guidance:

Graphics3D[{GraphicsComplex[tpts, TetrahedraWireframe[tets]], 
            MapIndexed[Style[Text[First[#2], #1, {-1, -1}], Red, 18] &, pts]}]

labeled polyhedron

Now, all that's needed is a criterion for knowing which lines should be retained, or a way to indicate connectivity ("point 1 is joined to points 7, 6, and 5; ...")...

OP managed to reckon out a patch list from the data given above:

patches = {{1, 2, 7}, {2, 3, 4}, {3, 4, 8}, {4, 5, 2}, {2, 5, 6}, {2, 6, 7},
           {1, 2, 3}, {7, 11, 12}, {6, 11, 7}, {8, 9, 4}, {13, 9, 8},
           {13, 10, 9}, {13, 11, 10}, {13, 12, 11}, {13, 1, 8}, {12, 1, 13},
           {11, 1, 10}, {10, 9, 1}, {9, 1, 4}, {7, 1, 12}, {6, 1, 11},
           {5, 4, 1}, {3, 1, 8}, {5, 6, 1}};

GraphicsComplex[] is of course what one should now use these days for reconstructing a polyhedron from points and patches. For reference, here's what was once done in old versions of Mathematica:

Graphics3D[Polygon[Part[pts, #] & /@ patches]]

Sam's polyhedron

If one had a list of edges as opposed to a list of patches:

edges = {1 -> 2, 1 -> 3, 1 -> 4, 1 -> 5, 1 -> 6, 1 -> 7, 1 -> 8, 1 -> 9,
         1 -> 10, 1 -> 11, 1 -> 12, 1 -> 13, 2 -> 3, 2 -> 4, 2 -> 5, 2 -> 6,
         2 -> 7, 3 -> 4, 3 -> 8, 4 -> 5, 4 -> 8, 4 -> 9, 5 -> 6, 6 -> 7,
         6 -> 11, 7 -> 11, 7 -> 12, 8 -> 9, 8 -> 13, 9 -> 10, 9 -> 13,
         10 -> 11, 10 -> 13, 11 -> 12, 11 -> 13, 12 -> 13};

then one could use GraphPlot3D[] to visualize a wireframe of the polyhedron:

GraphicsRow[{
    GraphPlot3D[edges, Method -> "SpringElectricalEmbedding"], 
    GraphPlot3D[edges, VertexCoordinateRules -> MapIndexed[First[#2] -> #1 &, pts]]}]

GraphPlot3D[] results

Here, the picture on the right used the explicit coordinates given by the OP, while the picture on the left used a graph embedding method to choose "nice" (for the internal algorithm, that is) coordinates.

Improve this answer
$\endgroup$
10
  • $\begingroup$ I have a physical model of this polyhedron, and I in fact constructed it for a particular purpose so I do know by looking at that picture you just uploaded exactly which edges should not be present. $\endgroup$
    – Samuel Reid
    Commented Jun 21, 2012 at 23:38
  • $\begingroup$ Okay. Could you maybe include a picture of your physical model in your question for reference? :) $\endgroup$
    – J. M.'s missing motivation ♦
    Commented Jun 21, 2012 at 23:40
  • $\begingroup$ I edited my response and also just realized that I made a mistake converting some of the coordinates from spherical to cartesian, so I will re-upload the correct coordinate data in one moment. Thank you for all of the help! $\endgroup$
    – Samuel Reid
    Commented Jun 21, 2012 at 23:49
  • $\begingroup$ If need be, you could post the original spherical coordinates, and we can then use Mathematica to do the conversion for you... $\endgroup$
    – J. M.'s missing motivation ♦
    Commented Jun 22, 2012 at 0:00
  • 1
    $\begingroup$ The figure I generated from the code in my answer ended up in a paper I wrote: arxiv.org/abs/1210.5756 if you are interested! Thanks for the help. $\endgroup$
    – Samuel Reid
    Commented Feb 5, 2013 at 23:42
6
$\begingroup$

Regarding your BONUS, you can get the minimum distance between all pairs of points like this:

list = {{0, 0, 0}, {0, 0, 1}, {1/2, 0, Sqrt[3]/2}, {1/6, Sqrt[2]/3, Sqrt[3]/ 2}, {-(7/18), (2 Sqrt[2])/9, Sqrt[3]/ 2}, {-(23/54), -((5 Sqrt[2])/27), Sqrt[3]/2}, {17/ 162, -((28 Sqrt[2])/81), Sqrt[3]/2}, {Sqrt[3]/4, 1/ 4, -(Sqrt[3]/2)}, {(3 - 2 Sqrt[6])/(12 Sqrt[3]), ( 6 Sqrt[2] + Sqrt[3])/( 12 Sqrt[3]), -(Sqrt[3]/2)}, {(-63 - 12 Sqrt[6])/(108 Sqrt[3]), 1/36 (-7 + 4 Sqrt[6]), -(Sqrt[3]/2)}, {1/ 108 (10 Sqrt[2] - 23 Sqrt[3]), 1/108 (-23 - 10 Sqrt[6]), -(Sqrt[3]/2)}, {1/ 324 (56 Sqrt[2] + 17 Sqrt[3]), 1/324 (17 - 56 Sqrt[6]), -(Sqrt[3]/2)}, {0, 0, -1}};

EuclideanDistance @@@ Subsets[N @ list, {2}] // Min
Improve this answer
$\endgroup$
4
  • $\begingroup$ I appreciate the response, but I am getting an error message when I attempt to try and compute that. Could you share a quick explanation for what "EuclideanDistance @@@ Subsets[list,{2}] // Min" means? $\endgroup$
    – Samuel Reid
    Commented Jun 21, 2012 at 23:24
  • $\begingroup$ Okay, I believe you edited your answer so that I would input: "EuclideanDistance @@@ Subsets[N@list, {2}] // Min" Since the output was "0.51..." this means that there exists two points which are that distance apart? $\endgroup$
    – Samuel Reid
    Commented Jun 21, 2012 at 23:28
  • 1
    $\begingroup$ @Samuel I made a transcription error in my post: I left out N. With that in place it should work. N converts to numeric. Subsets[x, {2}] gets all pairs of elements from x. EuclideanDistance determines the distance between two vectors; it is "Apply'ed at level one" with the operator @@@ which means that each pair of vertices is fed to the function in turn. Finally Min is used to find the minimum value. Documentation for each element can be found by highlighting it and pressing F1 in the Notebook. $\endgroup$
    – Mr.Wizard
    Commented Jun 21, 2012 at 23:29
  • $\begingroup$ Thank you for the explanation, I have solved that question now thanks to your answer! $\endgroup$
    – Samuel Reid
    Commented Jun 21, 2012 at 23:34
5
$\begingroup$

The figure I generated from the code in my answer ended up in a paper I wrote: arxiv.org/abs/1210.5756 if anyone is interested!

Thanks to the help of J.M. I was able to solve all of my problems relating to this question. I first used the following code:

pts = FullSimplify[
    TrigExpand[(#1 Append[Sin[#2] Through[{Cos, Sin}[#3]], 
        Cos[#2]])]] & @@@ {{0, 0, 0}, {1, 0, 0}, {1, Pi/3, 0}, {1, 
    Pi/3, ArcCos[1/3]}, {1, Pi/3, 2 ArcCos[1/3]}, {1, Pi/3, 
    3 ArcCos[1/3]}, {1, Pi/3, 
    4 ArcCos[1/3]}, {1, (2 Pi)/3, (ArcCos[1/3])/2}, {1, (2 Pi)/
     3, (3 ArcCos[1/3])/2}, {1, (2 Pi)/3, (5 ArcCos[1/3])/
     2}, {1, (2 Pi)/3, (7 ArcCos[1/3])/2}, {1, (2 Pi)/
     3, (9 ArcCos[1/3])/2}, {1, Pi, 0}}

Given the output of this, I was able to create a list $v$ of my vertices in Cartesian coordinates as,

 v = {{0, 0, 0}, {0, 0, 1}, {Sqrt[3]/2, 0, 1/2}, {1/(2 Sqrt[3]), Sqrt[
   2/3], 1/2}, {-(7/(6 Sqrt[3])), (2 Sqrt[2/3])/3, 1/
   2}, {-(23/(18 Sqrt[3])), -((5 Sqrt[2/3])/9), 1/2}, {17/(
   54 Sqrt[3]), -((28 Sqrt[2/3])/27), 1/2}, {1/Sqrt[2], 1/
   2, -(1/2)}, {-(1/(3 Sqrt[2])), 5/6, -(1/2)}, {-(11/(9 Sqrt[2])), 1/
   18, -(1/2)}, {-(13/(27 Sqrt[2])), -(43/54), -(1/2)}, {73/(
   81 Sqrt[2]), -(95/162), -(1/2)}, {0, 0, -1}}

By observing the following labelled vertices in J.M.'s answer and comparing it to my constructed model out of D&D dice I was able to come up with the following faces as a list.

i = {{1, 2, 7}, {2, 3, 4}, {3, 4, 8}, {4, 5, 2}, {2, 5, 6}, {2, 6, 
   7}, {1, 2, 3}, {7, 11, 12}, {6, 11, 7}, {8, 9, 4}, {13, 9, 8}, {13,
    10, 9}, {13, 11, 10}, {13, 12, 11}, {13, 1, 8}, {12, 1, 13}, {11, 
   1, 10}, {10, 9, 1}, {9, 1, 4}, {7, 1, 12}, {6, 1, 11}, {5, 4, 
   1}, {3, 1, 8}, {5, 6, 1}}

From this, I was able to use the Graphics3D and GraphicsComplex commands to generate the following figure by

Graphics3D[{Opacity[.95], Yellow, GraphicsComplex[v, Polygon[i]], 
  MapIndexed[Style[Text[First[#2], #1, {-1, -1}], Red, 18] &, pts]}]

Figure

Thank you J.M.

Improve this answer
$\endgroup$
1

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.