--- title: "Mapping a picture on a donut or a Hopf torus" author: "Stéphane Laurent" date: '2022-06-30' tags: R, maths, geometry, graphics, rgl rbloggers: yes output: md_document: variant: markdown preserve_yaml: true html_document: highlight: kate keep_md: no highlighter: pandoc-solarized --- # The donut torus Given a number $s \geqslant 1$, the following map: $$(u, v) \mapsto (x, y, z) = \frac{\Bigl(s\cos\frac{u}{s}, s\sin\frac{u}{s}, \sin v\Bigr)}{\sqrt{s^2+1}-\cos v}$$ is a *conformal parameterization* of the torus (the donut), where $-s\pi \leqslant u < s\pi$ and $\pi \leqslant v < \pi$. I found it in [this paper by J.M. Sullivan](https://static1.bridgesmathart.org/2011/cdrom/proceedings/134/paper_134.pdf). The number $s$ is the ratio of the major radius over the minor radius. The conformality of the map has the following consequence: you can easily map a doubly periodic image on the torus in such a way that it will perfectly fit on the torus. ## Mapping a checkerboard Let me show what I mean. The code below generates a mesh of the torus with a checkerboard mapped on its surface:  {.r .numberLines} library(rgl) library(Rvcg) # to use vcgUpdateNormals() torusMesh <- function(s, nu, nv){ nu <- as.integer(nu) nv <- as.integer(nv) nunv <- nu * nv vs <- matrix(NA_real_, nrow = 3L, ncol = nunv) tris1 <- matrix(NA_integer_, nrow = 3L, ncol = nunv) tris2 <- matrix(NA_integer_, nrow = 3L, ncol = nunv) u_ <- seq(-pi*s, pi*s, length.out = nu + 1L)[-1L] v_ <- seq(-pi, pi, length.out = nv + 1L)[-1L] scosu_ <- s * cos(u_ / s) ssinu_ <- s * sin(u_ / s) sinv_ <- sin(v_) w <- sqrt(s*s + 1) - cos(v_) jp1_ <- c(2L:nv, 1L) j_ <- 1L:nv color <- NULL for(i in 1L:(nu-1L)){ i_nv <- i*nv rg <- (i_nv - nv + 1L):i_nv vs[, rg] <- rbind( scosu_[i] / w, ssinu_[i] / w, sinv_ / w ) color <- c( color, if(mod(floor(5 * u_[i] / (pi*s)), 2) == 0){ ifelse( floor(5 * v_ / pi) %% 2 == 0, "yellow", "navy" ) }else{ ifelse( floor(5 * v_ / pi) %% 2 == 0, "navy", "yellow" ) } ) k1 <- i_nv - nv k_ <- k1 + j_ l_ <- k1 + jp1_ m_ <- i_nv + j_ tris1[, k_] <- rbind(m_, l_, k_) tris2[, k_] <- rbind(m_, i_nv + jp1_, l_) } i_nv <- nunv rg <- (i_nv - nv + 1L):i_nv vs[, rg] <- rbind( scosu_[nu] / w, ssinu_[nu] / w, sinv_ / w ) color <- c( color, ifelse( floor(5 * v_ / pi) %% 2 == 0, "yellow", "navy" ) ) k1 <- i_nv - nv l_ <- k1 + jp1_ k_ <- k1 + j_ tris1[, k_] <- rbind(j_, l_, k_) tris2[, k_] <- rbind(j_, jp1_, l_) tmesh <- tmesh3d( vertices = vs, indices = cbind(tris1, tris2), homogeneous = FALSE, material = list("color" = color) ) vcgUpdateNormals(tmesh) }  Let's see: r mesh <- torusMesh(s = sqrt(2), nu = 500, nv = 500) open3d(windowRect = c(50, 50, 562, 562), zoom = 0.85) bg3d("gainsboro") shade3d(mesh)  ![](./figures/ConformalTorusCheckerboard.gif){width="55%"} Now you surely see what I mean. ## Mapping a Gray-Scott picture I am a fan of the [Fronkonstin blog](https://fronkonstin.com/). Maybe you already see [this article about the Gray-Scott reaction-diffusion model](https://fronkonstin.com/2019/12/28/reaction-diffusion/) (it appeared on R-bloggers). It shows how to generate some beautiful pictures which are doubly periodic. So let's map such a picture on the donut:  {.r .numberLines} ...... fcolor <- colorRamp(viridisLite::magma(255L)) getColors <- function(B){ rgbs <- fcolor(B) rgb(rgbs[, 1L], rgbs[, 2L], rgbs[, 3L], maxColorValue = 255) } X <- iterate_Gray_Scott(X, L, DA, DB, 500) Colors <- getColors(c(X[,,2L])) mesh <- torusMesh(s = sqrt(2), nu = 600, nv = 600) mesh[["material"]] <- list("color" = Colors) open3d(windowRect = c(50, 50, 562, 562), zoom = 0.85) bg3d("gainsboro") shade3d(mesh)  ![](./figures/ConformalTorusGrayScott.gif){width="55%"} Beautiful! # The Hopf torus We can similarly map a picture on a Hopf torus, with this conformal parameterization:  {.r .numberLines} HT <- function(h, nlobes, t, phi){ # the spherical curve p1 <- sin(h * cos(nlobes*t)) p2 <- cos(t) * cos(h * cos(nlobes*t)) p3 <- sin(t) * cos(h * cos(nlobes*t)) # parameterization yden <- sqrt(2*(1+p1)) y1 <- (1+p1)/yden y2 <- p2/yden y3 <- p3/yden cosphi <- cos(phi) sinphi <- sin(phi) x1 <- cosphi*y1 x2 <- sinphi*y1 x3 <- cosphi*y2 - sinphi*y3 x4 <- cosphi*y3 + sinphi*y2 return(rbind(x1/(1-x4), x2/(1-x4), x3/(1-x4))) }  ## Checkerboard The code to construct the mesh with the checkerboard is similar to the one for the donut torus:  {.r .numberLines} HopfTorusMesh <- function(h, nlobes, nu, nv){ nu <- as.integer(nu) nv <- as.integer(nv) vs <- matrix(NA_real_, nrow = 3L, ncol = nu*nv) tris1 <- matrix(NA_integer_, nrow = 3L, ncol = nu*nv) tris2 <- matrix(NA_integer_, nrow = 3L, ncol = nu*nv) u_ <- seq(-pi, pi, length.out = nu + 1L)[-1L] v_ <- seq(-pi, pi, length.out = nv + 1L)[-1L] jp1_ <- c(2L:nv, 1L) j_ <- 1L:nv color <- NULL for(i in 1L:(nu-1L)){ i_nv <- i*nv vs[, (i_nv - nv + 1L):i_nv] <- HT(h, nlobes, u_[i], v_) color <- c( color, if(mod(floor(10 * u_[i] / pi), 2) == 0){ ifelse( floor(10 * v_ / pi) %% 2 == 0, "yellow", "navy" ) }else{ ifelse( floor(10 * v_ / pi) %% 2 == 0, "navy", "yellow" ) } ) k1 <- i_nv - nv k_ <- k1 + j_ l_ <- k1 + jp1_ m_ <- i_nv + j_ tris1[, k_] <- rbind(k_, l_, m_) tris2[, k_] <- rbind(l_, i_nv + jp1_, m_) } i_nv <- nu*nv vs[, (i_nv - nv + 1L):i_nv] <- HT(h, nlobes, pi, v_) color <- c( color, ifelse( floor(10 * v_ / pi) %% 2 == 0, "yellow", "navy" ) ) k1 <- i_nv - nv k_ <- k1 + j_ l_ <- k1 + jp1_ tris1[, k_] <- rbind(k_, l_, j_) tris2[, k_] <- rbind(l_, jp1_, j_) vcgUpdateNormals(tmesh3d( vertices = vs, indices = cbind(tris1, tris2), homogeneous = FALSE, material = list("color" = color) )) } mesh <- HopfTorusMesh(h = 0.4, nlobes = 4, nu = 500, nv = 500) open3d(windowRect = c(50, 50, 562, 562), zoom = 0.85) bg3d("gainsboro") shade3d(mesh)  ![](./figures/ConformalHopfTorusCheckerboard.gif){width="55%"} I really like it. ## Gray-Scott picture To map the Gray-Scott picture, we proceed as for the donut torus. Here is the result: ![](./figures/ConformalHopfTorusGrayScott.gif){width="55%"}