Thursday, June 1, 2017

3D Design in Mathematica: Custom Dice

Today we continue our series in 3D Design in Mathematica. I'll teach you how to use the RegionPlot3D command to create custom dice. Let's first start off with a story I teach in my combinatorics class. Most people are familiar with a cubical die having six sides labeled with pips representing the numbers 1 through 6, each of which has the same probability of coming up when the die is rolled.
 

What happens when two dice are rolled and we consider their sum? The possible values are between 2 and 12 with a predictable distribution.
 
1 2 3 4 5 6
1 2 3 4 5 6 7
2 3 4 5 6 7 8
3 4 5 6 7 8 9
4 5 6 7 8 9 10
5 6 7 8 9 10 11
6 7 8 9 10 11 12

Question of the day: Are there two other dice (not labeled 1 through 6) that when rolled and summed have the same chance of giving the sums in this table?
 
Answer of the day: Yes! Consider the pair of Sicherman dice. The first die has sides 1, 2, 2, 3, 3, and 4, while the second die has sides 1, 3, 4, 5, 6, and 8. Here is the distribution of sums of these two dice.
 
1 2 2 3 3 4
1 2 3 3 4 4 5
3 4 5 5 6 6 7
4 5 6 6 7 7 8
5 6 7 7 8 8 9
6 7 8 8 9 9 10
8 9 10 10 11 11 12

You can count how many times each number appears to verify that the number of appearances of 2, 3, ... 12 are the same for each pair of dice. Let's modify these dice even further by subtracting one from each number on the first die (0, 1, 1, 2, 2, 3) and adding one to each number on the second die (2, 4, 5, 6, 7, 9), which doesn't change any sum one bit!
 
0 1 1 2 2 3
2 2 3 3 4 4 5
4 4 5 5 6 6 7
5 5 6 6 7 7 8
6 6 7 7 8 8 9
7 7 8 8 9 9 10
9 9 10 10 11 11 12

This example is a great application of generating functions, because the existence of these dice is a direct result of the polynomial identity: \[(x^1+x^2+x^3+x^4+x^5+x^6)^2=(x^0+2x^1+2x^2+x^3)(x^2+x^4+x^5+x^6+x^7+x^9).\] Since these modified Sicherman dice are not easy to find at your local store (or at ANY store), we'll design our own copies as our task for today. If you're interested in dice, I suggest checking out The Dice Lab by Henry Segerman and Robert Fathauer where they've taken a mathematician's view toward perfecting dice.
 
Also, if you've missed an installment in the series, you can learn about designing a name ring, a geometric terrarium, or a country keychain.
 
Now on to the tutorial!
 

Step One: Determine a plan for the dice

One of the things about standard dice that I consider crucial is that the opposite sides of each die add to the same number. The 1 is opposite the 6, the 2 is opposite the 5, and the 3 is opposite the four. If we were to build a die out of paper and unfold the sides, we would get the following two-dimensional visualization:

We need to now place the numbers 0, 1, 1, 2, 2, 3 on the first die; I'll choose to continue the convention by ensuring that the 0 is opposite the 3 and each 1 is opposite a 2. (If you prefer to place the 1s opposite each other and the 2s opposite each other, you can modify our code to make your own dice!) I also plan to organize it so that the diagonals formed by the pips of the 2s are oriented in the same way.

The decisions in placing the numbers 2, 4, 5, 6, 7, 9 on the second die include the slant of the pips on the two and the orientation of the pips on the 6 and the 7. I think I'll just wing it and if my work turns out differently from my sketch then so be it!
 

Step Two: Understand how RegionPlot3D works

Today we'll be using Mathematica's RegionPlot3D command, which is one of the few ways in which Mathematica allows you to intersect three-dimensional regions. (Disappointingly, you can't intersect 3D MeshRegion objects like we used last time!)
 
RegionPlot3D outputs the three-dimensional object defined by a set of restrictions you specify along with boolean operators that indicate how your restrictions interact.
 
For instance, if you want to find the intersection of two spheres, you want points that are in both the first sphere AND the second sphere, so you would use the AND operator && like this:
RegionPlot3D[ x^2+y^2+z^2 <= 1 && (x-1)^2+y^2+z^2 <= 1,
 {x, 0, 1}, {y, -1, 1}, {z, -1, 1}]

If on the other hand you would like to find the union of two spheres, you want points that are in either the first sphere OR the second sphere, so you would use the OR operator || like this:
RegionPlot3D[ x^2+y^2+z^2 <= 1 || (x-1)^2+y^2+z^2 <= 1,
 {x, -1, 2}, {y, -1.5, 1.5}, {z, -1.5, 1.5}]

You must specify the bounds on the $x$, $y$, and $z$ variables where Mathematica will be looking for the valid points.
 
When we are making our dice, we will start with a basic cube, defined by points where the $x$, $y$, and $z$ values are between $-1$ and $1$:
RegionPlot3D[Abs[x] <= 1 && Abs[y] <= 1 && Abs[z] <= 1, {x, -1.1, 1.1}, {y, -1.1, 1.1}, {z, -1.1, 1.1}]
so that the equations of the sides of the cube are $x=1$, $x=-1$, $y=1$, $y=-1$, $z=1$, $z=-1$.
 

Now suppose we want to create the pips of the dice. I will do so by removing spheres from each of the faces. For instance, if we want to create one pip on the $z=1$ face, which would be centered at coordinates $(0,0,1)$, we will want the points that are in the cube with the points AND outside the sphere \[x^2+y^2+(z-1)^2=r^2,\] which we do with the code
pip = .04; RegionPlot3D[
  Abs[x] <= 1 && Abs[y] <= 1 && Abs[z] <= 1 &&
  (x^2 + y^2 + (z - 1)^2 >= pip)
  , {x, -1.1, 1.1}, {y, -1.1, 1.1}, {z, -1.1, 1.1},
  PlotStyle -> White, Mesh -> None, Axes -> False, Boxed -> False]

We have chosen $r=.2$, so $r^2=.04$. Note that we have changed the color using PlotStyle -> White, removed the lines from the surface with the option Mesh -> None, and removed the bounding wire cube and tickmarks using Axes -> False and Boxed -> False.
 
One of the issues with RegionPlot3D is the resolution of the file you create. In order to have a better approximation of the three-dimensional object that is determined by the inequalities you provide, you can use the PlotPoints option, which tells how much sampling you want Mathematica to do in the range you specify. Here you can see the difference in the result when you specify PlotPoints -> 10, PlotPoints -> 50, PlotPoints -> 100, and PlotPoints -> 200:
 

During the testing phase I used PlotPoints -> 50, but when creating the final STL file I specified PlotPoints -> 250 which took quite a while to compute.
 

Step Three: Rounding the Edges

We'll get back to the pips in a little bit, but first let's perfect the cube. You'll notice that when PlotPoints -> 200 is specified, the die starts to look more and more like a perfect cube. If you look at a normal die, you'll see that it is not a perfect cube—the edges are rounded. What sort of inequality restriction works to make a rounded edge? We need some sort of cylindrical constraint like \[(x-h)^2+(y-k)^2 < r^2.\] To line up with the faces of the cube, we need the radius of the cylinder to be the same as the distance from the point (h,k) to both faces. So in the simplest case we need something that looks like \[(x - .8)^2 + (y - .8)^2 < .2^2\] since it says that the distance to the $x=1$ face and to the $y=1$ face equals the radius $0.2$. (I tried a couple different radii and this one looked the best to my eyes.)
 
But simply including this cylindrical restriction would only include the part of the cube that is in the cylinder, which defeats the purpose.
RegionPlot[((x - .8)^2 + (y - .8)^2 < .2^2), {x, 0, 1.1}, {y, 0, 1.1}]

We need to instead merge this with two additional restrictions that either you are in the cylinder OR you satisfy $x<.8$ OR you satisfy $y<.8$. By doing this, the restriction on our cube is exactly the rounded bezel we wanted, as you can see here.
RegionPlot[((x-.8)^2+(y-.8)^2<.2^2||x<=.8||y<=.8)
  {x, 0, 1.1}, {y, 0, 1.1}]

We'll have to include this restriction for all twelve edges of the cube, which is coded as follows:
RegionPlot3D[Abs[x]<=1&&Abs[y]<=1&&Abs[z]<=1&&
 ((x-.8)^2+(y-.8)^2<.2^2||x<=.8||y<=.8)&&
 ((x-.8)^2+(y+.8)^2<.2^2||x<=.8||y>=-.8)&&
 ((x+.8)^2+(y-.8)^2<.2^2||x>=-.8||y<=.8)&&
 ((x+.8)^2+(y+.8)^2<.2^2||x>=-.8||y>=-.8)&&
 ((x-.8)^2+(z-.8)^2<.2^2||x<=.8||z<=.8)&&
 ((x-.8)^2+(z+.8)^2<.2^2||x<=.8||z>=-.8)&&
 ((x+.8)^2+(z-.8)^2<.2^2||x>=-.8||z<=.8)&&
 ((x+.8)^2+(z+.8)^2<.2^2||x>=-.8||z>=-.8)&&
 ((y-.8)^2+(z-.8)^2<.2^2||y<=.8||z<=.8)&&
 ((y-.8)^2+(z+.8)^2<.2^2||y<=.8||z>=-.8)&&
 ((y+.8)^2+(z-.8)^2<.2^2||y>=-.8||z<=.8)&&
 ((y+.8)^2+(z+.8)^2<.2^2||y>=-.8||z>=-.8)&&
 (x^2+y^2+(z-1)^2>=pip)
 ,{x,-1.1,1.1},{y,-1.1,1.1},{z,-1.1,1.1},
 PlotPoints->100,PlotStyle->White,Mesh->None,Axes->False,Boxed->False]
and looks like this:
 

Note that we could have used a similar method to round the corners, but I preferred this styling.
 

Step Four: Lay out the pips

Now onto the task of placing the pips. Let's start with my Modified Sicherman Die I with sides (0,1,1,2,2,3), which will be easier for us to code. We'll put the one-pip sides on the $x=-1$ and $y=1$ faces, the two-pip sides on the $x=1$ and $y=-1$ faces, and the three-pip side on the $z=-1$ face. Here is the Mathematica code for this:
(* 1 side *)
  ((x + 1)^2 + y^2 + z^2 >= pip) &&
 
(* 1 side *)
  (x^2 + (y - 1)^2 + z^2 >= pip) &&
 
(* 2 side *)
  ((x - 1)^2 + (y + .5)^2 + (z + .5)^2 >= pip) &&
  ((x - 1)^2 + (y - .5)^2 + (z - .5)^2 >= pip) &&
 
(* 2 side *)
  ((x + .5)^2 + (y + 1)^2 + (z + .5)^2 >= pip) &&
  ((x - .5)^2 + (y + 1)^2 + (z - .5)^2 >= pip)
 
(* 3 side *)
  ( (x + .5)^2 + (y + .5)^2 + (z + 1)^2 >= pip) &&
  ( x^2 + y^2 + (z + 1)^2 >= pip) &&
  ( (x - .5)^2 + (y - .5)^2 + (z + 1)^2 >= pip) &&
As you can see, the three-pip side has three spheres, centered at $(-.5,-.5,-1)$, $(0,0,-1)$, and $(.5,.5,-1)$, all indeed lying on the face $z=-1$.
 
For my Modified Sicherman Die II with sides (2,4,5,6,7,9), we place the two- and nine-pip sides on the $z$ faces, the five- and six-pip sides on the $x$ faces, and the four- and seven-pip sides on the $y$ faces:
(* 2 side *)
  ((x + .5)^2 + (y + .5)^2 + (z - 1)^2 >= pip) &&
  ((x - .5)^2 + (y - .5)^2 + (z - 1)^2 >= pip) &&
 
(* 9 side *)
  ((x + .5)^2 + (y + .5)^2 + (z + 1)^2 >= pip) &&
  ((x + .5)^2 + y^2 + (z + 1)^2 >= pip) &&
  ((x + .5)^2 + (y - .5)^2 + (z + 1)^2 >= pip) &&
  (x^2 + (y + .5)^2 + (z + 1)^2 >= pip) &&
  (x^2 + y^2 + (z + 1)^2 >= pip) &&
  (x^2 + (y - .5)^2 + (z + 1)^2 >= pip) &&
  ((x - .5)^2 + (y + .5)^2 + (z + 1)^2 >= pip) &&
  ((x - .5)^2 + y^2 + (z + 1)^2 >= pip) &&
  ((x - .5)^2 + (y - .5)^2 + (z + 1)^2 >= pip) &&
 
(* 6 side *)
  ((x - 1)^2 + (y + .5)^2 + (z + .5)^2 >= pip) &&
  ((x - 1)^2 + (y)^2 + (z + .5)^2 >= pip) &&
  ((x - 1)^2 + (y - .5)^2 + (z - .5)^2 >= pip) &&
  ((x - 1)^2 + (y + .5)^2 + (z - .5)^2 >= pip) &&
  ((x - 1)^2 + (y)^2 + (z - .5)^2 >= pip) &&
  ((x - 1)^2 + (y - .5)^2 + (z + .5)^2 >= pip) &&
 
(* 5 side *)
  ((x + 1)^2 + y^2 + z^2 >= pip) &&
  ((x + 1)^2 + (y + .5)^2 + (z + .5)^2 >= pip) &&
  ((x + 1)^2 + (y + .5)^2 + (z - .5)^2 >= pip) &&
  ((x + 1)^2 + (y - .5)^2 + (z + .5)^2 >= pip) &&
  ((x + 1)^2 + (y - .5)^2 + (z - .5)^2 >= pip) &&
 
(* 4 side *)
  ((x + .5)^2 + (y - 1)^2 + (z + .5)^2 >= pip) &&
  ((x + .5)^2 + (y - 1)^2 + (z - .5)^2 >= pip) &&
  ((x - .5)^2 + (y - 1)^2 + (z + .5)^2 >= pip) &&
  ((x - .5)^2 + (y - 1)^2 + (z - .5)^2 >= pip) &&
 
(* 7 side *)
  ((x + .5)^2 + (y + 1)^2 + (z + .5)^2 >= pip) &&
  ((x)^2 + (y + 1)^2 + (z - .5)^2 >= pip) &&
  ((x + .5)^2 + (y + 1)^2 + (z - .5)^2 >= pip) &&
  ((x)^2 + (y + 1)^2 + (z)^2 >= pip) &&
  ((x - .5)^2 + (y + 1)^2 + (z + .5)^2 >= pip) &&
  ((x)^2 + (y + 1)^2 + (z + .5)^2 >= pip) &&
  ((x - .5)^2 + (y + 1)^2 + (z - .5)^2 >= pip)
All these spheres were placed by hand with coordinates in the set $\{-1,-.5,0,.5,1)$. Here's a fun picture of what it looks likes when all the pips' spheres are added to the cube!
 

Step Five: Get them printed!

To serve as a recap, here is the entirety of the code that generates my Modified Sicherman Die I.
pip = .04;
die = RegionPlot3D[
  Abs[x] <= 1 && Abs[y] <= 1 && Abs[z] <= 1 &&
  ((x-.8)^2+(y-.8)^2<.2^2||x<=.8||y<=.8)&&
  ((x-.8)^2+(y+.8)^2<.2^2||x<=.8||y>=-.8)&&
  ((x+.8)^2+(y-.8)^2<.2^2||x>=-.8||y<=.8)&&
  ((x+.8)^2+(y+.8)^2<.2^2||x>=-.8||y>=-.8)&&
  ((x-.8)^2+(z-.8)^2<.2^2||x<=.8||z<=.8)&&
  ((x-.8)^2+(z+.8)^2<.2^2||x<=.8||z>=-.8)&&
  ((x+.8)^2+(z-.8)^2<.2^2||x>=-.8||z<=.8)&&
  ((x+.8)^2+(z+.8)^2<.2^2||x>=-.8||z>=-.8)&&
  ((y-.8)^2+(z-.8)^2<.2^2||y<=.8||z<=.8)&&
  ((y-.8)^2+(z+.8)^2<.2^2||y<=.8||z>=-.8)&&
  ((y+.8)^2+(z-.8)^2<.2^2||y>=-.8||z<=.8)&&
  ((y+.8)^2+(z+.8)^2<.2^2||y>=-.8||z>=-.8)&&
  ((x + 1)^2 + y^2 + z^2 >= pip) &&
  (x^2 + (y - 1)^2 + z^2 >= pip) &&
  ((x - 1)^2 + (y + .5)^2 + (z + .5)^2 >= pip) &&
  ((x - 1)^2 + (y - .5)^2 + (z - .5)^2 >= pip) &&
  ((x + .5)^2 + (y + 1)^2 + (z + .5)^2 >= pip) &&
  ((x - .5)^2 + (y + 1)^2 + (z - .5)^2 >= pip)
  ( (x + .5)^2 + (y + .5)^2 + (z + 1)^2 >= pip) &&
  ( x^2 + y^2 + (z + 1)^2 >= pip) &&
  ( (x - .5)^2 + (y - .5)^2 + (z + 1)^2 >= pip) &&
  , {x, -1.1, 1.1}, {y, -1.1, 1.1}, {z, -1.1, 1.1}, PlotPoints -> 250,
  PlotStyle -> White, Mesh -> None, Axes -> False, Boxed -> False]
After exporting the STL files for my two dice (using PlotPoints -> 250), here is a rendering of the final version of my modified Sicherman dice on Sketchfab:
 

I printed them on the local Lulzbot Mini 3D printers that the Queens College Art department has so graciously loaned us. They look good too!
 

You can buy your own pair of modified Sicherman dice on Shapeways or print your own copy of the STL files I posted on Thingiverse. I don't guarantee that my modified Sicherman dice are unbiased because by removing material from the sides of the dice they no longer symmetrical.
 
The same technique above shows that a 4-sided die with sides (1,4,4,7) and a 9-sided die with (1,2,2,3,3,3,4,4,5) would also have the same distribution of sums—now THAT would be a unique pair of dice! What other dice would you create?

Christopher Hanusa's portfolio is available online at
Purchase a copy of this and other 3D printed artwork
at Hanusa ≀ Design on Shapeways.

Monday, May 1, 2017

3D Design in Mathematica: Costa Rica Keychain

Hi everyone! Welcome back to another 3D Design in Mathematica Tutorial. Last time I showed how to create a polyhedral terrarium. Today I will use Mathematica's MeshRegion command to design a keychain shaped like a country. I had the opportunity to visit Costa Rica in February and especially enjoyed my visit to the cloud forests of Monteverde, so let's choose Costa Rica for our example.
 

Step One: Import the shape of Costa Rica

We'll be relying on one of the strengths of Mathematica and the whole Wolfram suite—its vast amount of curated data. The command CountryData can access diverse information about countries such as their GDP, their population, their borders, their languages, and even their flags. For instance, we can access the shape of Costa Rica by using the following command.
CountryData["CostaRica", "Shape"]

What we would really like are the coordinates of the vertices of this shape, which we can acquire using the command
vertices =
     CountryData[Entity["Country", "CostaRica"], "Polygon"][[1, 1, 1]];
The first few elements of this list are
{{11.0785, -85.6911}, {11.2142, -85.6144}, {11.21, -85.5642},
  {11.1667, -85.5264}, ...
which are the longitude and latitude of each of the coordinates.
 

Step Two: Simplify the boundary

Keeping an eye toward printability, I realized that Costa Rica's actual land and sea borders are too complicated to be able to be printed in metal. (Shapeways has certain tolerances that must be adhered to for them to accept your file.) So I needed to find a way to smooth the border to reduce the complexity. After searching around for quite a while, I learned about a couple well-known simplification algorithms including Mike Bostock's awesome visualization implementing the Visvalingam-Whyatt algorithm.
 
I found this list of implementations of Mike's simplify code and was able to run the python implementation on repl.it. I needed to take the data from Mathematica and put it into the right python format to input into simplify, which would take a pair of coordinates {11.0785, -85.6911} and output them as the string {'x':11.0785, 'y':-85.6911}. So I used Mathematica's String operations.
StringJoin @@
  Map["{'x':" <> ToString[#[[1]]] <>
     ", 'y':" <> ToString[#[[2]]] <> "}," &, vertices]
I input the resulting code:
[{'x':11.0785, 'y':-85.6911}, {'x':11.2142, 'y':-85.6144}, ... ,
   {'x':11.0782, 'y':-85.6907}]
into simplify with the parameter 0.05. The output was again in python format, which I needed to reconvert into Mathematica format by deleting extraneous characters:
StringDelete[StringDelete[newpoints, "'y':"], "'x':"]
We can compare the before and after of this process:
 

Notice that there are still some jagged parts of the polygon, so I decided to make a few manual adjustments too. The best way I have found to do this is to use the ToolTip command
Graphics[{Polygon@simplified, Red, Map[Tooltip[Point@#, #] &, simplified]}]
which displays a vertex's coordinates when you hover over it so that I know I am removing the correct vertices.
 

By the end of this process, I had reduced the original polygon with over 1400 vertices to a polygon with 55 vertices that still contains the essence of the shape of Costa Rica.
simplified = {{ -85.6911, 11.0785}, { -85.6144, 11.2142}, { -84.9387, 10.9541}, { -84.7104, 11.091}, { -84.4801, 10.973}, { -84.3577, 10.9965}, { -84.2041, 10.7839}, { -84.0131, 10.7908}, { -83.9293, 10.7087}, { -83.6779, 10.7938}, { -83.6978, 10.8801}, { -83.6401, 10.9096}, { -83.3902, 10.3557}, { -82.7786, 9.66272}, { -82.62, 9.57017}, { -82.6712, 9.49412}, { -82.8549, 9.57112}, { -82.9361, 9.47312}, { -82.9359, 9.07847}, { -82.7118, 8.92455}, { -82.9192, 8.76513}, { -82.83, 8.63599}, { -82.8396, 8.48029}, { -83.0517, 8.33343}, { -83.1454, 8.36625}, { -83.1207, 8.60242}, { -83.3745, 8.74827}, { -83.4645, 8.72645}, { -83.2844, 8.54143}, { -83.2774, 8.3865}, { -83.5892, 8.45915}, { -83.7345, 8.59876}, { -83.5704, 8.84997}, { -83.6403, 9.05175}, { -84.2461, 9.49397}, { -84.6181, 9.58172}, { -84.703, 9.92881}, { -84.774, 9.99558}, { -85.2166, 10.1833}, { -85.1987, 10.0272}, { -84.9217, 9.9254}, { -84.8642, 9.82857}, { -85.1111, 9.559}, { -85.2539, 9.78983}, { -85.6684, 9.90357}, { -85.8752, 10.3566}, { -85.7732, 10.4469}, { -85.811, 10.5156}, { -85.6993, 10.6107}, { -85.6584, 10.766}, { -85.9497, 10.8896}, { -85.8843, 10.9498}, { -85.7141, 10.9201}, { -85.755, 11.0254}, { -85.6907, 11.0782}}

Step Three: Define an interior

I would like to make a raised lip around the outside of the keychain, so I will use some code I wrote last year that creates a boundary of a fixed thickness on the inside or outside of a given polygon.
 
Before I apply it, I'll remove some of the peninsulas from our polygon and some of the redundant vertices and visualize the difference:
minimal = { { -85.6144, 11.2142}, { -84.9387, 10.9541}, { -84.7104, 11.091}, { -84.4801, 10.973}, { -84.3577, 10.9965}, { -84.2041, 10.7839}, { -84.0131, 10.7908}, { -83.9293, 10.7087}, { -83.5979, 10.8238}, { -83.3902, 10.3557}, { -82.7786, 9.66272}, { -82.9361, 9.47312}, { -82.9359, 9.07847}, { -82.9192, 8.76513}, { -83.1207, 8.60242}, { -83.3745, 8.74827}, { -83.5704, 8.84997}, { -83.6403, 9.05175}, { -84.2461, 9.49397}, { -84.6181, 9.58172}, { -84.703, 9.92881}, { -84.774, 9.99558}, { -85.2166, 10.1833}, { -85.1987, 10.0272}, { -85.2539, 9.78983}, { -85.6684, 9.90357}, { -85.8752, 10.3566}, { -85.7732, 10.4469}, { -85.811, 10.5156}, { -85.6584, 10.766}, { -85.7141, 10.9201}};
Graphics[{Polygon@simplified, Gray, Polygon@minimal]}]

Now let's describe the algorithm to create a polygon nested inside our bounding shape—we'll be using geometry and trigonometry! We define the vertices of the interior polygon in relation to the vertices of the exterior polygon. The interior vertex is found along the angle bisector of the edges incident with the exterior vertex. We determine its final position by ensuring that the distance to each exterior edge is the prescribed distance ep.
 
Let me give you the code and then dissect it.
ep = .15;
boundarypoints = Reverse@minimal;

interiorhalfangles =
  Table[FullSimplify[
   Mod[
    Apply[ArcTan,
     (boundarypoints[[i]] -
      boundarypoints[[Mod[i + 1, Length[boundarypoints], 1]]])
    ] -
    Apply[ArcTan,
     (boundarypoints[[Mod[i + 2, Length[boundarypoints], 1]]] -
      boundarypoints[[Mod[i + 1, Length[boundarypoints], 1]]])
    ],
   2 Pi]],
  {i, Length[boundarypoints]}]/2;

edgedirections =
  Table[FullSimplify[
   Apply[ArcTan,
    boundarypoints[[Mod[i + 2, Length[boundarypoints], 1]]] -
    boundarypoints[[Mod[i + 1, Length[boundarypoints], 1]]]]],
  {i, Length[boundarypoints]}];

interiorvectors =
  Map[AngleVector, interiorhalfangles + edgedirections];

interiorvertices =
  MapThread[#1 + ep/Sin[#3] #2 &,
   {RotateLeft[boundarypoints], interiorvectors, interiorhalfangles}]
We choose our thickness (ep for epsilon) to be .15. Notice that the following command is to invert the order of the points on the bounding polygon. If we had left the list as is, the new polygon would have been constructed on the outside of the original polygon instead of on the inside.
 
Then I find the interior half angles by using a special overloading of the ArcTan command. The expected functionality of ArcTan is that ArcTan applied to a single number finds the angle whose tangent is that number. More useful in this context is the two argument version of ArcTan:
 
Useful Command: ArcTan[x,y] gives the angle that the line through (x,y) makes with the positive x-axis.
 
I have used ArcTan to find the angles that each of the directed edges make with the positive x-axis and taking their difference modulo 2π so that the number is between 0 and 2π. Another command that seemed useful when I started programming was VectorAngle, which finds the angle between two vectors, but that gives the unsigned angle instead of the signed angle between the two vectors.
 
If we add the interior half angle to the angle that the corresponding edge makes with the x-axis, we get the direction of the vector leaving the exterior vertex toward the interior vertex. Applying the command AngleVector gives the unit vector in that direction. (It gives me warm fuzzy feelings to know that Mathematica has both a command VectorAngle and a command AngleVector!)
 
The interior vertices are finally calculated using trigonometry to calculate the distance along this unit vector from the exterior vertex.
 
The final result is a polygon that nests perfectly inside the original Costa Rica shape.
Graphics[{Polygon@simplified, Red, Polygon@interiorvertices}]

Step Four: Create a Mesh Object

Now that we have our exterior polygon and our interior polygon, we will convert these Graphics objects into MeshRegion objects, since this seems to be the underlying structure necessary to export three dimensional objects to STL files. The first step is to use DiscretizeGraphics to convert the polygons into MeshRegion objects.
interior = DiscretizeGraphics@Graphics@Polygon@interiorvertices
exterior = DiscretizeGraphics@Graphics@Polygon@simplified
Then we use RegionDifference to excise the interior from the exterior.
lip = RegionDifference[exterior, interior]
The last pieces we need are the boundaries of these regions.
exteriorbdry = RegionBoundary@exterior
interiorbdry = RegionBoundary@interior
With these building blocks, we can create our three-dimensional model. We define four variables that are the heights of each of the layers, making sure that they are numerical / decimal instead of exact / infinitely precise numbers. There are errors if you use exact numbers like '0' instead of '0.'. I am not sure why.
 
Pro tip: Notice that I have defined these variables outside the subsequent code. By separating the definition of the variables, it makes it easier to modify the rest of the code later if you need to change a parameter for aesthetic or printing reasons.
extbottom = 0.;
intbottom = 0.1;
inttop = 0.2;
exttop = 0.3;
And then build the pieces that comprise the hull of the model by using a RegionProduct command.
Show[
  RegionProduct[interior, Point[{{intbottom}}]],
  RegionProduct[interior, Point[{{inttop}}]],
  RegionProduct[interiorbdry, Line[{{extbottom}, {intbottom}}]],
  RegionProduct[interiorbdry, Line[{{inttop}, {exttop}}]],
  RegionProduct[lip, Point[{{extbottom}}]],
  RegionProduct[lip, Point[{{exttop}}]],
  RegionProduct[RegionBoundary@exteriorbdry,
                 Line[{{extbottom}, {exttop}}]]]
You can see each of these objects individually and all assembled together.

Step Five: Add a loop

Since we want to use this object as a keychain, we need to add in a ring onto which we can clip a key ring. To do this we will be adding a torus into the object, which has this general form.
thickness = .15;
innerradius = .8;
outerradius = 2;
xcoord = -84;
ycoord = 10.75;
zcoord = Mean[{extbottom, exttop}];
loop = ParametricPlot3D[{
  (outerradius thickness + innerradius thickness Cos[v]) Cos[u] +
     xcoord,
  (outerradius thickness + innerradius thickness Cos[v]) Sin[u] +
     ycoord + 2 thickness,
  thickness Sin[v] + zcoord},
  {u, 0, 2 Pi}, {v, 0, 2 Pi}, Mesh -> None, PlotPoints -> 200];

I chose the ring to have the same thickness as the body and played with the other parameters, especially the x-, y-, and z-translations to figure out where best on the model to place it. One reason why I think my choices work well is because the circle is basically just North of the center of gravity—the map of Costa Rica will have North oriented upward when dangling from the keychain!
 

Step Six: Send to the printer!

Now let's print out the model! (Remember that there is more detail on the prototyping and printing processes at the bottom of the name ring design post.) One thing we have to take into consideration is that stainless steel requires a 1 mm thickness everywhere, which may mean that you will have to change the thickness parameters above if you want to shrink the keychain much smaller. Here is what Shapeways gives as a 3D rendering of the keychain
 

And here is a 3D rendering of the keychain by Sketchfab
 

Now you have the tools to make your own keychain for any country or administrative region. What countries are on your bucket keychain list? Until next time!

Christopher Hanusa's portfolio is available online at
Purchase a copy of this and other 3D printed artwork
at Hanusa ≀ Design on Shapeways.

Monday, April 3, 2017

3D Design in Mathematica: Polyhedral Terrarium

Today I continue my series of Mathematica Tutorials for 3D printing. Last time I showed how to create a custom-designed name ring. In this post I will discuss how to design a polyhedral terrarium. You may have noticed that geometric objects are very fashionable these days. A quick Google Image search for Geometric Terrarium gives a wide variety of styles and manufacturers.
 

We're going to make our own terrarium using Mathematica. I'm inspired to write about this because I'm giving a talk in May at Construct3D about 3D printing techniques in Mathematica that I teach my students, and this is a case in point—my student Isaac Deonarine used similar techniques to create a Dodecahedral Terrarium. Click here to interact with a 3D rendering of his work:

or see the Geometric Terrarium at Shapeways. Now, on to the tutorial!
 

Step One: Choose a Polyhedron

The Mathematica team curated a large amount of polyhedra that can be accessed using the command PolyhedronData. The full list of 195 entries can be accessed using the command PolyhedronData[All], and all 195 polyhedra can be visualized by typing
Map[PolyhedronData, PolyhedronData[All]]
Alternatively, Mathematica's thorough Documentation Center suggests using the code
Manipulate[
 Column[{PolyhedronData[g], PolyhedronData[g, p]}],
  {g, PolyhedronData[All]},
  {p, Complement @@ PolyhedronData /@ {"Properties", "Classes"}}
]
to generate an interactive interface for navigating the data:


I've chosen to work with the Snub Cube.


The snub cube is one of my favorite polyhedra because it has chirality—there are two distinct snub cubes based on the way it is built— (also an important concept in chemistry...) and because it cannot be built using the mathematical building blocks ZomeTools!
 

Step Two: Develop the schematics

Now let's gather some data about snub cubes. It is useful to know the coordinates of the vertices, the pairs of vertices that form the edges, and faces of the polyhedron. These are all simple to request.
vertices = N@PolyhedronData["SnubCube", "VertexCoordinates"]
edges = N@PolyhedronData["SnubCube", "Edges"]
faces = N@PolyhedronData["SnubCube", "Faces"]
The N@ prefix asks for numerical approximations of these coordinates so that we are not dragging around the exact coordinates which involve roots of the polynomial \[32 x^6-32 x^4-12 x^2-1.\]
Fun Fact: N@ is also a colloquialism from Pittsburgh, PA, where I grew up. It is a filler that means "and so on" and might be used in a sentence such as "Yinz goin' dahntahn n'at?".

What I would like to do is to remove some of the faces. If you look at the structure of the faces variable, you see that it is a GraphicsComplex object listing its coordinates and the list of vertices involved in each face. A very helpful thing to do is to put the labels of the vertices on the vertices to understand how the polyhedron is constructed. We can do that by putting the vertex index at the coordinates of the vertex.
coords = faces[[1]]
facelist = faces[[2, 1]]
Graphics3D[{
  Table[Text[Style[i, Large], verts[[i]]], {i, Length[verts]}],
  GraphicsComplex[coords, Polygon@facelist]
}, Boxed -> False]
which looks like this:


The variable facelist contains the list of vertices for each of the polygons:
{{3, 1, 17}, {3, 17, 9}, {3, 19, 2}, {3, 9, 19}, {1, 4, 20}, {1, 20, 11}, {1, 11, 17}, {2, 19, 12}, {2, 18, 4}, {2, 12, 18}, {4, 18, 10}, {4, 10, 20}, {17, 11, 13}, {19, 9, 15}, {18, 12, 14}, {20, 10, 16}, {9, 21, 15}, {11, 23, 13}, {12, 24, 14}, {10, 22, 16}, {13, 23, 7}, {13, 7, 21}, {15, 21, 5}, {15, 5, 24}, {16, 22, 6}, {16, 6, 23}, {14, 24, 8}, {14, 8, 22}, {21, 7, 5}, {23, 6, 7}, {24, 5, 8}, {22, 8, 6}, {1, 3, 2, 4}, {21, 9, 17, 13}, {24, 12, 19, 15}, {10, 18, 14, 22}, {11, 20, 16, 23}, {8, 5, 7, 6}}
For example, in the above figure you can see the triangular face with vertices {3, 17, 9} on the left and the square face with vertices {8, 5, 7, 6} on the right.

I am going to define some vertex sets in order to simplify some future commands. Let's define the sets of vertices on the top and bottom faces of the snub cube and the vertices on the upper and lower halves of the snub cube.
topvs = {12, 15, 19, 24};
bottomvs = {16, 20, 11, 23};
uppervs = Quiet@Flatten@Position[vertices, _?(#[[3]] > 0 &)];
lowervs = Quiet@Flatten@Position[vertices, _?(#[[3]] < 0 &)];
I'd like to only keep the faces at the bottom of the snub cube, which I could have done by hand, but because of the previous definitions, I can calculate algorithmically by asking which faces in facelist do not contain any of the vertices in the upper half:
newfacelist = Select[facelist, Intersection[uppervs, #] == {} &]
Graphics3D[{
  GraphicsComplex[coords, Polygon@newfacelist]
}, Boxed -> False]
which looks like this:


When we removed the faces, we also removed the incident edges, and I'd like to add many of them back in. In particular, I'd like to reinsert the lost edges that are not are not touching the top face and also not edges of the faces of the base.
lostedges = Select[edgelist,
  (Length@Intersection[lowervs, #] < 2 &&
   Length@Intersection[topvs, #] == 0) &]
Graphics3D[{
  GraphicsComplex[coords, Polygon@newfacelist],
  Thick, GraphicsComplex[coords, Line@lostedges]
}, Boxed -> False]
This code yields the following image. The basic structure of our terrarium is finally coming in view!


 

Step Three: Make it 3D printable

The structure of what we want to 3D print is there, but we can't print it because each face is only two-dimensional and each edge is only one-dimensional! So we'll need to add some thickness to the faces and the edges. In fact, we won't be adding thickness to a face as much as we will be constructing a new solid that has two layers of faces. We will be generating a new GraphicsComplex object, which means we need to mark down all vertices that form the corners of our object, and keep track of which of these vertices are connected to form the polygonal faces.

Just like blowing up a balloon appears to dilate the surface of the balloon by a constant factor, we can create an outer layer of faces 10% bigger than the original faces by multiplying all coordinates by a factor of 1.1; we save these coordinates as dilatedcoords. Thinking of the original vertices as vertices 1 through 24, we consider these dilated vertices to be vertices 25 through 48; furthermore, they have the exact same incidences as the vertices 1 through 24. So determining the vertex indices in the list of dilated faces is as simple as adding 24 to the index of each of the original vertices.
dilatedcoords = 1.1 coords;
dilatedfacelist = newfacelist + 24;
allcoords = Join[coords, dilatedcoords];
allfaces = Join[newfacelist, dilatedfacelist];
Graphics3D[{GraphicsComplex[allcoords, Polygon@allfaces]}, Boxed -> False]

Combining the original and dilated coordinates and faces gives the inner and outer shell of polygonal faces, but this is not a closed object. We also need to complete the base by adding in quadrilaterals that bridge the shells. To do this, we (manually) keep track of the indices of the original vertices that work around the boundary of the base. The quadrilaterals we create need to join two adjacent boundary vertices with their dilates (remember they are indexed by 24 more than their non-dilated counterparts.
boundaryedges = {{1, 17}, {17, 13}, {13, 7}, {7, 6}, {6, 22}, {22, 10}, {10, 4}, {4, 1}};
boundaryfaces = Map[
  {#[[1]], #[[2]], #[[2]] + 24, #[[1]] + 24} &,
  boundaryedges];
Graphics3D[{
  GraphicsComplex[allcoords, Polygon@allfaces],
  GraphicsComplex[allcoords, Polygon@boundaryfaces]
}, Boxed -> False]
Putting these all together gives the base; we visualize the result:


Now we need to construct the three dimensional version of the edges. I want to make thin cylindrical edges for the black lines on the sketch above, and I also want to curve the top of each of the boundary edges to soften the edges. I introduced some parameters to be able to play around with them to work out the best visualization. The value midpt is the coordinate multiplier. It is 1.05 since that is halfway between the original coordinate (multiplier 1.0) and the dilated coordinate (multiplier 1.1). The big radius is the radius of the cylinder along the `boundary edges'. I was originally surprised that .05 was not the correct value here. The small radius is the radius of the cylinder along the `lost edges' (the black lines above). Map then puts a Tube (cylinder) along each of those edges at the specified radii.
midpt = 1.05; bigr = .0615; smallr = .04;
tubes = Join[
  Map[Tube[#, bigr] &,
   Table[midpt {coords[[boundaryedges[[i, 1]]]],
    coords[[boundaryedges[[i, 2]]]]},
    {i, Length[boundaryedges]}]],
  Map[Tube[#, smallr] &,
   Table[midpt {coords[[lostedges[[i, 1]]]],
    coords[[lostedges[[i, 2]]]]},
   {i, Length[lostedges]}]]
];
Just as when we constructed the name ring, we need to finish the cylinders with spheres at each endpoint. We need spheres of the same radius as the radius of the adjacent cylinders.
spheres = {
  Map[Sphere[#, bigr] &,
   midpt coords[[Complement[lowervs, bottomvs]]]],
  Map[Sphere[#, smallr] &,
   midpt coords[[Complement[uppervs, topvs]]]]
}
Now put everything together and export the model to an STL file.
terrarium = Graphics3D[{
  GraphicsComplex[allcoords, Polygon@allfaces],
  GraphicsComplex[allcoords, Polygon@boundaryfaces],
  tubes, spheres
}, Boxed -> False]
Export[NotebookDirectory[] <> "terrarium.stl", terrarium]
After exporting, we can upload it where we need to. I've uploaded it to Sketchfab so you can play with a rendering of the final product!

Step Four: Send to the printer!

Now let's print out the model! (Note that I provide much more detail on the prototyping and printing processes at the bottom of the name ring design post.)

I highly suggest a final print of your terrarium in glazed ceramic because it will be able to withstand the elements and the cleaning required by dirt and plants. At the same time, I would also suggest prototyping on a local 3D printer instead of prototyping through Shapeways. At 4.5 inches by 4.5 inches by 3.5 inches, a basic print is already approaching $60! I printed it on the Lulzbot Mini printer that my colleague in the Queens College Art department is graciously loaning me, and, after 9 hours of printing, here is the stunning result: (click to zoom)


Pro Tip: The standard Cura software that comes with the Lulzbot was not able to correctly process my file—it either completely fills in the bottom half of the model or does not connect the edges together. So I needed to do some post-processing of the STL file. I uploaded it to Netfabb's online STL repair service and the Lulzbot was able to print the STL output from there with no issues.

Shapeways has produced a rendering of what it anticipates that a glazed ceramic version of my file will look like.

I can't wait to get one for myself and house some succulents inside. If you do your own modifications, do let me know how it turns out. Until next time!

Christopher Hanusa's portfolio is available online at
Purchase a copy of this and other 3D printed artwork
at Hanusa ≀ Design on Shapeways.

Wednesday, March 1, 2017

3D Design in Mathematica: Creating a Name Ring

In this post I will be going through the techniques I use to create a name ring in Mathematica. Here is a ring I designed that is an ambigram of the name Sara.

Click below to interact with a 3D rendering of the ring.

Since I have never met a meta I didn't like, let's walk through the design of a new ring that says Ring.

Step One: Create a sketch

Create a drawing of the word with an eye toward its style and making sure that the letters have a natural way that they can be connected. After doing a dozen sketches, I settled on this draft to guide me:

I made sure that the sketch has two disjoint paths from the beginning of the word to the end of the word so that the ring is stronger when it is printed.

Step Two: Transfer into Mathematica

Our next goal is to convert the drawing into a two-dimensional Graphics object in Mathematica. The relevant Mathematica commands for this are BSplineFunction, BezierFunction, and Interpolation, which take as input a set of points and give a smooth function that follows those points as output. I've created BezierFunctions manually a couple of times which was a painstaking process because the curve does not pass through the chosen points, so this time I figured that I would try to streamline the choosing and adjusting of points. When researching how to do this, I found a thread about extruding along a path on StackExchange, which led me to a comment by J.M. and a link in Mathematica's Documentation Center about how to create a BSplineCurve that touches the control points. I wrote a function to do this automatically, which I called SplineIt.

SplineIt[pts_] := Module[
  {n = Length[pts], dist, param, knots, m, ctrlpts},
  dist = Accumulate[Table[
   EuclideanDistance[pts[[i]], pts[[i+1]]], {i, n-1}]];
  param = N[Prepend[dist/Last[dist], 0]];
  knots = Flatten[{{0, 0, 0, 0},
      Table[i/(n-3), {i, 1, n-4}], {1, 1, 1, 1}}];
  m = Table[
   BSplineBasis[{3, knots}, j-1, param[[i]]],
   {i, n}, {j, n}];
  ctrlpts = LinearSolve[m, pts]
]
Here I have applied SplineIt to the sequence of points $\{(1, 0), (0, 1), (-1, 0), (0, -1)\}$
Then I wanted to move the control points (or add in new ones) and watch the shape of the curves change. Once again the Documentation Center has a relevant example about an application of DynamicModule, which I coupled with another StackExchange answer on inserting points in a DynamicModule to give the following code that allows us to move points and have a BSplineCurve passing through the movable points. This allowed me to create a streamlined process where I successively created piece after piece of the name plate.
allpts = {};
pts = {{1, 0}, {0, 1}, {-1, 0}, {0, -1}, {1, 0}};
DynamicModule[{i = Length[pts], last},
  last[prev_, curr_] := If[Length[prev] != Length[curr], Length[curr], FirstPosition[SameQ @@@ Thread[{prev, curr}], False][[1]]];
  Column[{Style["Don't forget to save the points", Red, Bold],
   LocatorPane[
    Dynamic[pts, (i = last[pts, #]; pts = #) &],
    EventHandler[
     Dynamic[Show[
      {Graphics[{
       {Thick, Red, Map[BSplineCurve[SplineIt[#]] &, allpts]},
       {Thick, Black, BSplineCurve[SplineIt[pts]]}
      }, ImageSize -> 700,
      GridLines -> {Table[i, {i, -1.3, 1.3, .05}], Table[i, {i, -1.3, 1.3, .05}]},
      PlotRange -> {{-2, 2}, {-2, 2}}]},
     Frame -> True]],
   {{"MouseDown", 2} :> (pts = Insert[pts, MousePosition["GraphicsAbsolute"], i + 1])}], LocatorAutoCreate -> True]}, Alignment -> Center]]
The variable pts keeps track of the current set of points that I am moving and sculpting. Once I get the points in the right place, I mark down what the current set of points pts is and append it to the list allpts. Here is what it looks like part of the way through when I am editing the tail of the G (which is also the bottom of the I):
Pro Tip: I always tell my students to never break anything that works! If you get one piece of your code working, copy the whole working block of code into a new cell and modify the new cell.
 
By the end of the process, my list of allpts includes all the pieces of the name plate, including the three parts of the R, the tail of the G, the circle of the I, and the two parts of the N. This process involves much trial and error to get the points just right.
r1pts = {{-1.592, 0.86}, {-1.328, 1.05}, {-0.786, 0.98}, {-0.64, 0.67}, {-0.868, 0.225}, {-1.212, 0.15}, {-1.56, 0.215}};
r2pts = {{-1.586, 0.87}, {-1.55, 0.62}, {-1.542, -0.12}, {-1.594, -0.505}, {-1.736, -0.745}};
r3pts = {{-1.534, 0.19}, {-1.238, 0.035}, {-1.01, -0.38}, {-0.61, -0.905}, {-0.092, -0.96}, {0.344, \ -0.835}, {0.88, -0.62}, {1.314, -0.335}, {1.518, 0.235}, {1.306, 0.75}, {0.676, 0.75}, {0.612, 0.34}, {0.984, 0.13}, {1.282, 0.335}};
gpts = {{1.298, 0.755}, {1.304, 0.08}, {1.208, -0.945}, {0.956, -1.24}, {-0.172, -1.1}, {-0.412, \ -0.165}, {-0.412, 0.33}, {-0.818, 0.26}};
ipts = {{-0.326, 0.82}, {-0.6, 0.92}, {-0.63, 0.735}, {-0.466, 0.67}, {-0.322, 0.81}};
n1pts = {{-0.302, 0.805}, {-0.092, 0.83}, {0.018, -0.045}, {-0.096, -0.79}, {-0.278, -0.97}};
n2pts = {{0.064, 0.44}, {0.47, 0.585}, {0.61, -0.08}, {0.652, -0.51}, {0.824, -0.655}};
allpts = {r1pts, r2pts, r3pts, gpts, ipts, n1pts, n2pts};
With these control points, we get the final two-dimensional graphic. Not bad!

Step Three: Convert into three dimensions

Now we need to take the two-dimensional Graphics object and make it into a three-dimensional Graphics3D object. We get to use some elementary trigonometry to do this! The key idea is that we can wrap a two-dimensional picture around a cylinder of radius 1 by taking a point at $(x,y)$ on the plane to a point $(\sin(x),y,\cos(x))$ on the cylinder.
 
First I use a technique from a discussion on StackExchange to define the $x$- and $y$-components of the BSplineCurve commands we defined above.

xComponent[t_?NumericQ, f_] :=
   Module[{val}, val = f[t]; First@val];
yComponent[t_?NumericQ, f_] :=
   Module[{val}, val = f[t]; Last@val];
This means that we can recreate the two-dimensional curves shown above using ParametricPlot commands. Note to do that we have to convert our BSplineCurve commands to BSplineFunction commands, as shown here.
fcns = Map[ BSplineFunction[SplineIt[#]] &, allpts];
ParametricPlot[{
  Table[{
   xComponent[t, fcns[[i]]],
   yComponent[t, fcns[[i]]]
   }, {i, Length[fcns]}],
  {t, 0, 1}, AspectRatio -> 1, PlotRange -> {-1.8, 1.8}, Axes -> False]
To wrap these two-dimensional functions around a three-dimensional cylinder of a given radius, we first scale the $x$-components so that they fit in the range between $-\pi/2$ and $\pi/2$, and take the sine and cosine of this times the given radius as the 3D $x$- and $z$-components, respectively.
 
We combine all the curves together using the Table command and use a technique I learned from a very useful article by Henry Segerman to give these curves a specified thickness by way of the Tube command in the PlotStyle option.
xscale = 1.5;
radius = 1.1;
thickness = .08;
ParametricPlot3D[
  Table[{
   radius * Sin[xComponent[t, fcns[[i]]]/xscale * Pi/2],
   yComponent[t, fcns[[i]]],
   radius * Cos[xComponent[t, fcns[[i]]]/xscale * Pi/2]},
   {i, 1, Length[fcns]}],
  {t, 0, 1}, AspectRatio -> 1, PlotRange -> {-1.8, 1.8},
PlotStyle -> {Tube[thickness], Yellow}]

Step Four: Add finishing touches

We now have a virtual three-dimensional version of the name plate from our original sketch, and need to do some finishing work before it is ready to be printed. We will add the strap that goes behind the finger and add a sphere to every curve endpoint.
 
You can add the strap in multiple ways depending on the style you are going for. For example, the Sara ring above has two straps that cross in an X behind the finger. For this ring, I have decided to make a single strap connecting the beginning and the end of the name plate. All this requires is a part of a circle of given radius which I have placed at height $y=0.1$ to line up well. The range on $t$ is determined by trial and error.

ParametricPlot3D[
  {radius*Sin[t + Pi], 0.1, radius*Cos[t + Pi]},
  {t, -Pi/2 - .46, Pi/2 + .45},
  AspectRatio -> 1, PlotRange -> {-1.8, 1.8},
  PlotStyle -> {{Tube[thickness], Green}}]
If we were to export the file right now, we would be in for an unwelcome surprise! The exported file would not have the nice rounded ends of the curves like in the Mathematica notebook, so we need to add them manually. Compare before and after shots of the exported files:
Luckily this is not too difficult with Mathematica's Map function. We tell Mathematica to choose the first and last points of every letter piece, and then tell Mathematica to put a sphere at the transformed image of these points. I also like to give the spheres a different color in order to see them distinctly on the image.
sphereposns =
   Flatten[{ptslist[[All, 1]], ptslist[[All, -1]]}, 1];
Graphics3D[{Blue,
   Map[Sphere[{radius*Sin[#[[1]]/xscale*Pi/2], #[[2]],
      radius*Cos[#[[1]]/xscale*Pi/2]}, thickness] &,
   sphereposns]}]
Pro Tip: The PlotStyle->Tube option and Sphere command have acceptable resolution because a ring is a small object. When you want to export a larger sphere (2 in / 5 cm) or a larger curved tube, instead you would need to use a ParametricPlot3D command involving multiple variables in order to specify the exporting resolution.
 
By combining all the pieces we have programmed, our virtual ring is complete!
SplineIt[pts_] := Module[
  {n = Length[pts], dist, param, knots, m, ctrlpts},
  dist = Accumulate[Table[
   EuclideanDistance[pts[[i]], pts[[i+1]]], {i, n-1}]];
  param = N[Prepend[dist/Last[dist], 0]];
  knots = Flatten[{{0, 0, 0, 0},
      Table[i/(n-3), {i, 1, n-4}], {1, 1, 1, 1}}];
  m = Table[
   BSplineBasis[{3, knots}, j-1, param[[i]]],
   {i, n}, {j, n}];
  ctrlpts = LinearSolve[m, pts]
]
xComponent[t_?NumericQ, f_] :=
   Module[{val}, val = f[t]; First@val];
yComponent[t_?NumericQ, f_] :=
   Module[{val}, val = f[t]; Last@val];
 
r1pts = {{-1.592, 0.86}, {-1.328, 1.05}, {-0.786, 0.98}, {-0.64, 0.67}, {-0.868, 0.225}, {-1.212, 0.15}, {-1.56, 0.215}};
r2pts = {{-1.586, 0.87}, {-1.55, 0.62}, {-1.542, -0.12}, {-1.594, -0.505}, {-1.736, -0.745}};
r3pts = {{-1.534, 0.19}, {-1.238, 0.035}, {-1.01, -0.38}, {-0.61, -0.905}, {-0.092, -0.96}, {0.344, \ -0.835}, {0.88, -0.62}, {1.314, -0.335}, {1.518, 0.235}, {1.306, 0.75}, {0.676, 0.75}, {0.612, 0.34}, {0.984, 0.13}, {1.282, 0.335}};
gpts = {{1.298, 0.755}, {1.304, 0.08}, {1.208, -0.945}, {0.956, -1.24}, {-0.172, -1.1}, {-0.412, \ -0.165}, {-0.412, 0.33}, {-0.818, 0.26}};
ipts = {{-0.326, 0.82}, {-0.6, 0.92}, {-0.63, 0.735}, {-0.466, 0.67}, {-0.322, 0.81}};
n1pts = {{-0.302, 0.805}, {-0.092, 0.83}, {0.018, -0.045}, {-0.096, -0.79}, {-0.278, -0.97}};
n2pts = {{0.064, 0.44}, {0.47, 0.585}, {0.61, -0.08}, {0.652, -0.51}, {0.824, -0.655}};
allpts = {r1pts, r2pts, r3pts, gpts, ipts, n1pts, n2pts};
 
xscale = 1.5;
radius = 1.1;
thickness = .08;
stretch = .7;
ptslist = stretch * allpts;
sphereposns =
    Flatten[{ptslist[[All, 1]], ptslist[[All, -1]]}, 1]
fcns = Map[BSplineFunction[SplineIt[#]] &, ptslist];
Show[
  ParametricPlot3D[
   Table[{
     radius*Sin[xComponent[t, fcns[[i]]]/xscale*Pi/2],
     yComponent[t, fcns[[i]]],
     radius*Cos[xComponent[t, fcns[[i]]]/xscale*Pi/2]},
    {i, 1, Length[fcns]}],
   {t, 0, 1}, AspectRatio -> 1, PlotRange -> {-1.8, 1.8},
   PlotStyle -> {Tube[thickness], Yellow}],
  ParametricPlot3D[{
   {radius*Sin[t + Pi], 0.1, radius*Cos[t + Pi]}},
   {t, -Pi/2 - .46, Pi/2 + .45},
   PlotStyle -> {{Tube[thickness], Green}}],
  Graphics3D[{Blue,
   Map[Sphere[{radius*Sin[#[[1]]/xscale*Pi/2], #[[2]],
      radius*Cos[#[[1]]/xscale*Pi/2]}, thickness] &,
   sphereposns]}]
]

Step Five: Send to the printer!

Once you are happy with your virtual ring, you'll need to print it out. I send my files to Shapeways, which is also located in Queens, NY. (I've taken my students there!) I highly suggest printing a prototype first, probably in White Strong and Flexible Plastic since it is the fastest and cheapest material. This will help to make sure the ring is the right size and looks the way you want it to before printing it in higher-quality (and much more expensive) materials.
 
Mathematica 11 has built in the capability to upload your model directly to Shapeways using the command Printout3D, but I still prefer using Export in order to have a copy of the exported .STL file on my own computer. I always like to put the STL file in the same directory as the Mathematica file I am working with, so I use the following command.

Export[NotebookDirectory[] <> "MetaRing.stl", %]
Now Go to Shapeways and click the Upload button on the top right. Choose your model, and click the Inches option. After the file uploads, you'll need to resize the file so that the ring is the correct size, which you can measure on the desired finger and compare against the size Shapeways gives. Realize that your finger will need to fit on the inside of the ring, while Shapeways is displaying the size of the outside of the ring.
 
Shapeways will go through its preliminary set of checks on your ring and let you know what in materials your model is able to be printed. Even though you may be only printing your first prototype in White Strong and Flexible Plastic, make sure that your model also gets the green checkmark in the final material that you want to print it.
 
Order your ring, wait *VERY* patiently, and when it arrives check to see if it looks the way you want.
If it does not, you'll need to re-edit your Mathematica file (perhaps changing the thickness of the tubes, and/or the position of the control points) or resize the file on the Shapeways website. In either case, Shapeways will have one more say about whether the new model is printable. Go through the prototyping phase once more if the changes are drastic (or even not-so-drastic). Once you are sure that your ring is the way you want it to be, order the final version in the material you think it will look best. (The Sara ring above is printed in Premium Silver, and it is stunning!)
 
Good luck! Let me know how it turns out.

Christopher Hanusa's portfolio is available online at
Purchase a copy of this and other 3D printed artwork
at Hanusa ≀ Design on Shapeways.
I also design custom jewelry. Email (hanusadesign - AT - gmail.com) for more details.