# NABS reviewer demo animation — R (base graphics + gifski).
#
# Parity port of nabs_demo.py. Renders the full pass (home -> scan -> wash ->
# dry -> re-scan -> stage -> recommend) to an animated GIF, driven by the same
# data-defined process spec (PHASES) and synthetic thermal field. To render
# real captures, replace the body of thermal_raster() with your co-registered
# FLIR Lepton 3.5 frame; the geometry, timeline, and staging overlay are
# agnostic to where the field comes from.
#
# Deps:  none (base R). Frames -> GIF via ffmpeg/ImageMagick, no CRAN needed.
# Run:   Rscript nabs_demo.R
# Out:   nabs_demo_R.gif

fps  <- 20
VMAX <- 3.5

## Process definition — data, not control flow -------------------------------
phases <- data.frame(
  key = c("home", "scan", "wash", "dry", "rescan", "stage", "act"),
  dur = c(0.8, 2.6, 1.5, 1.5, 1.6, 1.3, 2.2),
  status = c(
    "Homing gantry to start position",
    "Scanning \u2014 thermal + optical capture",
    "Washing \u2014 warm-water pass",
    "Drying \u2014 warm-air pass",
    "Re-scanning to confirm",
    "Staging: non-blanchable erythema at sacrum",
    "Stage I / possible DTI \u2014 offload + nurse alert + FHIR Observation"),
  stringsAsFactors = FALSE)
TOTAL <- sum(phases$dur)

## Scene geometry (x 0..680, y 0..300, y grows downward) ----------------------
SACRUM <- c(x = 326, y = 164)
HEEL   <- c(x = 546, y = 168)
hotspots <- list(
  list(pos = SACRUM, sigma = 26, dT = 3.2, reveal = c(300, 350)),
  list(pos = HEEL,   sigma = 16, dT = 1.6, reveal = c(505, 545)))

pal <- grDevices::hcl.colors(256, "Inferno")
NX <- 140; NY <- 44
gx <- seq(120, 560, length.out = NX)
gy <- seq(140, 190, length.out = NY)   # row 1 = top of body

clamp <- function(v, a = 0, b = 1) pmax(a, pmin(b, v))
lerp  <- function(a, b, t) a + (b - a) * t

phase_at <- function(t) {
  acc <- 0
  for (i in seq_len(nrow(phases))) {
    if (t < acc + phases$dur[i]) return(list(i = i, lp = (t - acc) / phases$dur[i]))
    acc <- acc + phases$dur[i]
  }
  list(i = nrow(phases), lp = 1)
}

carriage_x <- function(i, lp) {
  k <- phases$key[i]
  if (k %in% c("scan", "rescan")) return(lerp(90, 590, lp))
  if (i == 1) return(90)
  SACRUM["x"]
}

reveal <- function(hs, i, cx) {
  if (i < 2) return(0)
  if (phases$key[i] == "scan") return(clamp((cx - hs$reveal[1]) / diff(hs$reveal)))
  1
}

## Synthetic registered thermal field -> raster of colours --------------------
## >>> REPLACE THIS BODY to render a real co-registered Lepton frame. <<<
thermal_raster <- function(reveals) {
  Z <- matrix(0, NY, NX)
  X <- matrix(gx, NY, NX, byrow = TRUE)
  Y <- matrix(gy, NY, NX)
  for (h in seq_along(hotspots)) {
    hs <- hotspots[[h]]
    Z <- Z + hs$dT * reveals[h] *
      exp(-(((X - hs$pos["x"])^2 + (Y - hs$pos["y"])^2) / (2 * hs$sigma^2)))
  }
  norm  <- clamp(Z / VMAX)
  alpha <- clamp(norm * 1.1)
  idx   <- pmax(1, ceiling(as.vector(norm) * 256))
  rgbm  <- grDevices::col2rgb(pal[idx]) / 255
  cols  <- grDevices::rgb(rgbm[1, ], rgbm[2, ], rgbm[3, ], alpha = as.vector(alpha))
  as.raster(matrix(cols, NY, NX))
}

circle <- function(cx, cy, r, col, lwd = 2, alpha = 1) {
  a <- seq(0, 2 * pi, length.out = 80)
  lines(cx + r * cos(a), cy + r * sin(a),
        col = grDevices::adjustcolor(col, alpha), lwd = lwd)
}

draw <- function(t) {
  par(mar = c(0, 0, 0, 0), bg = "white")
  plot(NA, xlim = c(0, 680), ylim = c(360, -10), asp = 1,
       xaxs = "i", yaxs = "i", axes = FALSE, xlab = "", ylab = "")

  ph <- phase_at(t); i <- ph$i; k <- phases$key[i]
  cx <- carriage_x(i, ph$lp)

  ## bed + patient
  rect(64, 222, 616, 196, col = "#8f8f88", border = NA)
  rect(64, 198, 616, 182, col = "#b4b2a9", border = NA)
  segments(64, 92, 616, 92, col = "#5f5e5a", lwd = 4)
  segments(c(72, 608), 92, c(72, 608), 210, col = "#8f8f88", lwd = 3)
  body <- "#a8a49a"
  circle(118, 168, 16, body, lwd = 1); polygon(118 + 16 * cos(seq(0, 2*pi, len=40)),
          168 + 16 * sin(seq(0, 2*pi, len=40)), col = body, border = NA)
  rect(134, 190, 344, 150, col = body, border = NA)
  rect(330, 186, 542, 158, col = body, border = NA)
  rect(536, 182, 558, 158, col = body, border = NA)

  ## thermal overlay
  reveals <- vapply(hotspots, reveal, numeric(1), i = i, cx = cx)
  if (any(reveals > 0)) {
    rasterImage(thermal_raster(reveals), 120, 190, 560, 140, interpolate = TRUE)
  }

  ## staging ring
  if (i >= 6) {
    circle(SACRUM["x"], SACRUM["y"], 30, "#e24b4a", lwd = 2)
    circle(SACRUM["x"], SACRUM["y"], 30, "#e24b4a", lwd = 2, alpha = 0.35)
  }

  ## carriage
  rect(cx - 5, 148, cx + 5, 92, col = "#5f5e5a", border = NA)
  rect(cx - 20, 162, cx + 20, 146, col = "#444441", border = NA)
  if (k %in% c("scan", "rescan")) {
    polygon(c(cx - 16, cx + 16, cx + 30, cx - 30), c(162, 162, 192, 192),
            col = grDevices::adjustcolor("#378add", 0.16), border = NA)
  } else if (k == "wash") {
    dx <- c(-10, 2, 12); dy <- c(176, 180, 176)
    for (j in seq_along(dx)) circle(cx + dx[j], dy[j], 2.4, "#378add", lwd = 4)
  } else if (k == "dry") {
    dx <- c(-14, -6, 2); dy <- c(176, 182, 176)
    segments(cx + dx, dy, cx + dx + 10, dy, col = "#ba7517", lwd = 2)
  }

  ## captions: phase pills + status
  pw <- 88
  for (j in seq_len(nrow(phases))) {
    px <- 40 + (j - 1) * pw; on <- (j == i)
    rect(px, 338, px + pw - 8, 318,
         col = if (on) "#185fa5" else NA,
         border = if (on) "#185fa5" else "#b4b2a9", lwd = 1)
    text(px + (pw - 8) / 2, 328, phases$key[j], cex = 0.62,
         col = if (on) "white" else "#5f5e5a")
  }
  text(40, 352, phases$status[i], adj = 0, cex = 0.9,
       col = if (i >= 7) "#a32d2d" else "#3d3d3a")
}

n <- round(TOTAL * fps)
times <- seq(0, TOTAL, length.out = n + 1)[1:n]
dir.create("frames", showWarnings = FALSE)
for (fi in seq_along(times)) {
  png(sprintf("frames/f%04d.png", fi), width = 680, height = 380, type = "cairo")
  draw(times[fi])
  dev.off()
}
cat("wrote", length(times), "PNG frames to frames/\n")