# Quasi-Newton Hessian Update Functions
# ======================================
#
# Implements Algorithm 4a: BFGS, SR1, L-BFGS, and L-SR1 update formulas
# for maintaining Hessian approximations in the QN-ARC optimizer.


#' SR1 (Symmetric Rank-1) Hessian Update
#'
#' Updates the Hessian approximation using the SR1 formula. Unlike BFGS,
#' SR1 can represent indefinite matrices, making it ideal for ARC which
#' naturally handles negative curvature.
#'
#' @param b Current Hessian approximation (n x n symmetric matrix).
#' @param s Step vector: s = x_new - x_old.
#' @param y Gradient difference: y = g_new - g_old.
#' @param skip_tol Tolerance for skip test (default: 1e-8). Update is skipped
#'   if |r'*s| < skip_tol * ||r|| * ||s||.
#' @param skip_count Current count of consecutive skipped updates.
#' @param restart_threshold Number of consecutive skips before restart
#'   (default: 5).
#'
#' @return A list with components:
#'   \item{b}{Updated Hessian approximation (n x n matrix).}
#'   \item{skipped}{Logical indicating if update was skipped.}
#'   \item{skip_count}{Updated skip counter (reset to 0 if update applied or
#'     restart triggered).}
#'   \item{restarted}{Logical indicating if b was reset to scaled identity.}
#'
#' @details
#' The SR1 update formula is:
#' \deqn{B_{k+1} = B_k + \frac{r r^T}{r^T s}}
#' where \eqn{r = y - B_k s}.
#'
#' The update is skipped when the denominator is too small relative to the
#' norms of r and s, which prevents numerical instability. After too many
#' consecutive skips, the approximation is reset using Barzilai-Borwein
#' scaling.
#'
#' @references
#' Algorithm 4a in design/pseudocode.qmd
#'
#' Conn, A. R., Gould, N. I., & Toint, P. L. (1991). Convergence of
#' quasi-Newton matrices generated by the symmetric rank one update.
#' Mathematical Programming, 50(1-3), 177-195.
#'
#' @keywords internal
update_sr1 <- function(b, s, y,
                       skip_tol = 1e-8,
                       skip_count = 0L,
                       restart_threshold = 5L) {
  # Compute residual: how far b is from satisfying secant equation
  r <- y - b %*% s
  r <- as.vector(r)

  # Norms for skip test
  r_norm <- sqrt(sum(r^2))
  s_norm <- sqrt(sum(s^2))

  # Skip if s is essentially zero (no step taken)
  if (s_norm < .Machine$double.eps) {
    return(list(b = b, skipped = TRUE, skip_count = skip_count, restarted = FALSE))
  }

  # Skip if r is essentially zero (B already satisfies secant equation)
  if (r_norm < .Machine$double.eps * s_norm) {
    return(list(b = b, skipped = TRUE, skip_count = skip_count, restarted = FALSE))
  }

  # Denominator of SR1 update
  denom <- sum(r * s)

  # Skip test: avoid division by near-zero denominator
  if (abs(denom) >= skip_tol * r_norm * s_norm) {
    # Apply SR1 update: B_{k+1} = B_k + (r r^T) / denom
    b_updated <- b + outer(r, r) / denom

    return(list(
      b = b_updated,
      skipped = FALSE,
      skip_count = 0L,
      restarted = FALSE
    ))
  }

  # Denominator too small - skip update
  skip_count <- skip_count + 1L

  # Check if restart is needed
  if (skip_count > restart_threshold) {
    # Restart with Barzilai-Borwein scaling: gamma = (y'*s) / (s'*s)
    ys <- sum(y * s)
    ss <- sum(s * s)

    if (ss > .Machine$double.eps && abs(ys) > .Machine$double.eps) {
      gamma <- ys / ss
    } else {
      gamma <- 1.0
    }

    # Reset to scaled identity
    n <- length(s)
    b_updated <- gamma * diag(n)

    return(list(
      b = b_updated,
      skipped = TRUE,
      skip_count = 0L,
      restarted = TRUE
    ))
  }

  # Skip without restart
  return(list(
    b = b,
    skipped = TRUE,
    skip_count = skip_count,
    restarted = FALSE
  ))
}


#' BFGS (Broyden-Fletcher-Goldfarb-Shanno) Hessian Update
#'
#' Updates the Hessian approximation using the BFGS formula. BFGS maintains
#' positive definiteness when the curvature condition y'*s > 0 is satisfied.
#'
#' @param b Current Hessian approximation (n x n symmetric positive definite
#'   matrix).
#' @param s Step vector: s = x_new - x_old.
#' @param y Gradient difference: y = g_new - g_old.
#'
#' @return A list with components:
#'   \item{b}{Updated Hessian approximation (n x n matrix).}
#'   \item{skipped}{Logical indicating if update was skipped due to curvature
#'     condition violation.}
#'
#' @details
#' The BFGS update formula is:
#' \deqn{B_{k+1} = B_k - \frac{B_k s s^T B_k}{s^T B_k s} + \frac{y y^T}{y^T s}}
#'
#' The update is skipped when the curvature condition \eqn{y^T s > 0} is
#' violated. This can happen on nonconvex problems. When skipped, the previous
#' approximation is retained.
#'
#' Note: BFGS maintains positive definiteness, which wastes ARC's ability to
#' handle indefinite Hessians. Consider using SR1 for nonconvex problems.
#'
#' @references
#' Algorithm 4a in design/pseudocode.qmd
#'
#' Nocedal, J., & Wright, S. J. (2006). Numerical Optimization (2nd ed.).
#' Springer. Section 6.1.
#'
#' @keywords internal
update_bfgs <- function(b, s, y) {
  # Curvature condition: y's > 0 required for positive definiteness
  ys <- sum(y * s)

  if (ys <= .Machine$double.eps) {
    # Curvature condition violated - skip update
    return(list(b = b, skipped = TRUE))
  }

  # Compute B*s for use in update
  bs <- as.vector(b %*% s)
  sbs <- sum(s * bs)

  # BFGS update: B_{k+1} = B_k - (B*s)(B*s)' / (s'*B*s) + y*y' / (y'*s)
  b_updated <- b - outer(bs, bs) / sbs + outer(y, y) / ys

  list(b = b_updated, skipped = FALSE)
}


#' Powell-Damped BFGS Update
#'
#' Applies Powell damping to ensure the curvature condition is satisfied,
#' then performs a BFGS update. This guarantees an update even when the
#' standard curvature condition y's > 0 fails.
#'
#' @param b Current Hessian approximation (n x n symmetric matrix).
#' @param s Step vector: s = x_new - x_old.
#' @param y Gradient difference: y = g_new - g_old.
#' @param damping_threshold Threshold for damping (default: 0.2).
#'   Damping applied if y's < damping_threshold * s'Bs.
#'
#' @return A list with components:
#'   \item{b}{Updated Hessian approximation (n x n matrix).}
#'   \item{theta}{Damping parameter used (1.0 = no damping).}
#'   \item{y_damped}{The damped y vector used in update.}
#'   \item{skipped}{Logical indicating if update was skipped (only if s'Bs
#'     is too small to apply damping).}
#'
#' @details
#' Powell damping modifies y to y_damped = theta*y + (1-theta)*Bs such that
#' s'*y_damped >= damping_threshold * s'*Bs, ensuring positive curvature.
#'
#' The formula for theta when y's < damping_threshold * s'Bs is:
#' theta = (1 - damping_threshold) * s'Bs / (s'Bs - y's)
#'
#' This ensures s'*y_damped = damping_threshold * s'Bs exactly.
#'
#' @references
#' Powell, M. J. D. (1978). A fast algorithm for nonlinearly constrained
#' optimization calculations. Numerical Analysis, 144-157.
#'
#' Algorithm 4a-hybrid in design/pseudocode.qmd
#'
#' @keywords internal
update_bfgs_powell <- function(b, s, y, damping_threshold = 0.2) {
  # Compute B*s and curvature terms

  bs <- as.vector(b %*% s)
  sbs <- sum(s * bs)
  ys <- sum(y * s)

  # Guard: if s'Bs is too small, we can't apply damping safely

  if (sbs <= .Machine$double.eps) {
    return(list(b = b, theta = NA_real_, y_damped = y, skipped = TRUE))
  }

  # Determine if damping is needed
  if (ys >= damping_threshold * sbs) {
    # No damping needed - use standard BFGS
    theta <- 1.0
    y_damped <- y
  } else {
    # Apply Powell damping
    # theta chosen so s'*y_damped = damping_threshold * s'Bs
    theta <- (1 - damping_threshold) * sbs / (sbs - ys)
    y_damped <- theta * y + (1 - theta) * bs
  }

  # Apply BFGS with (possibly damped) y
  ys_damped <- sum(y_damped * s)
  b_updated <- b - outer(bs, bs) / sbs + outer(y_damped, y_damped) / ys_damped

  list(b = b_updated, theta = theta, y_damped = y_damped, skipped = FALSE)
}


#' Hybrid BFGS/SR1 Update with Automatic Routing
#'
#' Attempts BFGS first, falls back to SR1, then to Powell-damped BFGS.
#' Provides robust quasi-Newton updates for both convex and nonconvex regions.
#'
#' @param b Current Hessian approximation (n x n symmetric matrix).
#' @param s Step vector: s = x_new - x_old.
#' @param y Gradient difference: y = g_new - g_old.
#' @param bfgs_tol Tolerance for BFGS curvature condition (default: 1e-10).
#' @param sr1_skip_tol Tolerance for SR1 skip test (default: 1e-8).
#' @param skip_count Current count of consecutive skipped updates.
#' @param restart_threshold Number of consecutive skips before restart
#'   (default: 5).
#'
#' @return A list with components:
#'   \item{b}{Updated Hessian approximation (n x n matrix).}
#'   \item{update_type}{Character: "bfgs", "sr1", "powell", or "skipped".}
#'   \item{skipped}{Logical indicating if no update was applied.}
#'   \item{skip_count}{Updated skip counter (reset on successful update).}
#'   \item{restarted}{Logical indicating if b was reset to scaled identity.}
#'   \item{theta}{Powell damping parameter (only if update_type = "powell").}
#'
#' @details
#' Routing priority:
#' 1. BFGS if y's > bfgs_tol (stable, positive definite)
#' 2. SR1 if |r's| >= sr1_skip_tol * ||r|| * ||s|| (allows indefiniteness)
#' 3. Powell-damped BFGS otherwise (guaranteed update)
#'
#' The hybrid approach is ideal for problems that transition between
#' convex and nonconvex regions.
#'
#' @references
#' Algorithm 4a-hybrid in design/pseudocode.qmd
#'
#' @keywords internal
update_hybrid <- function(b, s, y,
                          bfgs_tol = 1e-10,
                          sr1_skip_tol = 1e-8,
                          skip_count = 0L,
                          restart_threshold = 5L) {
  # Early exit for zero step
  s_norm <- sqrt(sum(s^2))
  if (s_norm < .Machine$double.eps) {
    return(list(
      b = b,
      update_type = "skipped",
      skipped = TRUE,
      skip_count = skip_count,
      restarted = FALSE,
      theta = NA_real_
    ))
  }

  # Curvature for BFGS check

  ys <- sum(y * s)

  # 1. TRY BFGS (stable, maintains positive definiteness)
  if (ys > bfgs_tol) {
    bs <- as.vector(b %*% s)
    sbs <- sum(s * bs)

    if (sbs > .Machine$double.eps) {
      b_updated <- b - outer(bs, bs) / sbs + outer(y, y) / ys
      return(list(
        b = b_updated,
        update_type = "bfgs",
        skipped = FALSE,
        skip_count = 0L,
        restarted = FALSE,
        theta = NA_real_
      ))
    }
  }

  # 2. FALL BACK TO SR1 (allows indefiniteness)
  r <- y - as.vector(b %*% s)
  r_norm <- sqrt(sum(r^2))
  denom <- sum(r * s)

  # Skip SR1 if r is essentially zero (B already satisfies secant equation)
  # or if denominator condition is met
  if (r_norm >= .Machine$double.eps * s_norm &&
      abs(denom) >= sr1_skip_tol * r_norm * s_norm) {
    b_updated <- b + outer(r, r) / denom
    return(list(
      b = b_updated,
      update_type = "sr1",
      skipped = FALSE,
      skip_count = 0L,
      restarted = FALSE,
      theta = NA_real_
    ))
  }

  # 3. FALL BACK TO POWELL-DAMPED BFGS (guaranteed update)
  powell_result <- update_bfgs_powell(b, s, y)

  if (!powell_result$skipped) {
    return(list(
      b = powell_result$b,
      update_type = "powell",
      skipped = FALSE,
      skip_count = 0L,
      restarted = FALSE,
      theta = powell_result$theta
    ))
  }

  # All methods failed - skip update (very rare edge case)
  skip_count <- skip_count + 1L

  # Check if restart is needed
  if (skip_count > restart_threshold) {
    # Restart with Barzilai-Borwein scaling
    ss <- sum(s * s)
    if (ss > .Machine$double.eps && abs(ys) > .Machine$double.eps) {
      gamma <- ys / ss
    } else {
      gamma <- 1.0
    }
    n <- length(s)
    b_updated <- abs(gamma) * diag(n)  # Use abs to ensure positive scaling

    return(list(
      b = b_updated,
      update_type = "skipped",
      skipped = TRUE,
      skip_count = 0L,
      restarted = TRUE,
      theta = NA_real_
    ))
  }

  # Skip without restart
  list(
    b = b,
    update_type = "skipped",
    skipped = TRUE,
    skip_count = skip_count,
    restarted = FALSE,
    theta = NA_real_
  )
}


#' Hybrid Update with SR1-First Routing
#'
#' Reverse priority of update_hybrid: tries SR1 first (to preserve
#' indefinite curvature information), then BFGS, then Powell-damped
#' BFGS. Used by arcopt_qn when the current Hessian approximation is
#' indefinite or when recent BFGS predictions have been inaccurate.
#'
#' @inheritParams update_hybrid
#' @return Same structure as update_hybrid.
#' @keywords internal
update_hybrid_sr1_first <- function(b, s, y,
                                    bfgs_tol = 1e-10,
                                    sr1_skip_tol = 1e-8,
                                    skip_count = 0L,
                                    restart_threshold = 5L) {
  s_norm <- sqrt(sum(s^2))
  if (s_norm < .Machine$double.eps) {
    return(list(
      b = b, update_type = "skipped", skipped = TRUE,
      skip_count = skip_count, restarted = FALSE, theta = NA_real_
    ))
  }

  # 1. TRY SR1 FIRST (preserves indefinite curvature)
  r <- y - as.vector(b %*% s)
  r_norm <- sqrt(sum(r^2))
  denom <- sum(r * s)
  if (r_norm >= .Machine$double.eps * s_norm &&
      abs(denom) >= sr1_skip_tol * r_norm * s_norm) {
    b_updated <- b + outer(r, r) / denom
    return(list(
      b = b_updated, update_type = "sr1", skipped = FALSE,
      skip_count = 0L, restarted = FALSE, theta = NA_real_
    ))
  }

  # 2. FALL BACK TO BFGS (when SR1 denominator is degenerate)
  ys <- sum(y * s)
  if (ys > bfgs_tol) {
    bs <- as.vector(b %*% s)
    sbs <- sum(s * bs)
    if (sbs > .Machine$double.eps) {
      b_updated <- b - outer(bs, bs) / sbs + outer(y, y) / ys
      return(list(
        b = b_updated, update_type = "bfgs", skipped = FALSE,
        skip_count = 0L, restarted = FALSE, theta = NA_real_
      ))
    }
  }

  # 3. FALL BACK TO POWELL-DAMPED BFGS
  powell_result <- update_bfgs_powell(b, s, y)
  if (!powell_result$skipped) {
    return(list(
      b = powell_result$b, update_type = "powell", skipped = FALSE,
      skip_count = 0L, restarted = FALSE, theta = powell_result$theta
    ))
  }

  # All methods failed -- apply the same restart logic as update_hybrid
  skip_count <- skip_count + 1L
  if (skip_count > restart_threshold) {
    ss <- sum(s * s)
    gamma <- if (ss > .Machine$double.eps && abs(ys) > .Machine$double.eps) {
      ys / ss
    } else {
      1.0
    }
    n <- length(s)
    b_updated <- abs(gamma) * diag(n)
    return(list(
      b = b_updated, update_type = "skipped", skipped = TRUE,
      skip_count = 0L, restarted = TRUE, theta = NA_real_
    ))
  }
  list(
    b = b, update_type = "skipped", skipped = TRUE,
    skip_count = skip_count, restarted = FALSE, theta = NA_real_
  )
}
