# Another Hopf torus

Recall that a Hopf torus is a two-dimensional object in the 4D space defined by a *profile curve*: a closed curve on the unit sphere. When mapping it to the 3D space with the stereographic projection, we can obtain a beautiful object, or an ugly one, depending on the choice of the profile curve.

Here, we will see the Hopf torus defined by this profile curve:

This is the intersection of the unit sphere with a cubical cone, the isosurface of equation \(x^2 + y^2 + z^2 = 0\). First, I obtained a mesh of this surface thanks to the **rmarchingcubes** package:

```
library(rgl)
library(rmarchingcubes)
# cubical cone ####
function(x, y, z) {
f <-^3 + y^3 + z^3
x
} y_ <- z_ <- seq(-1.05, 1.05, length.out = 150L)
x_ <- expand.grid(X = x_, Y = y_, Z = z_)
Grid <- array(with(Grid, f(X, Y, Z)), dim = c(150L, 150L, 150L))
voxel <- contour3d(voxel, level = 0, x_, y_, z_)
surf <- tmesh3d(
coneMesh <-vertices = t(surf[["vertices"]]),
indices = t(surf[["triangles"]]),
normals = surf[["normals"]]
)
```

Then I obtained the intersection with the unit sphere thanks to the `clipMesh3d`

and `getBoundary3d`

functions of the **rgl** package:

```
# intersection with unit sphere ####
Rvcg::vcgSphere(subdivision = 5L)
sphereMesh <- clipMesh3d(
mesh <-fn = f, minVertices = 20000L
sphereMesh,
)
boundary <- getBoundary3d(mesh, sorted = TRUE, color = "black", lwd = 2)
# plot ####
open3d(windowRect = 50 + c(0, 0, 512, 512), zoom = 0.9)
shade3d(coneMesh, color = "red", alpha = 0.5, polygon_offset = 1)
shade3d(sphereMesh, color = "blue", alpha = 0.5, polygon_offset = 1)
shade3d(boundary)
```

The curve has not the required orientation of a nice profile curve. Its axis of symmetry is directed by \((1,1,1)\), and we need \((0,0,1)\) instead. So one has to rotate the curve. To do so, I use an exported function from the **cgalMeshes** package, namely `quaternionFromTo`

. It will return a unit quaternion corresponding to the desired rotation. I already talked about this way to obtain a rotation sending a given vector to another given vector, here.

```
# get points at the intersection and rotate them ####
boundary[["vb"]][-4L, boundary[["is"]][1L, ]]
pts <- cgalMeshes:::quaternionFromTo(c(1, 1, 1)/sqrt(3), c(0, 0, 1))
q <- onion::as.orthogonal(q)
R <- t(R %*% pts)[, c(3L, 2L, 1L)] gamma0 <-
```

Now let’s introduce a function which creates a mesh of the Hopf torus defined by a discretized curve, such as our matrix of points `gamma0`

. Again, I use an exported function from **cgalMeshes**, namely `meshTopology`

, which returns the incidences between the vertices of the mesh.

```
# Hopf torus mesh from a discrete curve `gamma` ####
function(gamma, m) {
hMesh <- nrow(gamma)
nu <- TRUE
uperiodic <- 1L:nu
u_ <- TRUE
vperiodic <- as.integer(m)
nv <- 1L:nv
v_ <- array(NA_real_, dim = c(3L, nv, nu))
R <-for(k in 1L:nv) {
k - 1L
K <- cospi(2*K/m)
cosphi <- sinpi(2*K/m)
sinphi <-for(j in 1L:nu) {
gamma[j, 1L]
p1 <- gamma[j, 2L]
p2 <- gamma[j, 3L]
p3 <- sqrt(2 * (1 + p1))
yden <- (1 + p1) / yden
y1 <- p2 / yden
y2 <- p3 / yden
y3 <- cosphi * y3 + sinphi * y2
x1 <- cosphi * y2 - sinphi * y3
x2 <- sinphi * y1
x3 <- cosphi * y1
x4 <- c(x1, x2, x3)/(1 - x4)
R[, k, j] <-
}
} matrix(R, nrow = 3L, ncol = nu*nv)
vs <- cgalMeshes:::meshTopology(nu, nv, uperiodic, vperiodic)
tris <-tmesh3d(
vertices = vs,
indices = tris,
homogeneous = FALSE
) }
```

If you run `hMesh(gamma0, m)`

with `m`

large enough, here is the mesh you will obtain (actually you have to close `gamma0`

, that is to say you have to use `rbind(gamma0, gamma0[1L, ])`

):

Finally I did another animation. The Hopf torus whose profile curve is the equator of the unit sphere is nothing but an ordinary torus after the stereographic projection. Then, I scaled the \(x\)-coordinates of `gamma0`

continuously from a factor zero to a positive factor and I plotted the (stereographic projection of the) Hopf torus corresponding to each scaling. In this way the ordinary torus is smoothly transformed to the previous Hopf torus:

The code:

```
seq(0, 2, length.out = 60L) # scaling factors
h_ <-open3d(windowRect = 50 + c(0, 0, 512, 512))
bg3d(rgb(54, 57, 64, maxColorValue = 255))
view3d(0, 0, zoom = 0.75)
for(i in seq_along(h_)) {
gamma0
gamma <- h_[i] * gamma[, 1L]
gamma[, 1L] <-# normalize so that the points are on the sphere
gamma / sqrt(apply(gamma, 1L, crossprod))
gamma <- rbind(gamma, gamma[1L, ])
gamma <- hMesh(gamma, 500L)
mesh <- addNormals(mesh, angleWeighted = FALSE)
mesh <-shade3d(mesh, color = "firebrick4")
snapshot3d(sprintf("zzpic%03d.png", i), webshot = FALSE)
clear3d()
}# mount the animation ####
library(gifski)
Sys.glob("zzpic*.png")
pngFiles <-gifski(
png_files = c(pngFiles, rev(pngFiles)),
gif_file = "HopfTorusCubicalConeToTorus.gif",
width = 512,
height = 512,
delay = 1/15
)file.remove(pngFiles)
```