#| '!! 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
# Two markings of the same torus
#
# Pick a lattice Z + tau Z and a matrix g in SL(2, Z). The app draws
#   - the parallelogram on the basis (1, tau), and
#   - the parallelogram on the new basis (c tau + d, a tau + b),
# both in the SAME lattice, without renormalizing. Both tile the same lattice
# points and have the same area: they are two ways of cutting open one torus.
# A "normalize" slider rotates and scales the plane by (c tau + d)^(-t); at t = 1
# the new first vector is 1 and the new parallelogram's far corner is g . tau.
# A second panel shows the normalized parallelograms (1, tau) and (1, g . tau)
# and the reduced point in the upper half-plane.
#
# Convention: g = [[a, b], [c, d]] acts on the column (omega2, omega1), so
#   new omega2 = a tau + b,  new omega1 = c tau + d,
#   g . tau = (a tau + b) / (c tau + d).
#
# TWISTS. A twist slider deforms the torus before the marking is changed:
#   twist along a (direction 1):    basis (1, tau) -> (1, tau + t)
#   twist along b (direction tau):  basis (1, tau) -> (1 + t tau, tau)
# For fractional t this is a different torus (a different point of Teichmüller
# space). At integer t = n the lattice is the original one again, and the
# twisted basis is the original basis changed by the Dehn twist T^n (for a) or
# [[1, 0], [n, 1]] (for b): an integer twist IS a change of marking. Everything
# else in the app (both parallelograms, g . tau, the reduction, the shortest
# curve) is computed for the twisted torus. The picture is drawn in the twisted
# basis's own coordinates, so the lattice dots visibly return at integer t.
# The original parallelogram (1, tau) is shown dashed for comparison.
#
# Run with: shiny::runApp("path/to/marking_app")

library(shiny)
library(bslib)
library(ggplot2)
library(dplyr)
library(tidyr)
library(tibble)
library(purrr)

col_orig <- "#1D9E75" # basis (1, tau)
col_new <- "#D85A30" # basis (c tau + d, a tau + b)
col_red <- "#185FA5" # reduced point

tau_presets <- list(
  "0.3 + 1.2i" = complex(real = 0.3, imaginary = 1.2),
  "i (square)" = 1i,
  "e^(pi i/3) (hexagonal)" = exp(1i * pi / 3),
  "e^(5 pi i/6)" = exp(1i * 5 * pi / 6),
  "1.6 + 0.2i" = complex(real = 1.6, imaginary = 0.2)
)

g_presets <- list(
  "I (identity)" = c(1, 0, 0, 1),
  "T = [[1,1],[0,1]]" = c(1, 1, 0, 1),
  "T^5" = c(1, 5, 0, 1),
  "S = [[0,-1],[1,0]]" = c(0, -1, 1, 0),
  "ST = [[0,-1],[1,1]]" = c(0, -1, 1, 1),
  "[[2,1],[1,1]]" = c(2, 1, 1, 1),
  "[[5,3],[3,2]]" = c(5, 3, 3, 2),
  "[[13,8],[8,5]]" = c(13, 8, 8, 5),
  "[[1,0],[4,1]]" = c(1, 0, 4, 1)
)

# ---- math helpers -----------------------------------------------------------

fmt_c <- function(z, digits = 3) {
  re <- round(Re(z), digits)
  im <- round(Im(z), digits)
  paste0(re, if (im < 0) " - " else " + ", abs(im), "i")
}

# Reduce tau to the standard fundamental domain, recording the moves.
reduce_tau <- function(tau, max_iter = 200, tol = 1e-12) {
  moves <- character()
  for (k in seq_len(max_iter)) {
    n <- round(Re(tau))
    if (n != 0) {
      tau <- tau - n
      moves <- c(moves, paste0("T^", -n))
    }
    if (Mod(tau) < 1 - tol) {
      tau <- -1 / tau
      moves <- c(moves, "S")
    } else {
      break
    }
  }
  list(tau = tau, moves = moves)
}

parallelogram <- function(v1, v2) {
  z <- c(0, v1, v1 + v2, v2)
  tibble(x = Re(z), y = Im(z))
}

# Lattice points m + n tau inside a box, or NULL if there would be too many.
lattice_points <- function(tau, xlim, ylim, max_pts = 40000) {
  n_rng <- seq(floor(ylim[1] / Im(tau)) - 1, ceiling(ylim[2] / Im(tau)) + 1)
  est <- length(n_rng) * (diff(xlim) + 3)
  if (est > max_pts) {
    return(NULL)
  }
  map_dfr(n_rng, function(n) {
    m <- seq(
      floor(xlim[1] - n * Re(tau)) - 1,
      ceiling(xlim[2] - n * Re(tau)) + 1
    )
    z <- m + n * tau
    tibble(x = Re(z), y = Im(z))
  }) |>
    filter(between(x, xlim[1], xlim[2]), between(y, ylim[1], ylim[2]))
}

# Shortest nonzero vector of the lattice Z + tau Z (Lagrange-Gauss reduction).
# For the square and hexagonal lattices there are ties; this returns one of them.
shortest_vector <- function(tau, max_iter = 200) {
  u <- 1 + 0i
  v <- tau
  for (k in seq_len(max_iter)) {
    if (Mod(v) < Mod(u)) {
      tmp <- u
      u <- v
      v <- tmp
    }
    mu <- round(Re(v * Conj(u)) / Mod(u)^2)
    if (mu == 0) {
      break
    }
    v <- v - mu * u
  }
  if (Mod(v) < Mod(u)) v else u
}

# Integer coordinates (s, t) with z = s p1 + t p2.
lattice_coords <- function(z, p1, p2) {
  M <- matrix(c(Re(p1), Im(p1), Re(p2), Im(p2)), 2)
  round(solve(M, c(Re(z), Im(z))))
}

# The closed geodesic in direction v, cut into pieces by the parallelogram on
# (p1, p2) and folded back into it. The curve passes through the parallelogram's
# center. Returns one row per piece with complex endpoints z0, z1.
folded_curve <- function(v, p1, p2) {
  st <- lattice_coords(v, p1, p2)
  S <- st[1]
  Tt <- st[2]
  s0 <- 0.5
  t0 <- 0.5
  cuts <- function(x0, D) {
    if (D == 0) {
      return(numeric())
    }
    r <- sort(c(x0, x0 + D))
    k <- seq(ceiling(r[1]), floor(r[2]))
    (k - x0) / D
  }
  u <- sort(unique(c(0, 1, cuts(s0, S), cuts(t0, Tt))))
  u <- u[u >= 0 & u <= 1]
  pieces <- map_dfr(seq_len(length(u) - 1), function(i) {
    if (u[i + 1] - u[i] < 1e-12) {
      return(NULL)
    }
    um <- (u[i] + u[i + 1]) / 2
    sh <- c(floor(s0 + um * S), floor(t0 + um * Tt))
    pt <- function(uu) (s0 + uu * S - sh[1]) * p1 + (t0 + uu * Tt - sh[2]) * p2
    tibble(z0 = pt(u[i]), z1 = pt(u[i + 1]))
  })
  # The start point (the center) is interior, so the last piece runs straight
  # into the first one: merge them. This leaves |S| + |T| pieces.
  n <- nrow(pieces)
  if (n > 1) {
    pieces$z0[1] <- pieces$z0[n]
    pieces <- pieces[-n, ]
  }
  pieces |> mutate(piece = row_number())
}

col_short <- "#2C2C2A" # shortest closed curve

# "2(cτ + d) − (aτ + b)" style formatting of an integer combination.
fmt_comb <- function(k, names) {
  terms <- character()
  for (i in seq_along(k)) {
    if (k[i] == 0) {
      next
    }
    coef <- if (abs(k[i]) == 1) "" else as.character(abs(k[i]))
    nm <- if (names[i] == "·1") {
      (if (coef == "") "1" else coef)
    } else {
      paste0(coef, names[i])
    }
    sgn <- if (k[i] < 0) "−" else "+"
    terms <- c(
      terms,
      if (length(terms) == 0) {
        paste0(if (k[i] < 0) "−" else "", nm)
      } else {
        paste(sgn, nm)
      }
    )
  }
  if (length(terms) == 0) "0" else paste(terms, collapse = " ")
}

# ---- twists ------------------------------------------------------------------
#
# The twisted basis (omega1, omega2) and its normalized form (1, tau_t):
#   a: (1, tau + t),        so tau_t = tau + t,             omega1 = 1
#   b: (1 + t tau, tau),    so tau_t = tau / (1 + t tau),   omega1 = 1 + t tau
# (1 + t tau is never 0, since Im tau > 0.) The app computes with the normalized
# lattice Z + tau_t Z and multiplies the picture by omega1 to draw it in the
# twisted basis's own coordinates.

twist_tau <- function(tau, curve, t) {
  if (curve == "a") {
    list(tau = tau + t, omega1 = 1 + 0i)
  } else {
    list(tau = tau / (1 + t * tau), omega1 = 1 + t * tau)
  }
}

col_twist <- "#C0392B" # the twist path in the upper half-plane

# ---- plots ------------------------------------------------------------------

# tau is the (twisted, normalized) tau_t; omega1 scales the picture into the
# twisted basis's own coordinates; tau0 (if given) is the untwisted tau, whose
# parallelogram (1, tau0) is drawn dashed.
lattice_plot <- function(
  tau,
  g,
  zoom = FALSE,
  t = 0,
  show_short = FALSE,
  omega1 = 1 + 0i,
  tau0 = NULL
) {
  a <- g[1]
  b <- g[2]
  c <- g[3]
  d <- g[4]
  w1 <- c * tau + d # new first vector
  w2 <- a * tau + b # new second vector
  gtau <- w2 / w1

  # Normalizing map, run partway. Points are stored in normalized coordinates
  # (first vector 1); the picture multiplies them by
  #   f(s) = omega1^(1 - s) * w1^(-s).
  # At s = 0 this is omega1: the twisted lattice in its own coordinates (for no
  # twist, omega1 = 1 and nothing moves). At s = 1 it is 1 / w1: the new first
  # vector lands on 1 and the new second vector on g.tau.
  f_at <- function(s) {
    exp(
      (1 - s) *
        complex(real = log(Mod(omega1)), imaginary = Arg(omega1)) -
        s * complex(real = log(Mod(w1)), imaginary = Arg(w1))
    )
  }
  f <- f_at(t)

  lv <- c("(1, τ)", "(cτ + d, aτ + b)")
  para_z <- function(v1, v2, s) tibble(z = c(0, v1, v1 + v2, v2) * f_at(s))
  paras <- bind_rows(
    para_z(1, tau, t) |> mutate(basis = lv[1]),
    para_z(w1, w2, t) |> mutate(basis = lv[2])
  ) |>
    mutate(x = Re(z), y = Im(z), basis = factor(basis, levels = lv))

  # Fixed window over the whole slider range, so the picture doesn't jump.
  ss <- seq(0, 1, by = 0.1)
  frame_z <- if (zoom) {
    c(unlist(map(ss, \(s) para_z(1, tau, s)$z)), 1, gtau)
  } else {
    c(unlist(map(ss, \(s) c(para_z(1, tau, s)$z, para_z(w1, w2, s)$z))))
  }
  # the original parallelogram (1, tau0), in normalized coordinates: divide by omega1
  orig_norm <- if (!is.null(tau0)) c(0, 1, 1 + tau0, tau0) / omega1 else NULL
  if (!is.null(orig_norm) && !zoom) {
    frame_z <- c(frame_z, unlist(map(ss, \(s) orig_norm * f_at(s))))
  }
  fx <- range(Re(frame_z))
  fy <- range(Im(frame_z))
  pad <- if (zoom) 0.6 else 0.12 * max(diff(fx), diff(fy), 1)
  xlim <- fx + c(-pad, pad)
  ylim <- fy + c(-pad, pad)

  # Lattice points: find them in the original plane, then move them by f.
  corners <- complex(
    real = xlim[c(1, 2, 2, 1)],
    imaginary = ylim[c(1, 1, 2, 2)]
  ) /
    f
  pts <- lattice_points(tau, range(Re(corners)), range(Im(corners)))
  if (!is.null(pts)) {
    pts <- tibble(z = complex(real = pts$x, imaginary = pts$y) * f) |>
      mutate(x = Re(z), y = Im(z)) |>
      filter(between(x, xlim[1], xlim[2]), between(y, ylim[1], ylim[2]))
  }

  vec_z <- c(1, tau, w1, w2) * f
  vecs <- tibble(
    xend = Re(vec_z),
    yend = Im(vec_z),
    basis = factor(lv[c(1, 1, 2, 2)], levels = lv)
  )

  # Where the orange corner ends up when fully normalized
  target <- tibble(x = Re(gtau), y = Im(gtau))

  sub <- if (t == 0) {
    if (!is.null(tau0)) {
      "Twisted lattice (dashed: original)"
    } else {
      "Both bases in the same lattice (not normalized)"
    }
  } else if (t == 1) {
    "Normalized: cτ + d → 1, aτ + b → g·τ"
  } else {
    paste0("Normalizing: plane multiplied by (cτ + d)^(−", t, ")")
  }
  if (is.null(pts)) {
    sub <- paste0(sub, "\nToo many lattice points to draw")
  }

  p <- ggplot() +
    geom_hline(yintercept = 0, color = "grey80") +
    geom_vline(xintercept = 0, color = "grey80")
  if (!is.null(pts)) {
    p <- p + geom_point(data = pts, aes(x, y), size = 0.9, color = "grey35")
  }
  if (!is.null(orig_norm)) {
    oz <- c(orig_norm, orig_norm[1]) * f
    p <- p +
      geom_path(
        data = tibble(z = oz),
        aes(Re(z), Im(z)),
        colour = col_orig,
        linetype = "22",
        linewidth = 0.6
      )
  }
  p <- p +
    geom_polygon(
      data = paras,
      aes(x, y, fill = basis, color = basis),
      alpha = 0.22,
      linewidth = 0.7
    ) +
    geom_segment(
      data = vecs,
      aes(0, 0, xend = xend, yend = yend, color = basis),
      linewidth = 1,
      arrow = arrow(length = unit(0.1, "inches"))
    )
  if (show_short) {
    v <- shortest_vector(tau)
    curve <- bind_rows(folded_curve(v, 1, tau), folded_curve(v, w1, w2)) |>
      mutate(z0 = z0 * f, z1 = z1 * f)
    p <- p +
      geom_segment(
        data = curve,
        aes(Re(z0), Im(z0), xend = Re(z1), yend = Im(z1)),
        color = col_short,
        linewidth = 1.5,
        lineend = "round"
      ) +
      geom_point(
        data = curve,
        aes(Re(z0), Im(z0)),
        color = col_short,
        size = 1.6
      ) +
      geom_point(
        data = curve,
        aes(Re(z1), Im(z1)),
        color = col_short,
        size = 1.6
      )
  }
  p +
    geom_point(
      data = target,
      aes(x, y),
      shape = 21,
      size = 4,
      stroke = 1,
      color = col_new,
      fill = NA
    ) +
    geom_text(
      data = target,
      aes(x, y),
      label = "g·τ",
      color = col_new,
      vjust = -1.3,
      size = 4.5
    ) +
    scale_fill_manual(values = c(col_orig, col_new), name = "Basis") +
    scale_color_manual(values = c(col_orig, col_new), name = "Basis") +
    coord_fixed(xlim = xlim, ylim = ylim, expand = FALSE) +
    labs(x = "Re", y = "Im", subtitle = sub) +
    theme_minimal(base_size = 13) +
    theme(legend.position = "bottom", panel.grid.minor = element_blank())
}

# twist_path (if given): the path tau_s, s from 0 to the current twist, drawn
# from the untwisted tau to the twisted one.
h_plot <- function(tau, g, red, show_short = FALSE, twist_path = NULL) {
  a <- g[1]
  b <- g[2]
  c <- g[3]
  d <- g[4]
  gtau <- (a * tau + b) / (c * tau + d)
  w1 <- c * tau + d

  # Normalized parallelograms: (1, tau) and (1, g.tau). Each point is a corner.
  lv <- c("(1, τ)", "(1, g·τ)")
  paras <- bind_rows(
    parallelogram(1, tau) |> mutate(basis = lv[1]),
    parallelogram(1, gtau) |> mutate(basis = lv[2])
  ) |>
    mutate(basis = factor(basis, levels = lv))

  pts <- tibble(
    z = c(tau, gtau, red),
    label = c("τ", "g·τ", "reduced"),
    col = c(col_orig, col_new, col_red)
  ) |>
    mutate(x = Re(z), y = Im(z)) |>
    # merge points that coincide (e.g. tau already reduced) into one label
    mutate(key = paste(round(x, 6), round(y, 6))) |>
    group_by(key) |>
    summarise(
      x = first(x),
      y = first(y),
      col = first(col),
      label = paste(label, collapse = " = "),
      .groups = "drop"
    )

  extra <- if (is.null(twist_path)) complex() else twist_path
  ymax <- max(2.2, max(paras$y, pts$y, Im(extra)) * 1.15)
  xlim <- c(
    min(-1.6, min(paras$x, pts$x, Re(extra)) - 0.4),
    max(1.6, max(paras$x, pts$x, Re(extra)) + 0.4)
  )

  fd <- tibble(theta = seq(pi / 3, 2 * pi / 3, length.out = 100)) |>
    mutate(x = cos(theta), y = sin(theta))
  fd_poly <- bind_rows(
    tibble(x = -0.5, y = ymax),
    fd |> arrange(desc(theta)) |> select(x, y),
    tibble(x = 0.5, y = ymax)
  )
  circle <- tibble(theta = seq(0, pi, length.out = 200)) |>
    mutate(x = cos(theta), y = sin(theta))

  p <- ggplot() +
    geom_polygon(
      data = fd_poly,
      aes(x, y),
      fill = "grey92",
      color = "grey55",
      linetype = "dashed"
    ) +
    geom_path(data = circle, aes(x, y), color = "grey75", linetype = "dotted") +
    geom_hline(yintercept = 0, color = "grey40") +
    geom_polygon(
      data = paras,
      aes(x, y, fill = basis, color = basis),
      alpha = 0.18,
      linewidth = 0.6
    )
  if (show_short) {
    # The normalized new parallelogram is the old one divided by w1, so the
    # shortest curve on it is the folded curve divided by w1 too.
    v <- shortest_vector(tau)
    curve <- bind_rows(
      folded_curve(v, 1, tau),
      folded_curve(v / w1, 1, gtau)
    )
    p <- p +
      geom_segment(
        data = curve,
        aes(Re(z0), Im(z0), xend = Re(z1), yend = Im(z1)),
        color = col_short,
        linewidth = 1.2,
        lineend = "round"
      )
  }
  if (!is.null(twist_path)) {
    tp <- tibble(z = twist_path)
    p <- p +
      geom_path(
        data = tp,
        aes(Re(z), Im(z)),
        colour = col_twist,
        linewidth = 1,
        arrow = arrow(length = unit(0.08, "inches"))
      ) +
      geom_point(
        data = tp[1, ],
        aes(Re(z), Im(z)),
        colour = col_twist,
        size = 2.2,
        shape = 21,
        fill = "white",
        stroke = 1
      )
  }
  p +
    geom_point(data = pts, aes(x, y), color = pts$col, size = 3) +
    geom_text(
      data = pts,
      aes(x, y, label = label),
      color = pts$col,
      vjust = -1,
      size = 4.5
    ) +
    scale_fill_manual(values = c(col_orig, col_new), name = NULL) +
    scale_color_manual(values = c(col_orig, col_new), name = NULL) +
    coord_fixed(xlim = xlim, ylim = c(-0.05, ymax), expand = FALSE) +
    labs(x = "Re", y = "Im") +
    theme_minimal(base_size = 13) +
    theme(legend.position = "bottom", panel.grid.minor = element_blank())
}

# ---- UI -----------------------------------------------------------------------

# The controls are grouped into tabs on one card in the sidebar (τ, Twist, g,
# View), so only one group is open at a time and the sidebar doesn't scroll.
# The plots and the table each sit on their own card. Inputs on a hidden tab
# keep their values, so switching tabs never changes the picture.

ui <- page_sidebar(
  title = "Twists of a marked torus",
  sidebar = sidebar(
    width = 340,
    navset_card_tab(
      id = "controls",
      nav_panel(
        "τ",
        selectInput(
          "tau_preset",
          "Preset τ",
          choices = c("(custom)", names(tau_presets)),
          selected = "0.3 + 1.2i"
        ),
        layout_columns(
          numericInput("re_tau", "Re τ", value = 0.3, step = 0.05),
          numericInput("im_tau", "Im τ", value = 1.2, min = 0.05, step = 0.05)
        ),
        helpText("The lattice Z + τZ: the torus before any twist.")
      ),
      nav_panel(
        "Twist",
        radioButtons(
          "tw_curve",
          "Twist along",
          inline = TRUE,
          choiceNames = list("a (direction 1)", "b (direction τ)"),
          choiceValues = c("a", "b")
        ),
        sliderInput(
          "tw",
          "Twist amount",
          min = -2,
          max = 2,
          value = 0,
          step = 0.01,
          animate = animationOptions(interval = 100)
        ),
        helpText(
          "Deforms the torus: a sends τ to τ + t; b sends the basis (1, τ) to",
          "(1 + tτ, τ). At integer t the lattice dots return to the original",
          "lattice: an integer twist is a change of marking by a Dehn twist."
        )
      ),
      nav_panel(
        "g",
        selectInput(
          "g_preset",
          "Preset g ∈ SL(2, Z)",
          choices = c("(custom)", names(g_presets)),
          selected = "[[2,1],[1,1]]"
        ),
        layout_columns(
          numericInput("a", "a", value = 2, step = 1),
          numericInput("b", "b", value = 1, step = 1)
        ),
        layout_columns(
          numericInput("c", "c", value = 1, step = 1),
          numericInput("d", "d", value = 1, step = 1)
        ),
        uiOutput("det_msg"),
        helpText(
          "g acts on the column (ω₂, ω₁): the new basis is",
          "(cτ + d, aτ + b), and g·τ = (aτ + b)/(cτ + d)."
        )
      ),
      nav_panel(
        "View",
        sliderInput(
          "t",
          "Normalize the new basis",
          min = 0,
          max = 1,
          value = 0,
          step = 0.02,
          animate = animationOptions(interval = 120)
        ),
        helpText(
          "Slides the plane by (cτ + d)^(−t). At t = 1 the new first",
          "vector is 1 and the orange corner sits on g·τ."
        ),
        checkboxInput(
          "zoom",
          "Zoom lattice view to the original parallelogram",
          FALSE
        ),
        checkboxInput("show_short", "Show the shortest closed curve", FALSE),
        helpText(
          "Drawn through the center of each parallelogram and folded back",
          "in by the side gluings. The pieces join into one closed curve."
        )
      )
    )
  ),
  layout_columns(
    col_widths = c(7, 5),
    card(
      full_screen = TRUE,
      card_header("Same lattice, two parallelograms"),
      plotOutput("lattice", height = "520px")
    ),
    layout_columns(
      col_widths = 12,
      card(
        full_screen = TRUE,
        card_header("Upper half-plane"),
        plotOutput("hplane", height = "380px")
      ),
      card(
        card_header("Details"),
        tableOutput("info")
      )
    )
  )
)

# ---- server -------------------------------------------------------------------

server <- function(input, output, session) {
  observeEvent(input$tau_preset, {
    z <- tau_presets[[input$tau_preset]]
    if (!is.null(z)) {
      updateNumericInput(session, "re_tau", value = round(Re(z), 4))
      updateNumericInput(session, "im_tau", value = round(Im(z), 4))
    }
  })

  observeEvent(input$g_preset, {
    m <- g_presets[[input$g_preset]]
    if (!is.null(m)) {
      updateNumericInput(session, "a", value = m[1])
      updateNumericInput(session, "b", value = m[2])
      updateNumericInput(session, "c", value = m[3])
      updateNumericInput(session, "d", value = m[4])
    }
  })

  # tau0: the untwisted tau from the inputs. tw_state: the twisted torus.
  # tau(): the twisted, normalized tau_t, which everything else uses.
  tau0 <- reactive({
    req(is.numeric(input$re_tau), is.numeric(input$im_tau))
    validate(need(input$im_tau > 0, "Im τ must be positive."))
    complex(real = input$re_tau, imaginary = input$im_tau)
  })
  tw_amount <- reactive(if (is.null(input$tw)) 0 else input$tw)
  tw_curve <- reactive(if (is.null(input$tw_curve)) "a" else input$tw_curve)
  tw_state <- reactive(twist_tau(tau0(), tw_curve(), tw_amount()))
  tau <- reactive(tw_state()$tau)
  twist_path <- reactive({
    if (tw_amount() == 0) {
      return(NULL)
    }
    vapply(
      seq(0, tw_amount(), length.out = 121),
      \(s) twist_tau(tau0(), tw_curve(), s)$tau,
      complex(1)
    )
  })

  g_raw <- reactive({
    req(
      is.numeric(input$a),
      is.numeric(input$b),
      is.numeric(input$c),
      is.numeric(input$d)
    )
    c(input$a, input$b, input$c, input$d)
  })

  g_ok <- reactive({
    g <- g_raw()
    all(g == round(g)) && (g[1] * g[4] - g[2] * g[3]) == 1
  })

  g <- reactive({
    validate(need(g_ok(), "Enter integers a, b, c, d with ad − bc = 1."))
    g_raw()
  })

  output$det_msg <- renderUI({
    gr <- g_raw()
    det <- gr[1] * gr[4] - gr[2] * gr[3]
    if (g_ok()) {
      tags$p(style = "color:#0F6E56;", paste0("det = ", det, "  ✓"))
    } else if (any(gr != round(gr))) {
      tags$p(style = "color:#A32D2D;", "Entries must be integers.")
    } else {
      tags$p(style = "color:#A32D2D;", paste0("det = ", det, ". It must be 1."))
    }
  })

  reduced <- reactive(reduce_tau(tau()))

  output$lattice <- renderPlot(
    lattice_plot(
      tau(),
      g(),
      isTRUE(input$zoom),
      if (is.null(input$t)) 0 else input$t,
      isTRUE(input$show_short),
      omega1 = tw_state()$omega1,
      tau0 = if (tw_amount() != 0) tau0() else NULL
    ),
    res = 96
  )
  output$hplane <- renderPlot(
    h_plot(tau(), g(), reduced()$tau, isTRUE(input$show_short), twist_path()),
    res = 96
  )

  output$info <- renderTable(
    {
      t <- tau()
      m <- g()
      w1 <- m[3] * t + m[4]
      w2 <- m[1] * t + m[2]
      gt <- (m[1] * t + m[2]) / (m[3] * t + m[4])
      red <- reduced()
      v <- shortest_vector(t)
      st_old <- lattice_coords(v, 1, t)
      st_new <- lattice_coords(v, w1, w2)
      tw_t <- tw_amount()
      n_int <- abs(tw_t - round(tw_t)) < 1e-9
      twist_rows <- if (tw_t == 0) {
        NULL
      } else {
        tibble(
          Quantity = c(
            "Twist",
            "Twisted τ (normalized)",
            "Back to the original lattice?"
          ),
          Value = c(
            sprintf("along %s by t = %s", tw_curve(), format(tw_t)),
            fmt_c(t),
            if (n_int) {
              sprintf(
                "yes: the twist is the change of marking %s",
                if (tw_curve() == "a") {
                  sprintf("T^%d = [[1,%d],[0,1]]", round(tw_t), round(tw_t))
                } else {
                  sprintf("[[1,0],[%d,1]]", round(tw_t))
                }
              )
            } else {
              "no: fractional t gives a different torus"
            }
          )
        )
      }
      bind_rows(
        twist_rows,
        tibble(
          Quantity = c(
            if (tw_t == 0) "τ" else "τ (twisted)",
            "g·τ",
            "Original side lengths",
            "New side lengths",
            "Area (both)",
            "Shortest curve (as a lattice vector)",
            "  in the new basis",
            "  pieces in (1, τ) / in new parallelogram",
            "(shortest)² / area",
            "Reduced τ",
            "Reduction steps from τ"
          ),
          Value = c(
            fmt_c(t),
            fmt_c(gt),
            paste0("1, ", round(Mod(t), 3)),
            paste0(round(Mod(w1), 3), ", ", round(Mod(w2), 3)),
            as.character(round(Im(t), 3)),
            paste0(
              fmt_comb(st_old, c("·1", "τ")),
              ",  length ",
              round(Mod(v), 3)
            ),
            fmt_comb(st_new, c("(cτ + d)", "(aτ + b)")),
            paste0(
              nrow(folded_curve(v, 1, t)),
              " / ",
              nrow(folded_curve(v, w1, w2))
            ),
            as.character(round(Mod(v)^2 / Im(t), 3)),
            fmt_c(red$tau),
            if (length(red$moves)) {
              paste(red$moves, collapse = ", ")
            } else {
              "none (already reduced)"
            }
          )
        )
      )
    },
    striped = TRUE,
    spacing = "s"
  )
}

shinyApp(ui, server)