# Internal helper: validate the 'responses' argument.
# Requires at least two numeric response options. Real-valued responses such as
# seq(-1, 1, by = 0.5) are allowed; states are treated as their numeric values.
checkResponses <- function(responses)
{
  if (length(responses) < 2)
  {
    stop("'responses' must contain at least two response options.")
  }
  if (anyNA(responses) || !is.numeric(responses))
  {
    stop("'responses' must be numeric.")
  }
  invisible(responses)
}

# Wrapper function:
IsingSampler <- function(n, graph, thresholds, beta = 1, nIter = 100, responses = c(0L, 1L), method = c("MH","CFTP","direct"), CFTPretry = 10, constrain, delta = 0)
{
  if (missing(graph)) stop("'graph' must be supplied.")
  if (missing(thresholds)) stop("'thresholds' must be supplied.")
  if (!is.matrix(graph) || !is.numeric(graph) || nrow(graph) != ncol(graph))
  {
    stop("'graph' must be a numeric square matrix.")
  }
  if (!isSymmetric(graph)) stop("'graph' must be a symmetric matrix.")
  if (length(n) != 1L || !is.numeric(n) || !is.finite(n) || n != round(n) || n < 1)
  {
    stop("'n' must be a single positive integer.")
  }
  if (length(nIter) != 1L || !is.numeric(nIter) || !is.finite(nIter) || nIter != round(nIter) || nIter < 1)
  {
    stop("'nIter' must be a single positive integer.")
  }
  if (length(beta) != 1L || !is.numeric(beta) || !is.finite(beta))
  {
    stop("'beta' must be a single finite numeric value.")
  }
  if (length(thresholds) != 1L && length(thresholds) != ncol(graph))
  {
    stop("'thresholds' must have length 1 or the number of nodes (ncol(graph)).")
  }
  checkResponses(responses)
  if (any(diag(graph)!=0))
  {
    diag(graph) <- 0
    warning("Diagonal set to 0")
  }
  N <- ncol(graph)

  # Recycle single-value thresholds / delta to one value per node:
  if (length(thresholds) == 1L) thresholds <- rep(thresholds, N)
  if (length(delta) == 1L) delta <- rep(delta, N)
  if (length(thresholds) != N) stop("'thresholds' must have length 1 or the number of nodes (ncol(graph)).")
  if (length(delta) != N) stop("'delta' must have length 1 or the number of nodes (ncol(graph)).")

  method <- method[1]
  if (! method %in% c("MH","CFTP","direct")) stop("method must be 'MH', 'CFTP', or 'direct'")

  # The Blume-Capel quadratic (delta) term only has an identifiable effect with
  # more than two response options: for two options delta * s^2 is an affine
  # function of s and is absorbed into the thresholds (a constant for symmetric
  # responses such as c(-1, 1)).
  if (any(delta != 0) && length(responses) == 2)
  {
    warning("With two response options the 'delta' term is not separately identifiable from the thresholds; results are equivalent to an Ising model with adjusted thresholds.")
  }

  # Exact sampling (CFTP) is only implemented for binary (two-level) responses:
  if (method == "CFTP" && length(responses) != 2)
  {
    stop("method = 'CFTP' (exact sampling) is currently only implemented for two response options. Use method = 'MH' or method = 'direct' for more than two response options.")
  }

  # Check constrains:
  if (missing(constrain))
  {
    constrain <- matrix(NA_real_,n,ncol(graph))
  }
  if (!is.matrix(constrain) || nrow(constrain) != n || ncol(constrain) != N)
  {
    stop(sprintf("'constrain' must be an n x N matrix (%d x %d: number of samples by number of nodes), with NA indicating unconstrained values.", n, N))
  }
  if (!all(constrain[!is.na(constrain)] %in% responses))
  {
    stop("All non-NA values in 'constrain' must be members of 'responses'.")
  }
  # responses, constrain and delta are passed to C++ as doubles so that
  # non-integer response options (e.g. seq(-1, 1, by = 0.5)) are preserved:
  storage.mode(constrain) <- "double"

  if (method %in% c("MH","CFTP"))
  {
    try <- 1

    repeat{
      Res <- IsingSamplerCpp(as.integer(n), graph, thresholds, beta, as.integer(nIter), as.numeric(responses), as.logical(method == "CFTP"), constrain, as.numeric(delta))

      if (any(is.na(Res)) & method == "CFTP")
      {
        if (try < CFTPretry)
        {
          message("Restarting CFTP chain, attempt: ", try)
          try <- try + 1
        } else
        {
          warning(paste("NA's detected, this means that no CFTP sample was drawn after 100 couplings to the past and",CFTPretry,"resets of the chain. Use higher nIter value or method='MH' for inexact sampling."))
          break
        }
      } else break
    }

    # Preserve integer storage when all responses are integer-valued (keeps the
    # binary / integer behaviour identical to previous versions):
    if (all(responses == round(responses))) storage.mode(Res) <- "integer"
  } else
  {
    Res <- IsingDir(n, graph, thresholds, beta, responses, delta, constrain)
  }

  return(Res)
}

## direct sampling function:
# 'constrain' is an n x N matrix; NA = free, non-NA = clamp that node to that
# value in that sample. Constrained samples are drawn from the conditional
# distribution given the clamped nodes: the full state space is restricted to
# the states matching all non-NA entries of the constraint row and the
# probabilities are renormalized over that subset.
IsingDir <- function(n, graph, thresholds, beta,responses = c(0L,1L), delta = 0, constrain)
{
  if (!is.matrix(graph) || !is.numeric(graph) || nrow(graph) != ncol(graph))
  {
    stop("'graph' must be a numeric square matrix.")
  }
  if (!isSymmetric(graph)) stop("'graph' must be a symmetric matrix.")
  if (length(thresholds) != 1L && length(thresholds) != ncol(graph))
  {
    stop("'thresholds' must have length 1 or the number of nodes (ncol(graph)).")
  }
  checkResponses(responses)
  if (any(diag(graph)!=0))
  {
    diag(graph) <- 0
    warning("Diagonal set to 0")
  }
  N <- nrow(graph)
  if (length(thresholds) == 1L) thresholds <- rep(thresholds, N)
  if (length(delta) == 1L) delta <- rep(delta, N)
  Allstates <- do.call(expand.grid,lapply(1:N,function(x)responses))
  P <- exp(- beta * apply(Allstates,1,function(s)H(graph,s,thresholds,delta)))

  # Unconstrained sampling (also when all entries of 'constrain' are NA):
  if (missing(constrain) || all(is.na(constrain)))
  {
    Res <- Allstates[sample(1:nrow(Allstates),n,TRUE,prob=P), , drop = FALSE]
  } else
  {
    if (!is.matrix(constrain) || nrow(constrain) != n || ncol(constrain) != N)
    {
      stop(sprintf("'constrain' must be an n x N matrix (%d x %d: number of samples by number of nodes), with NA indicating unconstrained values.", n, N))
    }
    if (!all(constrain[!is.na(constrain)] %in% responses))
    {
      stop("All non-NA values in 'constrain' must be members of 'responses'.")
    }

    # Group identical constraint rows so the restricted distribution is computed
    # only once per unique constraint pattern:
    key <- apply(constrain, 1, paste, collapse = "\r")
    stateIndex <- integer(n)
    for (k in unique(key))
    {
      rows <- which(key == k)
      cons <- constrain[rows[1], ]
      fixed <- which(!is.na(cons))
      if (length(fixed) == 0)
      {
        sub <- seq_len(nrow(Allstates))
      } else
      {
        keep <- rep(TRUE, nrow(Allstates))
        for (j in fixed) keep <- keep & (Allstates[[j]] == cons[j])
        sub <- which(keep)
      }
      # Renormalization to the restricted subset happens implicitly in sample():
      stateIndex[rows] <- sub[sample.int(length(sub), length(rows), replace = TRUE, prob = P[sub])]
    }
    Res <- Allstates[stateIndex, , drop = FALSE]
  }

  # Return an unnamed matrix, matching the MH/CFTP methods (which return a
  # matrix from C++). Integer storage is preserved when all responses are
  # integer-valued, mirroring the MH/CFTP branch of IsingSampler():
  Res <- as.matrix(Res)
  dimnames(Res) <- NULL
  if (all(responses == round(responses))) storage.mode(Res) <- "integer"
  return(Res)
}