R/make_infrared_ineqmat.R

In musicMCT: Analyze the Structure of Musical Scales

#' Define hyperplanes for infrared arrangements
#'
#' The "infrared" hyperplane arrangements are in some sense 
#' an extension of the "pastel" arrangements to be more like the
#' Rothenberg arrangements. (This is the sense of the color-conceit
#' name for the arrangements: they contain red-like colors that we 
#' don't see in ordinary use of modal color theory.) That is, the
#' infrared arrangement for a given color contains all the pastel hyperplanes
#' (except those filtered out when `include_wraparound=FALSE`),
#' plus additional ones that make comparisons between generic intervals
#' of different sizes (as the Rothenberg arrangements do). Unlike the
#' Rothenberg arrangements, however, the infrared arrangments are central:
#' every hyperplane passes through the "origin" generated by [edoo()].
#' It should be the case that every infrared hyperplane either belongs
#' to the pastel arrangement or is parallel to one in a Rothenberg arrangement.
#' This family of arrangements is conceived primarily for the study
#' of voice leadings rather than scales themselves.
#'
#' These arrangements are still somewhat experimental and may change.
#' In particular, the ordering of hyperplanes currently is inconsistent
#' between settings for `include_wraparound`.
#'
#' @inheritParams makeineqmat
#' @param include_wraparound Boolean: should hyperplanes that involve
#'   intervals that wrap around the octave be included? Defaults to `TRUE`.
#'
#' @returns A matrix with `card+1` columns and `k` rows (where `k` is the
#'   number of hyperplanes in the arrangement). When `include_wraparound=TRUE`,
#'   `k` is the `card`th [doubly triangular number](https://oeis.org/A002817).
#'
#' @examples
#' # To see the effect of "include_wraparound" param, compare to
#' # pastel arrangements:
#' make_pastel_ineqmat(3)
#' make_infrared_ineqmat(3)
#' make_infrared_ineqmat(3, include_wraparound=FALSE)
#'
#' # In general, infrared arrangements are more complicated than pastel:
#' make_pastel_ineqmat(4)
#' make_infrared_ineqmat(4, include_wraparound=TRUE)
#'
#' @seealso [make_pastel_ineqmat()] and [make_roth_ineqmat()]
#'
#' @export
make_infrared_ineqmat <- function(card, include_wraparound=TRUE) {
  if (card < 3) {
    return(make_white_ineqmat(1+include_wraparound))
  }

  normalize_by_last_entry <- function(input_row) {
    last_entry <- input_row[length(input_row)]  
    -1 * (input_row / last_entry)
  }

  infrared_row <- function(firstroot, secondroot, g1, g2) {
    row <- rep(0, card+1)
    firstroot <- quasimod(firstroot+1, card=card)
    secondroot <- quasimod(secondroot+1, card=card)

    fr_target <- quasimod(firstroot + g1, card=card)
    sr_target <- quasimod(secondroot + g2, card=card)

    firstroot_indices <- c(firstroot, fr_target)
    secondroot_indices <- c(secondroot, sr_target)

    firstroot_vec <- c(-1, 1)
    secondroot_vec <- -1 * firstroot_vec

    if (fr_target < firstroot) {
      firstroot_indices <- c(firstroot_indices, card+1)
      firstroot_vec <- c(firstroot_vec, 1)
    }

    if (sr_target < secondroot) {
      secondroot_indices <- c(secondroot_indices, card+1)
      secondroot_vec <- c(secondroot_vec, -1)
    }

    temprow_small_side <- row
    temprow_large_side <- row
   
    temprow_small_side[firstroot_indices] <- firstroot_vec
    temprow_large_side[secondroot_indices] <- secondroot_vec
    
    row <- temprow_small_side + temprow_large_side
    is_wraparound <- row[card+1] != 0

    generic_difference <- g2 - g1
    generic_offset <- (1/card) * generic_difference
    row[card+1] <- row[card+1] + generic_offset

    res <- normalize_by_last_entry(row)
    if (!include_wraparound) res <- c(res, is_wraparound)

    res
  }

  roots <- 0:(card-1)
  intervals <- 1:(card-1)
  combinations <- expand.grid(roots, roots, intervals, intervals)
  combinations <- combinations[combinations[, 3] < combinations[, 4], ]

  firstroots <- combinations[, 1]
  secondroots <- combinations[, 2]
  g1s <- combinations[, 3]
  g2s <- combinations[, 4]

  res <- t(mapply(infrared_row, firstroot=firstroots, secondroot=secondroots, g1=g1s, g2=g2s))
  pastel_ineqmat <- make_pastel_ineqmat(card)

  if (!include_wraparound) {
    wraparounds <- which(res[, card+2]==1)

    res <- res[-wraparounds, ]
    res <- res[, 1:(card+1)]

    num_colorful_ineqs <- dim(getineqmat(card))[1]
    colorful_ineqmat <- pastel_ineqmat[1:num_colorful_ineqs, ]
    colorful_wraparounds <- which(colorful_ineqmat[, card+1] != 0)
    pastel_ineqmat <- pastel_ineqmat[-colorful_wraparounds, ]
  }

  possible_duplicates <- rbind(pastel_ineqmat, res)
  possible_duplicates <- round(possible_duplicates, digits=11)
  are_duplicated <- which(duplicated(possible_duplicates, MARGIN=1)==TRUE)
  are_duplicated <- are_duplicated - dim(pastel_ineqmat)[1]

  res <- res[-are_duplicated, ]

  rbind(pastel_ineqmat, res)
}