Hopf tori with spherical trochoids as profile curves

HopfToriSphericalTrochoidProfile.R

library(rgl)
library(cgalMeshes)

# Hopf fiber
HopfFiber <- function(p, t) { 
  c(
    p[3L] * cos(t) + p[2L] * sin(t),
    p[2L] * cos(t) - p[3L] * sin(t),
    sin(t) * (1 + p[1L]),
    cos(t) * (1 + p[1L])
  ) / sqrt(2 * (1 + p[1L])) 
}

# spherical trochoid 
# https://mathcurve.com/courbes3d/cycloidspheric/trochoidspheric.shtml
st <- function(t) {
  com <- cos(omega)
  cbind(
    (a - b*com + d*com*cos(q*t)) * cos(t) + d * sin(t)*sin(q*t),
    (a - b*com + d*com*cos(q*t)) * sin(t) - d * cos(t)*sin(q*t),
    sin(omega) * (b - d*cos(q*t))
  )
}

# Hopf parameterization
f <- Vectorize(function(t, u){
  com <- cos(omega)
  R <- sqrt(a^2 + (b-d)^2 + 2*a*(d-b)*com)
  p3 <- (a - b*com + d*com*cos(q*t)) * cos(t) + d * sin(t)*sin(q*t)
  p2 <- (a - b*com + d*com*cos(q*t)) * sin(t) - d * cos(t)*sin(q*t)
  p1 <- sin(omega) * (b - d*cos(q*t))
  x <- HopfFiber(c(p1, p2, p3)/R, u)
  x[1L:3L] / (1 - x[4L])
})

# parameters of the spherical trochoid
omega <- acos(2.5/3)
q <- 3
b <- 5
a <- q * b
d_ <- b - seq(0, 10, length.out = 40L)

# Hopf mesh - frames
open3d(windowRect = 50 + c(0, 0, 512, 512))
bg3d(rgb(54, 57, 64, maxColorValue = 255))
view3d(0, 0, zoom = 0.85)
for(i in seq_along(d_)) {
  d <- d_[i]
  mesh <- parametricMesh(
    f, c(0, 2*pi), c(0, 2*pi), periodic = c(TRUE, TRUE),
    nu = 300L, nv = 300L
  )
  mesh <- addNormals(mesh, angleWeighted = FALSE)
  shade3d(mesh, color = "firebrick4")
  snapshot3d(sprintf("zzpic%03d.png", i), webshot = FALSE)
  clear3d()
}

# mount animation
library(gifski)
pngs <- Sys.glob("zzpic*.png")
gifski(
  png_files = c(pngs, rev(pngs)), 
  gif_file = "HopfTori-sphericalTrochoidProfile.gif",
  width = 512, height = 512,
  delay = 1/10
)
file.remove(pngs)

HopfToriSphericalTrochoidProfileKlingon.R

library(rgl)
library(cgalMeshes)
library(trekcolors)

# Hopf fiber
HopfFiber <- function(p, t) { 
  c(
    p[3L] * cos(t) + p[2L] * sin(t),
    p[2L] * cos(t) - p[3L] * sin(t),
    sin(t) * (1 + p[1L]),
    cos(t) * (1 + p[1L])
  ) / sqrt(2 * (1 + p[1L])) 
}

# spherical trochoid 
# https://mathcurve.com/courbes3d/cycloidspheric/trochoidspheric.shtml
st <- function(t) {
  com <- cos(omega)
  cbind(
    (a - b*com + d*com*cos(q*t)) * cos(t) + d * sin(t)*sin(q*t),
    (a - b*com + d*com*cos(q*t)) * sin(t) - d * cos(t)*sin(q*t),
    sin(omega) * (b - d*cos(q*t))
  )
}

# coloring function
framp <- colorRampPalette(
  rev(trek_pal("klingon")), bias = 4, interpolate = "spline")
cols <- framp(50)
fpalette <- colorRamp(
  c(cols, rev(cols)), 
  bias = 1, interpolate = "spline"
)

fcolor <- Vectorize(function(t, u) {
  RGB <- fpalette(t/(2*pi))
  rgb(RGB[, 1L], RGB[, 2L], RGB[, 3L], maxColorValue = 255)
})

# Hopf parameterization
f <- Vectorize(function(t, u){
  com <- cos(omega)
  R <- sqrt(a^2 + (b-d)^2 + 2*a*(d-b)*com)
  p3 <- (a - b*com + d*com*cos(q*t)) * cos(t) + d * sin(t)*sin(q*t)
  p2 <- (a - b*com + d*com*cos(q*t)) * sin(t) - d * cos(t)*sin(q*t)
  p1 <- sin(omega) * (b - d*cos(q*t))
  x <- HopfFiber(c(p1, p2, p3)/R, u)
  x[1L:3L] / (1 - x[4L])
})

# parameters of the spherical trochoid
omega <- acos(2.5/3)
q <- 3
b <- 5
a <- q * b
d_ <- b - seq(0, 10, length.out = 40L)

# Hopf mesh - frames
open3d(windowRect = 50 + c(0, 0, 512, 512))
bg3d(rgb(54, 57, 64, maxColorValue = 255))
view3d(0, 0, zoom = 0.8)
for(i in seq_along(d_)) {
  d <- d_[i]
  mesh <- parametricMesh(
    f, c(0, 2*pi), c(0, 2*pi), periodic = c(TRUE, TRUE),
    nu = 300L, nv = 300L, fcolor = fcolor
  )
  mesh <- addNormals(mesh, angleWeighted = FALSE)
  shade3d(mesh)
  snapshot3d(sprintf("zzpic%03d.png", i), webshot = FALSE)
  clear3d()
}

# mount animation
library(gifski)
pngs <- Sys.glob("zzpic*.png")
gifski(
  png_files = c(pngs, rev(pngs)), 
  gif_file = "HopfTori-sphericalTrochoidProfile-klingon.gif",
  width = 512, height = 512,
  delay = 1/10
)
file.remove(pngs)

HopfToriSphericalTrochoidProfileKlingonColors.R

# there's an error in the two other files #

library(rgl)
library(cgalMeshes)
library(trekcolors)

# Hopf fiber
HopfFiber <- function(p, t) { 
  c(
    p[3L] * cos(t) + p[2L] * sin(t),
    p[2L] * cos(t) - p[3L] * sin(t),
    sin(t) * (1 + p[1L]),
    cos(t) * (1 + p[1L])
  ) / sqrt(2 * (1 + p[1L])) 
}

# spherical trochoid 
# https://mathcurve.com/courbes3d/cycloidspheric/trochoidspheric.shtml
st <- function(t) {
  com <- cos(omega)
  som <- sin(omega)
  h <- (b - a*com) / som
  R <- sqrt(a^2 + h^2 + d^2 - b^2) # radius
  f <- a - b*com + d*com*cos(q*t)
  c(
    f * cos(t) + d * sin(t)*sin(q*t),
    f * sin(t) - d * cos(t)*sin(q*t),
    som * (b - d*cos(q*t)) - h
  ) / R
}

# coloring function
framp <- colorRampPalette(
  rev(trek_pal("klingon")), bias = 0.1, interpolate = "spline")
cols <- framp(50)
fpalette <- colorRamp(
  c(cols, rev(cols)), 
  bias = 1, interpolate = "spline"
)

fcolor <- Vectorize(function(t, u) {
  RGB <- fpalette(t/(2*pi))
  rgb(RGB[, 1L], RGB[, 2L], RGB[, 3L], maxColorValue = 255)
})

# Hopf parameterization
f <- Vectorize(function(t, u){
  p <- st(t)
  p3 <- p[1L]
  p2 <- p[2L]
  p1 <- p[3L]
  x <- HopfFiber(c(p1, p2, p3), u)
  x[1L:3L] / (1 - x[4L])
})

# parameters of the spherical trochoid
omega <- acos(0.5/3)
q <- 3
b <- 5
a <- q * b
d_ <- b - seq(-5, 5, length.out = 40L)

# Hopf mesh - frames
open3d(windowRect = 50 + c(0, 0, 512, 512))
bg3d(rgb(54, 57, 64, maxColorValue = 255))
view3d(0, 0, zoom = 0.7)
for(i in seq_along(d_)) {
  d <- d_[i]
  mesh <- parametricMesh(
    f, c(0, 2*pi), c(0, 2*pi), periodic = c(TRUE, TRUE),
    nu = 350L, nv = 300L, fcolor = fcolor
  )
  mesh <- addNormals(mesh, angleWeighted = FALSE)
  shade3d(mesh)
  snapshot3d(sprintf("zzpic%03d.png", i), webshot = FALSE)
  clear3d()
}

# mount animation
library(gifski)
pngs <- Sys.glob("zzpic*.png")
gifski(
  png_files = c(pngs, rev(pngs)), 
  gif_file = "HopfTori-sphericalTrochoidProfile-KlingonColors.gif",
  width = 512, height = 512,
  delay = 1/10
)
file.remove(pngs)