Littlewood-Richardson

LittlewoodRichardson00.R

insertWith <- function(f, mp, key, value) {
  if(key %in% names(mp)) {
    mp[[key]] <- f(value, mp[[key]])
  } else {
    mp[[key]] <- value
  }
  mp
}

drop <- function(n, x) {
  tail(x, max(length(x) - n, 0L))
}

lrMult <- function(mu, nu) {
  add <- function(old, lambda) {
    insertWith(`+`, old, toString(lambda), 1L)
  }
  Reduce(add, addMu(mu, nu), init = list())
}

addMu <- function(mu, part) {
  go <- function(ubs, mms, dds, part) {
    if(length(mms) == 0L) {
      list(part)
    } else {
      d <- dds[1L]
      ds <- dds[-1L]
      ms <- mms[-1L]
      L <- addRowOf(ubs, part)
      LL <- lapply(L, function(x) {
        ubsprime <- x[[1L]]
        partprime <- x[[2L]]
        go(drop(d, ubsprime), ms, ds, partprime)
      })
      do.call(c, LL)
    }
  }
  ubs0 <- headOrZero(part) + seq_len(headOrZero(mu))
  dmu <- diffSeq(mu)
  go(ubs0, mu, dmu, part)
}

addRowOf <- function(pcols, part) {
  go <- function(lb, ububs, p, ncols) {
    if(length(ububs) == 0L) {
      list(list(rev(ncols), p))
    } else {
      ub <- ububs[1L]
      ubs <- ububs[-1L]
      LL <- lapply(newBoxes(lb + 1L, ub, p), function(ij) {
        col <- ij[2L]
        go(col, ubs, addBox(ij, p), c(col, ncols))
      })
      do.call(c, LL)
    }
  }
  go(0L, pcols, part, integer(0L))
}

newBoxes <- function(lb, ub, part) {
  go <- function(i, jjs, lp) {
    if(length(jjs) == 0L) {
      if(lb <= 1L && 1L <= ub && lp > 0L) {
        list(c(i, 1L))
      } else {
        list()
      }
    } else {
      j <- jjs[1L]
      js <- jjs[-1L]
      j1 <- j + 1L
      if(j1 < lb) {
        list()
      } else if(j1 <= ub && lp > j) {
        c(list(c(i, j1)), go(i + 1L, js, j))
      } else {
        go(i + 1L, js, j)
      }
    }
  }
  rev(go(1L, part, headOrZero(part) + 1L))
}

addBox <- function(kl, part) {
  k <- kl[1L]
  go <- function(i, pps) {
    if(length(pps) == 0L) {
      if(i == k) {
        1L
      } else {
        stop("addBox: shouldn't happen")
      }
    } else {
      p <- pps[1L]
      ps <- pps[-1L]
      if(i == k) {
        c(p + 1L, ps)
      } else {
        c(p, go(i + 1L, ps))
      }
    }
  }
  go(1L, part)
}

headOrZero <- function(xs) {
  if(length(xs) == 0L) {
    0L
  } else {
    xs[1L]
  }
}  

diffSeq <- function(x) {
  diff(-c(x, 0L))
}

##########################################
mu <- c(2L, 1L)
nu <- c(3L, 2L, 1L)
pr <- lrMult(mu, nu) 
library(jack)
s_mu <- SchurPolCPP(4, mu)
s_nu <- SchurPolCPP(4, nu)
smu_times_snu <- s_mu * s_nu

sterms <- lapply(names(pr), function(part) {
  lambda <- as.integer(strsplit(part, ",")[[1L]])
  pr[[part]] * SchurPolCPP(4, lambda)
})
ss <- Reduce(`+`, sterms)
ss == smu_times_snu