R/vlsig.R

In musicMCT: Analyze the Structure of Musical Scales

#' Which transpositions give elementary voice leadings?
#'
#' Just as the transpositions of the diatonic scale can be generated by
#' Hook's (2008, \doi{doi:10.1515/9781580467476-008}) elementary
#' "signature transformation," the transpositional voice leadings of any
#' set can generally be decomposed into a small number of basic motions.
#' These motions correspond to the arrows in a set's [brightnessgraph()].
#' (The qualifier "generally" is needed because of certain problematic edge
#' cases, such as the perfectly even scales of [edoo()] whose minimal voice
#' leadings always involve entirely parallel motion, which cannot be 
#' derived from "mode shift" voice leadings represented on a brightness graph.)
#' `vl_generators()` identifies these basic voice-leading motions.
#'
#' @inheritParams tnprime
#' @inheritParams minimize_vl
#'
#' @returns 2-by-m matrix whose m columns represent the m distinct voice-leading
#'   generators. The top row indicates the generic size of each interval; the 
#'   bottom row indicates the specific size. Results are sorted so that the first
#'   row (generic intervals) is strictly increasing.
#'
#' @examples
#' diatonic_scale <- c(0, 2, 4, 5, 7, 9, 11)
#' melodic_minor <- c(0, 2, 3, 5, 7, 9, 11)
#' vl_generators(diatonic_scale)
#' vl_generators(melodic_minor)
#' vl_generators(j(dia))
#'
#' maj7 <- c(0, 4, 7, 11)
#' vl_generators(maj7)
#'
#' @export
vl_generators <- function(set, edo=12, rounder=10) {
  tiny <- 10^(-1 * rounder)
  card <- length(set)

  if (evenness(set, edo=edo) < tiny) {
    warning("Perfectly even scales have no voice-leading generators")
    return(matrix(c(numeric(0), numeric(0)), nrow=2))
  }

  scalar_interval_matrix <- sim(set, edo=edo)

  reduced_comparisons <- bg_reduction(set=set, edo=edo, rounder=rounder)
  arrows_in_graph  <- which(reduced_comparisons==1, arr.ind=TRUE)
  from_which_mode <- arrows_in_graph[,1]
  generic_intervals <- (arrows_in_graph[,2] - from_which_mode) %% card
  generic_intervals <- (-1*generic_intervals) %% card

  gen_iv_internal <- generic_intervals + 1  
  get_largest_specific <- function(generic_size) max(scalar_interval_matrix[generic_size, ])
  specific_intervals <- sapply(gen_iv_internal, get_largest_specific)

  res <- rbind(generic_intervals, specific_intervals)
  res <- fpunique(res, MARGIN=2, rounder=rounder)
  res <- insist_matrix(res)

  res <- res[,order(res[1,])]
  insist_matrix(res)
}

#' Elementary voice leadings
#'
#' Calculate elementary voice leadings which represent motion by a single
#' arrow on a [brightnessgraph()]. `vlsig()` finds "**v**oice-**l**eading **sig**nature" 
#' of a set moving to transpositions of itself, as determined by [vl_generators()]. `inter_vlsig()`
#' finds the elementary voice leadings from a set to some other set, i.e. where the `goal`
#' parameter of [brightnessgraph()] is not `NULL`. By default, `inter_vlsig()` finds
#' voice leadings for contextual inversions of a set.
#'
#' Note that the voice leadings determined by `vlsig()` can be different from the
#' corresponding ones at the same \eqn{T_n} level in [vl_rolodex()]. The latter function
#' prioritizes minimal voice leadings, whereas `vlsig()` prioritizes *elementary* voice
#' leadings derived from a set's [brightnessgraph()]. In particular, this means that
#' `vlsig()` voice leadings will always be ascending, involve at least one common tone,
#' and involve no contrary motion. See the `odd_pentachord` voice leadings in the Examples.
#'
#' For `vlsig()` the value "rotation" in the result is non-arbitrary: if the rotation value
#' is n, the voice leading takes `set` to the nth mode of `set`. For `inter_vlsig()`, there
#' is no canonical correspondence between modes of `set` and `goal`, except to assume that
#' the input modes are the 1st mode of each scale. If `goal` is `NULL`, finding contextual
#' inversions of `set`, the first mode of the inversion is taken to be the one that holds the 
#' first and last pitches of `set` in common. These "rotation" values do not have a transparent 
#' relationship to the values of `inter_vlsig()`'s index parameter.
#'
#' For `inter_vlsig()` results are not as symmetric between `set` and `goal` as you might
#' expect. Since these voice-leading functions study ascending arrows on a brightness graph
#' the possibilities for *ascending from X to Y* are in principle somewhat different from
#' the possibilities for *ascending from Y to X*. See the examples for the "Tristan genus."
#' Note that this is still true when `type="commontone"`, which might lead to counterintuitive
#' results.
#' 
#'
#' @inheritParams vl_generators
#' @inheritParams ifunc
#' @param index Integer: which voice-leading generator should be displayed? Defaults to `NULL`, 
#'   displaying all voice leadings.
#' @param goal For `inter_vlsig()` only, vector of the transposition type to voice lead to.
#'   Defaults to `NULL`, producing voice leadings to the inversion of `set`.
#' @param type For `inter_vlsig()` only. String: "ascending", "commontone", or "obverse".
#'   Defaults to "ascending", which makes the result prefer ascending voice leadings (as for `vlsig()`).
#'   The second makes the result prefer common tones (as might be expected for 
#'   contextual inversions). The third option, "obverse", gives the obverse of a voice-leading
#'   in a sense that generalizes Morris (1998, \doi{doi:10.2307/746047})'s concept for 
#'   Neo-Riemannian PLR transformations. This option returns voice leadings that lead *to* `set` rather
#'   than away from it.
#'
#' @returns List with three elements:
#'   * "vl" which shows the distance (in `edo` steps) that each voice moves,
#'   * "tn" which indicates the (chromatic) transposition achieved by the voice leading,
#'   * "rotation" which indicates the scalar transposition caused by the voice leading.
#'  
#'  If `index=NULL`, returns instead a matrix whose rows are
#'  all the elementary voice leadings.
#'
#' @seealso [vl_generators()] and [brightnessgraph()]
#'
#' @examples
#' # Hook's elementary signature transformation
#' major_scale <- c(0, 2, 4, 5, 7, 9, 11)
#' vlsig(major_scale, index=1)
#'
#' pure_major_triad <- j(1, 3, 5)
#' vlsig(pure_major_triad, index=1)
#' vlsig(pure_major_triad, index=2)
#'
#' odd_pentachord <- c(0, 1, 4, 9, 11) # in 15-edo
#' vlsig(odd_pentachord, index=2, edo=15)
#' vl_rolodex(odd_pentachord, edo=15)$"8" 
#'
#' # Contextual inversions for Tristan genus:
#' dom7 <- c(0, 4, 7, 10)
#' halfdim7 <- c(0, 3, 6, 10)
#' inter_vlsig(dom7, halfdim7)
#' inter_vlsig(halfdim7, dom7)
#'
#' # Elementary voice leadings between unrelated sets:
#' maj7 <- c(0, 4, 7, 11)
#' min7 <- c(0, 3, 7, 10)
#' inter_vlsig(min7, maj7)
#' brightnessgraph(min7, maj7)
#'
#' # Elementary inversional VL for just diatonic which is NOT a Q-relation:
#' inter_vlsig(j(dia), index=3)
#'
#' # Obverse voice leadings:
#' # First we see the Parallel transformation which leads from minor to major:
#' minor <- c(0, 3, 7)
#' P <- inter_vlsig(minor, index=1)
#' print(P)
#' # Compare to its obverse, Slide, leading *to* minor from major:
#' S <- inter_vlsig(minor, index=1, type="obverse")
#' print(S)
#' # A voice-leading plus its obverse is a chromatic transposition:
#' P$vl + S$vl
#'
#' @export
vlsig <- function(set, index=NULL, display_digits=2, edo=12, rounder=10) {
  null_index <- is.null(index)
  if (index < 1 && !null_index) {
    stop("Index must be positive!")
  }

  card <- length(set)
  tn_levels <- vl_generators(set, edo=edo, rounder=rounder)
  rownames(tn_levels) <- NULL

  if (index > dim(tn_levels)[2] && !null_index) {
    stop(paste0(deparse(substitute(set)), " doesn't have that many VL generators!"))
  }

  if (null_index) {
    num_generators <- dim(tn_levels)[2]
    get_a_vl <- function(i) vlsig(set=set, index=i, display_digits=display_digits, edo=edo, rounder=rounder)$vl
    all_vls <- sapply(1:num_generators, get_a_vl)
    final_result <- t(all_vls)
  } else {
    chosen_tn_level <- tn_levels[2, index]
    chosen_generic_interval <- tn_levels[1, index]
    modes <- sim(set, edo=edo)

    goal_set <- rotate(set, -chosen_generic_interval) 
    goal_set[1:chosen_generic_interval] <- goal_set[1:chosen_generic_interval] - edo
    goal_set <- goal_set + chosen_tn_level

    res <- goal_set - set
    res <- round(res, display_digits)

    final_result <- list(vl=res, tn=chosen_tn_level, rotation=chosen_generic_interval)
  } 

  final_result
}


#' @rdname vlsig
#' @export
inter_vlsig <- function(set, 
                        goal=NULL, 
                        index=NULL, 
                        type=c("ascending", "commontone", "obverse"),
                        display_digits=2, 
                        edo=12, 
                        rounder=10) {
  card <- length(set)
  use_commontone <- match.arg(type) == "commontone"
  use_obverse <- match.arg(type) == "obverse"

  if (!is.null(goal) && length(goal) != card) {
    stop("Goal must have same length as set.")
  }

  if (is.null(goal)) {
    goal <- tni(set, set[card], edo=edo, rounder=rounder)
  } else {
    index <- NULL
  }

  arrows <- bg_reduction(set=set, goal=goal, edo=edo, rounder=rounder)
  upper_right_quadrant <- arrows[1:card, (card+1):(2*card)]

  modes <- sim(set, edo=edo, rounder=rounder)
  interscalar <- sim(set, goal, edo=edo, rounder=rounder)
  interscalar <- apply(interscalar, 2, startzero, optic="", edo=edo, rounder=rounder)

  arrow_indices <- which(upper_right_quadrant==1, arr.ind=TRUE)

  vl_from_arrow <- function(vec) rotate(interscalar[, vec[2]] - modes[, vec[1]], 1-vec[1])
  vls <- apply(arrow_indices, 1, vl_from_arrow)

  rounded_vls <- t(round(vls, digits=rounder))

  effective_card <- card / tsym_degree(set, edo=edo, rounder=rounder)
  all_rotations <- (arrow_indices[, 1] - arrow_indices[, 2]) %% effective_card
  rounded_vls <- rounded_vls[order(all_rotations), ]

  vls <- t(fpunique(vls, MARGIN=2))

  unique_rotations <- unique(all_rotations)
  vls <- vls[order(unique_rotations), ]
  if (!inherits(vls, "matrix")) vls <- t(vls)

  unique_vls <- which(duplicated(rounded_vls, MARGIN=1)==FALSE)

  if (use_commontone) {
    tiny <- 10^(-1 * rounder)
    fp_eq <- function(x, y) abs(x-y) < tiny
    modal_element <- function(vec) {
      equivalences <- outer(vec, vec, fp_eq)  
      match_count <- rowSums(equivalences)
      most_matches <- max(match_count)
      highly_matching <- which(match_count == most_matches)
      highly_matching <- vec[highly_matching]
      min(highly_matching)
    }

    tincture <- function(vl) vl - modal_element(vl)
    vls <- t(apply(vls, 1, tincture)) 
  }

  if (use_obverse) {
    make_obverse <- function(vec) {
      largest_chroma <- max(vec)
      res <- -1 * vec
      res + largest_chroma
    }
    
    vls <- t(apply(vls, 1, make_obverse))
    vls <- as.list(as.data.frame(t(vls)))
    vls <- mapply(rotate, x=vls, n=sort(unique_rotations))
    vls <- t(vls)
    dimnames(vls) <- NULL
  }

  if (is.null(index)) {
    return(round(vls, display_digits))
  }

  chosen_vl <- vls[index, ]
  if (use_obverse) {
    chosen_goal <- set - rotate(chosen_vl, -1*sort(unique_rotations)[index])
  } else {
    chosen_goal <- set + chosen_vl
  }

  goal_modes <- sapply(0:(card-1), rotate, x=chosen_goal)
  goal_sums <- (goal_modes + rev(set)) %% edo
  sum_spread <- abs(apply(goal_sums, 2, max) - apply(goal_sums, 2, min))
  tni_index <- goal_sums[1, which.min(sum_spread)]

  rotation_index <- sort(unique_rotations)[index]
  if (use_obverse) {
    rotation_index <- (-1 * rotation_index) %% card
  }

  rounded_vl <- round(vls[index, ], display_digits)
  res <- list(vl=rounded_vl, tni=tni_index, rotation=rotation_index)
  res
}


#' Which voice leadings are irreducible?
#'
#' Often, the elementary voice leadings of a set (given by [vlsig()]) can be broken
#' into two intermediate voice leadings through a different set (i.e. ones given by
#' [inter_vlsig()] with some suitable choice of `goal`). A classic example is the voice
#' leading (0, 1, 2) that takes C major (C, E, G) to F major (C, F, A). This voice leading
#' is elementary for major triads, but it can be decomposed into the succession of Neo-Riemannian
#' voice leadings R-then-L by passing through a minor triad. Such decompositions are not always
#' possible, though: given a choice of `set` and `goal` classes, sometimes the elementary path
#' from one mode of `set` to another does not pass through any mode of `goal`. Such a voice 
#' leading is "monochrome" in the sense that it uses the restricted palette of the modes of a single
#' `set`.
#'
#' @param goal Vector of the transposition type to voice lead to. 
#'   Defaults to `NULL`, producing voice leadings to the inversion of `set`.
#' @inheritParams inter_vlsig
#' @param bool Should the result be a Boolean `TRUE`/`FALSE` value? Defaults to `FALSE`.
#'
#' @returns If `bool=FALSE`, a voice-leading matrix formatted after `inter_vlsig()`. If `bool=TRUE`,
#'   a single Boolean value indicating whether any monochrome voice leadings exist for `set` and 
#'   `goal`.
#'
#' @examples
#' maj7 <- c(0, 4, 7, 11)
#' mM7 <- c(0, 3, 7, 11)
#'
#' # Just a few basic transformations lead between these seventh chords:
#' inter_vlsig(maj7, mM7)
#' inter_vlsig(mM7, maj7)
#'
#' # But we can see from their brightness graph that modes III and I of maj7
#' # have no intermediate voice leading that involves the minor-major seventh:
#' brightnessgraph(maj7, mM7)
#'
#' # monochrome_vl detects this voice leading:
#' monochrome_vl(maj7, mM7)
#'
#' # Note that the equivalent does not apply to the minor-major seventh, which always
#' # has some mode of the major 7th chord decomposing its elementary voice leadings:
#' monochrome_vl(mM7, maj7)
#'
#' # Finally, note that the presence of monochrome voice leadings is dependent on 
#' # the pair of chord types you choose, not simply the "set." For instance, we can 
#' # define a chord that will decompose the voice leading from mode III to mode I 
#' # of the major 7th:
#' dom7 <- c(0, 4, 7, 10)
#' monochrome_vl(maj7, dom7)
#' brightnessgraph(maj7, dom7)
#' 
#' @export
monochrome_vl <- function(set, goal=NULL, bool=FALSE, display_digits=2, edo=12, rounder=10) {
  card <- length(set)

  if (!is.null(goal) && length(goal) != card) {
    stop("Goal must have same length as set.")
  }

  if (is.null(goal)) {
    goal <- tni(set, set[card], edo=edo, rounder=rounder)
  }

  modes <- sim(set, edo=edo, rounder=rounder)
  arrows <- bg_reduction(set=set, goal=goal, edo=edo, rounder=rounder)
  upper_left_quadrant <- arrows[1:card, 1:card]

  monochrome_index <- which(upper_left_quadrant != 0, arr.ind=TRUE)

  if (length(monochrome_index) == 0) {
    vls <- matrix(integer(0), nrow=0, ncol=card)
  } else {

    vl_from_arrow <- function(vec) rotate(modes[, vec[2]] - modes[, vec[1]], 1-vec[1])
    vls <- apply(monochrome_index, 1, vl_from_arrow)

    rounded_vls <- t(round(vls, digits=rounder))
    effective_card <- card / tsym_degree(set, edo=edo, rounder=rounder)
    all_rotations <- (monochrome_index[, 1] - monochrome_index[, 2]) %% effective_card
    rounded_vls <- rounded_vls[order(all_rotations), ]
    unique_rotations <- unique(all_rotations)

    vls <- t(fpunique(vls, MARGIN=2))
    vls <- vls[order(unique_rotations), ]
    if (!inherits(vls, "matrix")) vls <- t(vls)
  }

  if (bool) {
    as.logical(length(vls))
  } else {
    round(vls, display_digits)
  }
}