# Can I inscribe a regular tetrahedron to a torus?

What kind of regular tetrahedra can we inscribe into a given torus?

For example, is it possible to inscribe a unit edge length regular tetrahedron to a spindle torus with major radius $$R=\frac{\sqrt 2}2$$ and minor radius $$r=\frac{\sqrt 3}2$$?

It seems to me that such an inscription should be doable for any $$R$$ and $$r$$ in a reasonable range, but I'm having a very hard time imagining it; I hope someone with some knowledge/vision in spatial geometry can answer this from the top of their head.

• The tetrahedron needs to be wholly inside of the torus? And every point of the tetrahedron needs to be on the torus' surface? And the dimensions of both the torus and the tetrahedron are given , so the only degrees of freedom are the location and orientation of the tetrahedron? – Wouter Dec 7 '18 at 8:54
• No, yes, and yes. – domotorp Dec 7 '18 at 9:27

One solution has the vertices: $$\begin{array}{ccc} (-0.42, & \ \ \, 0.28, & 0.84 )\\ (-0.03, & -0.16, & 0.04 )\\ (-0.19, & -0.69, & 0.87 )\\ (\ \ \, 0.54, & \ \ \, 0.00, & 0.85 )\\ \end{array}$$ which lead to this view looking up at the region with $$z>0$$:

This comes from Mathematica using NMinimize, which surprisingly worked better than NSolve or FindInstance. The code is below, and you could get other solutions by rotating this or by adding a term like $$(a_2-\frac32)^2$$ to the sum of squares.

xyz[a_, b_] := {(Sqrt[2] + Sqrt[3] Cos[b]) Cos[a],
(Sqrt[2] + Sqrt[3] Cos[b]) Sin[a], Sqrt[3] Sin[b]} / 2

d[t_, u_, v_, w_] := (xyz[t, u] - xyz[v, w]).(xyz[t, u] - xyz[v, w])

sol = NMinimize[
(d[a1, b1, a2, b2] - 1)^2 + (d[a2, b2, a3, b3] - 1)^2 +
(d[a3, b3, a1, b1] - 1)^2 + (d[a1, b1, 0, b0] - 1)^2 +
(d[a2, b2, 0, b0] - 1)^2 + (d[a3, b3, 0, b0] - 1)^2,
{a1, a2, a3, b1, b2, b3, b0}][[2]]

Round[{xyz[a1, b1], xyz[a2, b2], xyz[a3, b3], xyz[0, b0]} /. sol, .01]

tetra = ListPlot3D[{xyz[a1, b1], xyz[a2, b2], xyz[a3, b3],
xyz[0, b0]} /. sol, PlotTheme -> Business,
PlotRange -> {{-2, 2}, {-2, 2}, {0, 1}}]

torus = ParametricPlot3D[xyz[a, b], {a, 0, 2 Pi}, {b, 0, 2 Pi},
PlotRange -> {{-2, 2}, {-2, 2}, {0, 1}}]

Show[tetra, torus]