#| '!! shinylive warning !!': |
#| shinylive does not work in self-contained HTML documents.
#| Please set `embed-resources: false` in your metadata.
#| standalone: true
#| viewerHeight: 950
## file: app.R
# Collar explorer: a right-angled hexagon and its half-collars
#
# Three sliders set the cuff lengths l1, l2, l3 of a pair of pants Y.
# The app draws one of the two hexagons G that make up Y (Buser 3.1), with
# sides a1, c3, a2, c1, a3, c2 (counterclockwise), c_i = l_i / 2,
# seam a_i opposite c_i (the common perpendicular between the other two cuffs),
# in the Poincare disk, and shades the half-collars
# C*[gamma_i] = { p : dist(p, gamma_i) < w_i }, sinh(w_i) sinh(l_i / 2) = 1
# (Proposition 3.1.8). Along each seam it marks the gap between the two
# half-collars that meet it, a_k - w_i - w_j (Example 3.1.9).
#
# An optional "widen by epsilon" slider grows every half-collar by epsilon, to
# see where the disjointness of Proposition 3.1.8 first fails.
# A second tab shows the same pants as a mirror-symmetric 3D model
# (needs the rgl package and ../pants-3d.R).
#
# Run with: shiny::runApp("collar-explorer") (from the hyperbolic folder)
library(shiny)
library(ggplot2)
library(dplyr)
library(tibble)
library(purrr)
has_rgl <- requireNamespace("rgl", quietly = TRUE) &&
file.exists("pants-3d.R")
if (has_rgl) {
options(rgl.useNULL = TRUE)
source("pants-3d.R", encoding = "UTF-8")
}
# ---- hyperboloid model ---------------------------------------------------------
#
# All the geometry is done in the hyperboloid model, as in Buser 2.1 and the
# Section 2.2 notes ("generalized triangles"):
#
# H = { X = (x1, x2, x3) : x1^2 + x2^2 - x3^2 = -1, x3 > 0 },
#
# with the Minkowski product <X, Y> = x1 y1 + x2 y2 - x3 y3 and
# cosh dist(X, Y) = -<X, Y>. Isometries are 3x3 matrices preserving this form.
# Only two kinds are needed:
#
# L(s): rotation by angle s about the "origin" p0 = (0, 0, 1). It turns the
# x1-x2 plane and leaves x3 alone.
# M(r): translation by distance r along the base geodesic
# { M(t) p0 = (sinh t, 0, cosh t) : t in R },
# a hyperbolic "boost" in the x1-x3 plane.
#
# THE TURTLE. Think of a walker standing at p0, facing along the base geodesic
# (the +x1 direction). A 3x3 isometry W records a position-and-heading
# ("frame"): the walker is at W p0, facing along the image under W of the base
# direction. Moves are applied on the RIGHT:
#
# W %*% M(r) walk forward distance r (along the current heading),
# W %*% L(s) turn left by angle s (without moving).
#
# Right-multiplication works because W M(r) p0 = W (M(r) p0): first do the
# move in the standard position, then carry the result to where the walker
# really is. So a walk is just a product of M's and L's, read left to right.
#
# USEFUL CONSEQUENCES, used below:
# * W M(t) p0, t in [0, r] is the segment the walker traces while walking r.
# * W L(pi/2) M(s) p0 is the point at distance s from the walker along
# the perpendicular to its left. For s in [0, w],
# this is the perpendicular arc of length w.
# * W e2, with e2 = (0, 1, 0), is a unit normal to the walker's line. For any
# point X, sinh dist(X, that line) = |<X, W e2>|. (pants-3d.R uses this.)
L <- function(s) matrix(c(cos(s), sin(s), 0, -sin(s), cos(s), 0, 0, 0, 1), 3)
M <- function(r) matrix(c(cosh(r), 0, sinh(r), 0, 1, 0, sinh(r), 0, cosh(r)), 3)
p0 <- c(0, 0, 1)
mink <- function(X, Y) X[1] * Y[1] + X[2] * Y[2] - X[3] * Y[3]
# From the hyperboloid to the Poincare disk: project from (0, 0, -1) onto the
# plane x3 = 0. A point of the disk is returned as a complex number x + iy.
# The projection is conformal (angles are right), but it shrinks distances more
# and more toward the boundary circle.
to_disk <- function(X) complex(real = X[1], imaginary = X[2]) / (1 + X[3])
# Half-collar width from the half-cuff c = l/2: sinh(w) sinh(c) = 1 (Prop. 3.1.8).
width <- function(ci) asinh(1 / sinh(ci))
# Seam length from the hexagon formula (Buser 2.4.1(i)). In a right-angled
# hexagon with alternate sides c1, c2, c3, the side between cj and ck (the seam
# a_i, opposite ci) satisfies
# cosh(ci) = sinh(cj) sinh(ck) cosh(a_i) - cosh(cj) cosh(ck),
# which we solve for a_i:
# cosh(a_i) = (cosh(ci) + cosh(cj) cosh(ck)) / (sinh(cj) sinh(ck)).
seam <- function(ci, cj, ck) {
acosh((cosh(ci) + cosh(cj) * cosh(ck)) / (sinh(cj) * sinh(ck)))
}
col_c <- c(c1 = "#185FA5", c2 = "#534AB7", c3 = "#1D9E75")
col_gap <- "#C0392B" # gap between half-collars along a seam
col_ovl <- "#E67E22" # overlap (only when widened)
# ---- the hexagon ---------------------------------------------------------------
#
# hexagon(l) builds the right-angled hexagon G with cuff lengths l = (l1, l2, l3).
#
# 1. SIDE LENGTHS. The c-sides are half-cuffs, c_i = l_i / 2 (Buser 3.1.6). The
# seams a_i come from the hexagon formula above. Now all six sides are known.
#
# 2. WALK AROUND IT. In Buser's order the sides are a1, c3, a2, c1, a3, c2.
# Start the turtle at p0 facing along +x1 (W = identity). For each side:
# - record the current frame (where this side starts, and its direction),
# - walk the side's length: W <- W M(len),
# - turn left 90 degrees: W <- W L(pi/2).
# Left turns mean we go around counterclockwise, so the INTERIOR of G is
# always on the walker's LEFT. collar_poly relies on this.
#
# 3. CHECK THAT IT CLOSES. After six sides and six right turns the walker must
# be back at p0 facing the original way, so W should be the identity again.
# This is Buser's Theorem 2.2.6 (the product of the moves around a closed
# polygon is the identity). `closure` records how far W is from the identity:
# about 1e-12 in practice, which confirms the side lengths.
#
# 4. CENTER IT. The walk starts at a corner, so G would sit off to one side of
# the disk and get squashed toward the boundary circle. To fix this, average
# the six vertices (as vectors in R^3) and rescale the result back onto the
# hyperboloid. That gives a point inside G: in the Klein model, which is the
# straight-line projection of the hyperboloid, this is a convex combination
# of the vertices. Then find the isometry B taking it to p0:
# a point at distance r = acosh(x3) in direction phi = atan2(x2, x1) is
# L(phi) M(r) p0, so B = (L(phi) M(r))^(-1) = M(-r) L(-phi).
# Replacing every frame Fr by B Fr moves the whole picture without changing
# its shape.
#
# The function returns:
# names, len the six sides in walking order, and their lengths
# frames frames[[k]] is the turtle's frame at the START of side k
# c, a, w half-cuffs c_i, seams a_i, collar widths w_i (indexed by i)
# closure the check from step 3
hexagon <- function(l) {
cc <- l / 2 # step 1
aa <- c(
seam(cc[1], cc[2], cc[3]),
seam(cc[2], cc[3], cc[1]),
seam(cc[3], cc[1], cc[2])
)
names <- c("a1", "c3", "a2", "c1", "a3", "c2")
len <- c(aa[1], cc[3], aa[2], cc[1], aa[3], cc[2])
W <- diag(3)
frames <- vector("list", 6) # step 2
for (k in 1:6) {
frames[[k]] <- W
W <- W %*% M(len[k]) %*% L(pi / 2)
}
# step 4: move an interior point (normalized sum of the vertices) to the center
V <- sapply(frames, \(Fr) Fr %*% p0) # the six vertices, as columns
ctr <- rowSums(V)
ctr <- ctr / sqrt(-mink(ctr, ctr)) # back onto the hyperboloid
B <- M(-acosh(ctr[3])) %*% L(-atan2(ctr[2], ctr[1]))
list(
names = names,
len = len,
frames = lapply(frames, \(Fr) B %*% Fr),
c = cc,
a = aa,
w = width(cc),
closure = max(abs(W - diag(3)))
) # step 3
}
# Points along a side, as disk coordinates. Starting from frame Fr, walk from
# distance `from` to distance `to` along the heading: Fr M(t) p0. Used for the
# hexagon's edges (from = 0, to = side length) and for the gap segments.
side_pts <- function(Fr, from, to, n = 100) {
map_vec(seq(from, to, length.out = n), \(t) to_disk(Fr %*% M(t) %*% p0))
}
# ---- half-collars --------------------------------------------------------------
#
# The half-collar of gamma_i, restricted to G, is the set of points of G within
# distance w_i of the side c_i. The proof of Proposition 3.1.8 shows it is swept
# out by the perpendiculars to c_i of length w_i: for each point at distance t
# along c_i, walk distance s in [0, w_i] perpendicular to c_i, into G. In turtle
# terms that point is
#
# perp(t, s) = Fr M(t) L(pi/2) M(s) p0
#
# (walk t along the side, turn left toward the interior, walk s).
# So the region is the image of the rectangle [0, len] x [0, w] under perp,
# and its boundary is the image of the rectangle's four edges:
# s = 0: the side c_i itself (t from 0 to len),
# t = len: the perpendicular at the far end, out to distance w.
# It runs along the adjacent seam, which meets c_i at a
# right angle.
# s = w: the equidistant curve at distance w (traced backwards).
# It is NOT a geodesic: it bends away from c_i.
# t = 0: the perpendicular at the near end, back to the side.
# It runs along the other adjacent seam.
# All four are curved in the disk model, so all four are sampled. (Joining the
# corners with straight chords instead cuts outside the hexagon when w is
# large, i.e. for short cuffs.)
collar_poly <- function(Fr, len, w, n = 120) {
ts <- seq(0, len, length.out = n)
ss <- seq(0, w, length.out = n)
perp <- function(t, s) to_disk(Fr %*% M(t) %*% L(pi / 2) %*% M(s) %*% p0)
c(
side_pts(Fr, 0, len, n), # s = 0: the side c_i
map_vec(ss, \(s) perp(len, s)), # t = len: up the far seam
map_vec(rev(ts), \(t) perp(t, w)), # s = w: the equidistant curve, backwards
map_vec(rev(ss), \(s) perp(0, s))
) # t = 0: down the near seam
}
# ---- gaps along the seams --------------------------------------------------------
#
# Each seam a_k joins two cuffs. Walking it from its start, the first w_i of it
# lies in the half-collar of the cuff at its start, and the last w_j lies in the
# half-collar of the cuff at its end. What remains in the middle, of length
# a_k - w_i - w_j, is the gap (Example 3.1.9, Step 1). If that number is
# negative (only possible when the collars are widened by eps), the two
# half-collars overlap along the seam.
#
# For seam a_k (k = 1, 2, 3): which c-sides are at its start and its end?
# In the walking order a1, c3, a2, c1, a3, c2 (cyclic), each seam starts where
# the previous c-side ends and ends where the next c-side starts:
# a1 runs from c2 to c3, a2 from c3 to c1, a3 from c1 to c2.
seam_ends <- list(a1 = c(2, 3), a2 = c(3, 1), a3 = c(1, 2))
# ---- the plot ----------------------------------------------------------------------
#
# hex_plot draws, in the disk:
# 1. the boundary circle (optional),
# 2. the three half-collars as shaded polygons (collar_poly),
# 3. the six sides of G (side_pts),
# 4. along each seam, the gap in red or the overlap in orange,
# 5. side labels a_i, c_i, placed at the middle of each side and pushed a
# little away from the center (z * 1.07) so they sit just outside G.
# eps widens every half-collar: widths w_i + eps.
hex_plot <- function(
hx,
eps = 0,
show_gaps = TRUE,
show_labels = TRUE,
show_disk = TRUE
) {
w <- hx$w + eps
# every side as a sampled curve, tagged with its index k and name
sides <- imap_dfr(hx$frames, \(Fr, k) {
tibble(z = side_pts(Fr, 0, hx$len[k]), k = k, side = hx$names[k])
})
# the half-collar of each cuff, built on the frame of its c-side
collars <- map_dfr(1:3, \(i) {
k <- match(paste0("c", i), hx$names)
tibble(
z = collar_poly(hx$frames[[k]], hx$len[k], w[i]),
collar = paste0("c", i)
)
})
# gaps (or overlaps) along each seam: the part of seam k between distance
# w_start from its start and distance w_end from its end
segs <- map_dfr(1:3, \(i) {
nm <- paste0("a", i)
k <- match(nm, hx$names)
e <- seam_ends[[nm]]
from <- w[e[1]]
to <- hx$len[k] - w[e[2]]
if (from <= to) {
tibble(
z = side_pts(hx$frames[[k]], from, to, 40),
seam = nm,
kind = "gap"
)
} else {
tibble(
z = side_pts(hx$frames[[k]], to, from, 40),
seam = nm,
kind = "overlap"
)
}
})
p <- ggplot()
if (show_disk) {
circ <- tibble(t = seq(0, 2 * pi, length.out = 300), x = cos(t), y = sin(t))
p <- p + geom_path(data = circ, aes(x, y), color = "grey85")
}
p <- p +
geom_polygon(
data = collars,
aes(Re(z), Im(z), fill = collar, group = collar),
alpha = 0.35,
color = NA
) +
geom_path(
data = sides,
aes(Re(z), Im(z), group = k),
color = "grey20",
linewidth = 0.7
)
if (show_gaps && nrow(segs)) {
p <- p +
geom_path(
data = segs,
aes(Re(z), Im(z), group = seam, color = kind),
linewidth = 2.2,
lineend = "round"
) +
scale_color_manual(
values = c(gap = col_gap, overlap = col_ovl),
name = NULL,
labels = c(
gap = "gap between half-collars",
overlap = "overlap (disjointness fails)"
)
)
}
if (show_labels) {
# label = plotmath string like "a[1]", drawn with parse = TRUE as a subscript
labs_df <- sides |>
group_by(k, side) |>
summarise(z = z[ceiling(n() / 2)], .groups = "drop") |>
mutate(
z = z * 1.22,
lab = paste0(substr(side, 1, 1), "[", substr(side, 2, 2), "]")
)
p <- p +
geom_text(
data = labs_df,
aes(Re(z), Im(z), label = lab),
parse = TRUE,
size = 5
)
}
# whole disk, or zoom to the hexagon
lim <- if (show_disk) 1.04 else max(Mod(sides$z)) * 1.12
p +
scale_fill_manual(
values = col_c,
name = NULL,
labels = scales::parse_format()(c(
"C*group('[', gamma[1], ']')",
"C*group('[', gamma[2], ']')",
"C*group('[', gamma[3], ']')"
))
) +
coord_fixed(xlim = c(-lim, lim), ylim = c(-lim, lim)) +
theme_void(base_size = 14) +
theme(
legend.position = "bottom",
legend.box = "vertical",
plot.background = element_rect(fill = "white", color = NA)
)
}
# ---- the table -----------------------------------------------------------------------
#
# The true (hyperbolic) sizes, which the disk picture distorts. Columns are
# i = 1, 2, 3; the "seam" and "gap" rows refer to the seam a_i opposite c_i,
# whose gap is a_i - w_j - w_k for the two cuffs j, k at its ends.
info_table <- function(hx, eps) {
w <- hx$w + eps
gap <- function(nm) {
k <- match(nm, hx$names)
e <- seam_ends[[nm]]
hx$len[k] - w[e[1]] - w[e[2]]
}
tibble(
` ` = c(
"cuff length ℓᵢ",
"half-cuff cᵢ = ℓᵢ/2",
"collar width wᵢ",
if (eps > 0) "widened width wᵢ + ε" else NULL,
"seam aᵢ (opposite cᵢ)",
"gap along aᵢ"
),
`i = 1` = c(
2 * hx$c[1],
hx$c[1],
hx$w[1],
if (eps > 0) w[1] else NULL,
hx$a[1],
gap("a1")
),
`i = 2` = c(
2 * hx$c[2],
hx$c[2],
hx$w[2],
if (eps > 0) w[2] else NULL,
hx$a[2],
gap("a2")
),
`i = 3` = c(
2 * hx$c[3],
hx$c[3],
hx$w[3],
if (eps > 0) w[3] else NULL,
hx$a[3],
gap("a3")
)
) |>
mutate(across(-1, \(v) sprintf("%.4f", v)))
}
# ---- UI -------------------------------------------------------------------------
ui <- fluidPage(
titlePanel("Right-angled hexagons and half-collars"),
sidebarLayout(
sidebarPanel(
width = 3,
h4("Cuff lengths"),
sliderInput(
"l1",
HTML("ℓ<sub>1</sub> = length of γ<sub>1</sub>"),
min = 0.05,
max = 6,
value = 2,
step = 0.05
),
sliderInput(
"l2",
HTML("ℓ<sub>2</sub> = length of γ<sub>2</sub>"),
min = 0.05,
max = 6,
value = 2,
step = 0.05
),
sliderInput(
"l3",
HTML("ℓ<sub>3</sub> = length of γ<sub>3</sub>"),
min = 0.05,
max = 6,
value = 2,
step = 0.05,
animate = animationOptions(interval = 150)
),
helpText(HTML(
"Each width is set by the cuff: sinh w<sub>i</sub> sinh(ℓ<sub>i</sub>/2) = 1.",
"Short cuff, wide collar."
)),
actionButton("demo", "Example 3.1.9: ℓ₁ = ℓ₂ = 2, ℓ₃ → 0"),
hr(),
sliderInput(
"eps",
HTML("Widen every half-collar by ε"),
min = 0,
max = 0.5,
value = 0,
step = 0.01
),
helpText(
"At ε = 0 the half-collars never overlap (Prop. 3.1.8).",
"For ε > 0, shrink a cuff until the gap turns orange."
),
hr(),
checkboxInput("show_gaps", "Mark gaps along the seams", TRUE),
checkboxInput("show_labels", "Label the sides", TRUE),
checkboxInput(
"show_disk",
"Show the whole disk (uncheck to zoom to the hexagon)",
TRUE
)
),
mainPanel(
width = 9,
tabsetPanel(
tabPanel(
"Hexagon (disk model)",
fluidRow(
column(7, plotOutput("hex", height = "600px")),
column(
5,
h4("Lengths"),
tableOutput("info"),
helpText(HTML(
"One of the two hexagons G, G′ of the pair of pants, drawn in the",
"Poincaré disk. Its sides alternate between half-cuffs",
"c<sub>i</sub> = ℓ<sub>i</sub>/2 and seams a<sub>i</sub>, where",
"a<sub>i</sub> is opposite c<sub>i</sub>. Shaded: the parts of the",
"half-collars inside G. Red: the gap along each seam between the two",
"half-collars that meet it. The disk model compresses distances near",
"the boundary circle, so use the table for actual sizes."
))
)
)
),
tabPanel(
"Pants in 3D",
if (has_rgl) {
tagList(
rgl::rglwidgetOutput("pants3d", width = "100%", height = "600px"),
helpText(
"Mirror-symmetric model: G above the grey plane, G′ below,",
"the seams on the mirror. Drag to rotate; the view is kept when",
"you move the sliders. With ε > 0, orange marks points in two",
"widened half-collars at once. Lengths and widths are not to",
"scale; only the positions of the pieces are."
)
)
} else {
helpText(
"The 3D view needs the rgl package and ../pants-3d.R.",
"Install rgl with install.packages(\"rgl\")."
)
}
)
)
)
)
)
# ---- server -----------------------------------------------------------------------
#
# Shiny recomputes things reactively: a reactive({...}) or render*({...}) reruns
# automatically whenever an input it reads changes. The chain here is
# sliders l1, l2, l3 -> hx() (the hexagon) -> the plot and the table,
# slider eps and the checkboxes -> the plot and the table only
# (the hexagon itself doesn't depend on eps).
server <- function(input, output, session) {
# "Example 3.1.9" button: set l1 = l2 = 2 and make l3 small.
observeEvent(input$demo, {
updateSliderInput(session, "l1", value = 2)
updateSliderInput(session, "l2", value = 2)
updateSliderInput(session, "l3", value = 0.1)
})
# The hexagon, recomputed only when a cuff length changes.
hx <- reactive({
req(input$l1, input$l2, input$l3)
hexagon(c(input$l1, input$l2, input$l3))
})
output$hex <- renderPlot(
hex_plot(
hx(),
input$eps,
isTRUE(input$show_gaps),
isTRUE(input$show_labels),
isTRUE(input$show_disk)
),
res = 96
)
output$info <- renderTable(
info_table(hx(), input$eps),
striped = TRUE,
spacing = "s"
)
if (has_rgl) {
# The 3D model is redrawn whenever a slider changes. To keep the view the
# user has rotated to, we ask the widget for its current rotation (userMatrix)
# as soon as a slider moves; the answer arrives in input$par3d before the
# debounced redraw runs, and the redraw reuses it.
view <- reactiveValues(user = NULL, zoom = 0.8, subscene = NULL)
# The slider values, but only after they have been still for 0.4 s, so that
# dragging a slider (or pressing play) doesn't trigger dozens of redraws.
params3d <- reactive(list(
l = c(input$l1, input$l2, input$l3),
eps = input$eps
)) |>
debounce(400)
# As soon as any slider moves, ask the widget in the browser for its
# current rotation and zoom. (Nothing to ask before the first draw.)
observeEvent(
list(input$l1, input$l2, input$l3, input$eps),
{
if (!is.null(view$subscene)) {
rgl::shinyGetPar3d(
c("userMatrix", "zoom"),
session,
subscene = view$subscene
)
}
},
ignoreInit = TRUE
)
# The browser's answer: remember it for the next redraw.
observeEvent(input$par3d, {
um <- input$par3d$userMatrix
if (is.numeric(um) && length(um) == 16) {
view$user <- matrix(um, 4, 4)
}
zm <- input$par3d$zoom
if (is.numeric(zm) && length(zm) == 1) view$zoom <- zm
})
# Rebuild the scene from scratch (pants3d is in ../pants-3d.R), then restore
# the remembered view. isolate() reads the view without making the redraw
# depend on it, so rotating the model by hand never triggers a redraw.
# We store the scene's subscene id so the next request goes to this widget.
output$pants3d <- rgl::renderRglwidget({
p <- params3d()
rgl::open3d()
rgl::bg3d("white")
pants_lights()
pants3d(p$l[1], p$l[2], p$l[3], eps = p$eps)
um <- isolate(view$user)
if (is.null(um)) {
rgl::view3d(theta = 30, phi = 40, zoom = 0.8)
} else {
rgl::par3d(userMatrix = um, zoom = isolate(view$zoom))
}
view$subscene <- rgl::currentSubscene3d()
rgl::rglwidget()
})
}
}
shinyApp(ui, server)
## file: pants-3d.R
# A mirror-symmetric 3D model of a hyperbolic pair of pants
#
# pants3d(l1, l2, l3) -> draws the model in the current rgl scene
#
# The pants Y = G + G' is built from the right-angled hexagon G with sides
# a1, c3, a2, c1, a3, c2 (Buser 3.1). The model is honest about everything the
# reflection symmetry of Y forces, and about incidence (what touches what):
#
# * G is drawn as a sheet ABOVE the plane z = 0 and G' as its mirror image
# BELOW it. The three seams a1, a2, a3 are exactly where the surface meets
# the mirror plane z = 0, just as they are the fixed set of the isometry of
# Y swapping G and G'.
# * Each boundary geodesic gamma_i = c_i (top) + c_i' (bottom) is an open
# "mouth" that crosses the mirror at the two endpoints of its seams, so the
# seams split it into halves (Corollary 3.1.6), meeting it at right angles.
# * Intrinsic sets (half-collars, the perpendicular h, ...) are computed in the
# hyperbolic plane and carried to the model through the map below, so they
# are in the right place relative to each other.
#
# What it is NOT honest about: lengths, widths and the curvature. No picture in
# R^3 is. The planar shape is the disk-model picture of G (which is conformal,
# so angles in the plane are right), and the height is an arbitrary bump that
# vanishes on the seams.
#
# The map from G to the model:
# 1. place G in the hyperboloid model with a central point at the origin;
# 2. take its Poincare-disk picture (x, y); G is star-shaped about 0 there,
# because rays from 0 are hyperbolic geodesics and G is convex;
# 3. lift to height z = +- H * sqrt(D), where D is a soft minimum of the
# hyperbolic distances to the three seam lines. The square root makes the
# sheet vertical where it meets the mirror, so G and G' join smoothly.
library(rgl)
# ---- hyperboloid model (same conventions as the Buser 2.2 notes) -------------
.L <- function(s) matrix(c(cos(s), sin(s), 0, -sin(s), cos(s), 0, 0, 0, 1), 3)
.M <- function(r) matrix(c(cosh(r), 0, sinh(r), 0, 1, 0, sinh(r), 0, cosh(r)), 3)
.p0 <- c(0, 0, 1)
.e2 <- c(0, 1, 0) # unit normal to the base geodesic M(t) p0
.mink <- function(X, Y) X[1] * Y[1] + X[2] * Y[2] - X[3] * Y[3]
.to_disk <- function(X) complex(real = X[1], imaginary = X[2]) / (1 + X[3])
.from_disk <- function(z) {
r2 <- Mod(z)^2
rbind(2 * Re(z), 2 * Im(z), 1 + r2) / rep(1 - r2, each = 3)
}
pants_width <- function(ci) asinh(1 / sinh(ci))
pants_seam <- function(ci, cj, ck) acosh((cosh(ci) + cosh(cj) * cosh(ck)) / (sinh(cj) * sinh(ck)))
# All the intrinsic data of the hexagon G, centered at the origin.
pants_hexagon <- function(l1, l2, l3) {
cc <- c(l1, l2, l3) / 2
aa <- c(pants_seam(cc[1], cc[2], cc[3]), pants_seam(cc[2], cc[3], cc[1]),
pants_seam(cc[3], cc[1], cc[2]))
names <- c("a1", "c3", "a2", "c1", "a3", "c2") # counterclockwise
len <- c(aa[1], cc[3], aa[2], cc[1], aa[3], cc[2])
W <- diag(3); frames <- vector("list", 6)
for (k in 1:6) {
frames[[k]] <- W
W <- W %*% .M(len[k]) %*% .L(pi / 2) # walk, then turn left
}
# Recenter: move the normalized sum of the vertices (a point inside G) to p0.
V <- sapply(frames, \(Fr) Fr %*% .p0)
ctr <- rowSums(V); ctr <- ctr / sqrt(-.mink(ctr, ctr))
B <- .M(-acosh(ctr[3])) %*% .L(-atan2(ctr[2], ctr[1]))
frames <- lapply(frames, \(Fr) B %*% Fr)
list(names = names, len = len, frames = frames, c = cc, a = aa, w = pants_width(cc),
normal = lapply(frames, \(Fr) as.vector(Fr %*% .e2)))
}
# Hyperbolic distance from hyperboloid points (columns of X) to the line of side k
.dist_to_side <- function(hx, k, X) {
n <- hx$normal[[k]]
asinh(abs(n[1] * X[1, ] + n[2] * X[2, ] - n[3] * X[3, ]))
}
# Points along side k (or along any frame), as disk coordinates
.side_disk <- function(Fr, len, n = 80)
vapply(seq(0, len, length.out = n), \(t) .to_disk(Fr %*% .M(t) %*% .p0), complex(1))
# Height function on disk points z
.height <- function(hx, z, H = 0.55, k = 4) {
X <- .from_disk(z)
d <- sapply(which(startsWith(hx$names, "a")), \(j) .dist_to_side(hx, j, X))
if (is.null(dim(d))) d <- matrix(d, nrow = 1)
D <- rowSums(pmax(d, 1e-12)^(-k))^(-1 / k)
H * sqrt(tanh(D))
}
# Lift disk points to the top sheet (sign = +1) or the bottom sheet (sign = -1)
.lift <- function(hx, z, sign = 1) cbind(Re(z), Im(z), sign * .height(hx, z))
pants_colors <- c(G = "#E8E2D0", Gp = "#C9D6E3",
c1 = "#185FA5", c2 = "#534AB7", c3 = "#1D9E75",
seam = "#C0392B", h = "#2C2C2A", overlap = "#E67E22")
# Lights: one from above and a dimmer one from below, so both sheets are lit.
pants_lights <- function() {
clear3d("lights")
light3d(theta = 0, phi = 60)
light3d(theta = 0, phi = -60, specular = "black", diffuse = "grey45")
}
# Draw the model. Options:
# collars: shade the half-collars C*[gamma_i] on both sheets
# eps: widen every half-collar by eps; points lying in two widened
# half-collars are colored orange (where disjointness fails)
# show_h: draw the perpendicular h from c3 to a3 (Example 3.1.9) on both sheets
# labels: text labels for gamma_i, c_i, c_i', a_i
# mirror: a faint patch of the mirror plane z = 0
pants3d <- function(l1 = 2, l2 = 2, l3 = 2, collars = TRUE, eps = 0, show_h = FALSE,
labels = TRUE, mirror = TRUE, n_rad = 40, n_side = 70) {
hx <- pants_hexagon(l1, l2, l3)
# Boundary of G in the disk, as one closed polyline (counterclockwise)
bnd <- unlist(lapply(1:6, \(k) head(.side_disk(hx$frames[[k]], hx$len[k], n_side), -1)))
bnd <- c(bnd, bnd[1])
rr <- seq(0, 1, length.out = n_rad)
Z <- outer(rr, bnd) # star-shaped about 0
Zh <- .height(hx, as.vector(Z)); dim(Zh) <- dim(Z)
# Surface colors: base color per sheet, overridden inside the half-collars
col_for <- function(base) {
cols <- matrix(base, nrow(Z), ncol(Z))
if (collars) {
X <- .from_disk(as.vector(Z))
n_in <- 0
for (i in 1:3) {
k <- match(paste0("c", i), hx$names)
inside <- .dist_to_side(hx, k, X) < hx$w[i] + eps
n_in <- n_in + inside
cols[inside] <- adjustcolor(pants_colors[paste0("c", i)], 0.45,
offset = c(0.45, 0.45, 0.45, 0))
}
cols[n_in >= 2] <- pants_colors["overlap"]
}
cols
}
surface3d(Re(Z), Im(Z), Zh, color = col_for(pants_colors["G"]), specular = "grey15",
back = "filled", front = "filled")
surface3d(Re(Z), Im(Z), -Zh, color = col_for(pants_colors["Gp"]), specular = "grey15",
back = "filled", front = "filled")
# Curves
for (k in 1:6) {
nm <- hx$names[k]; z <- .side_disk(hx$frames[[k]], hx$len[k], 120)
if (startsWith(nm, "a")) {
lines3d(Re(z), Im(z), 0, color = pants_colors["seam"], lwd = 5)
} else {
col <- pants_colors[nm]
lines3d(.lift(hx, z, 1), color = col, lwd = 5) # c_i (front half of gamma_i)
lines3d(.lift(hx, z, -1), color = col, lwd = 5) # c_i' (back half)
}
}
if (show_h) {
# h: the common perpendicular from c3 to a3, found by minimizing over c3
k3 <- match("c3", hx$names); ka <- match("a3", hx$names)
na <- hx$normal[[ka]]
pt_c3 <- \(t) hx$frames[[k3]] %*% .M(t) %*% .p0
tt <- optimize(\(t) abs(.mink(pt_c3(t), na)), c(0, hx$len[k3]))$minimum
# walk perpendicular from c3 into G until we hit the a3 line
Fr <- hx$frames[[k3]] %*% .M(tt) %*% .L(pi / 2)
s_end <- uniroot(\(s) .mink(Fr %*% .M(s) %*% .p0, na), c(1e-6, 50))$root
zh <- vapply(seq(0, s_end, length.out = 120), \(s) .to_disk(Fr %*% .M(s) %*% .p0), complex(1))
lines3d(.lift(hx, zh, 1), color = pants_colors["h"], lwd = 3)
lines3d(.lift(hx, zh, -1), color = pants_colors["h"], lwd = 3)
}
if (mirror) {
# a faint patch of the mirror plane z = 0, to show that the seams lie in it
m <- 1.15 * max(Mod(bnd))
quads3d(c(-m, m, m, -m), c(-m, -m, m, m), 0, color = "grey50", alpha = 0.10,
lit = FALSE, depth_mask = FALSE)
}
if (labels) {
lab_at <- function(k, frac, sign, push) {
z <- .side_disk(hx$frames[[k]], hx$len[k], 101)[round(1 + 100 * frac)]
z <- z * push
c(Re(z), Im(z), sign * .height(hx, z / push) * (if (sign == 0) 0 else 1.25))
}
for (k in 1:6) {
nm <- hx$names[k]; i <- substr(nm, 2, 2)
if (startsWith(nm, "a")) {
p <- lab_at(k, 0.5, 0, 1.12)
text3d(p[1], p[2], p[3], texts = paste0("a", sub_digit(i)), color = pants_colors["seam"], cex = 1.1)
} else {
p <- lab_at(k, 0.5, 1, 1.10)
text3d(p[1], p[2], p[3], texts = paste0("c", sub_digit(i)), color = pants_colors[nm], cex = 1.1)
p <- lab_at(k, 0.5, -1, 1.10)
text3d(p[1], p[2], p[3], texts = paste0("c", sub_digit(i), "\u2032"), color = pants_colors[nm], cex = 1.1)
p <- lab_at(k, 0.5, 0, 1.28)
text3d(p[1], p[2], p[3], texts = paste0("\u03b3", sub_digit(i)), color = pants_colors[nm], cex = 1.2,
font = 2)
}
}
}
aspect3d("iso")
invisible(hx)
}
sub_digit <- function(i) c("1" = "\u2081", "2" = "\u2082", "3" = "\u2083")[[as.character(i)]]