R/pattern_weave.R

In gridpattern: 'grid' Pattern Grobs

#' Weave pattern matrix
#'
#' `pattern_weave()` returns a logical matrix indicating where the warp lines should
#'  be "up" for a specified weave pattern type and subtype.
#' `names_weave` is a character vector listing supported weave pattern types.
#'
#' Here is a list of the various weave `type`s supported:
#'
#' \describe{
#' \item{basket}{A simple criss-cross pattern using two threads at a time.
#'              Same as the "matt_irregular" weave but with a default `subtype` of `2L`.}
#' \item{matt}{A simple criss-cross pattern using 3 (or more) threads at a time.
#'             Same as the "matt_irregular" weave but with a default `subtype` of `3L`.}
#' \item{matt_irregular}{A generalization of the "plain" weave.
#'                       A character `subtype` `"U/D(L+R)"` is a standard matt weave specification:
#'                       `U` indicates number warp up, `D` indicates number warp down,
#'                       `L` indicates number of warp up in repeat, and
#'                       `R` indicates number of warp down in repeat.
#'                       An integer `subtype` `N` will be interpreted as a `"N/N(N+N)"` irregular matt weave.
#'                       A character `subtype` `"U/D"` will be interpreted as a `"U/D(U+D)"` irregular matt weave.
#'                       Has a default `subtype` of `"3/2(4+2)"`.}
#' \item{plain}{A simple criss-cross pattern.
#'              Same as the "matt_irregular" weave but with a default `subtype` of `1L`.}
#' \item{rib_warp}{A plain weave variation that emphasizes vertical lines.
#'                 An integer `subtype` `N` will be interpreted as a "matt_irregular" `"N/N(1+1)"` weave.
#'                 A character `subtype` `"U/D"` will be interpreted as a "matt_irregular" `"U/D(1+1)"` weave.
#'                 Default `subtype` of `2L`.}
#' \item{satin}{A "regular" satin weave is a special type of the elongated twill weave
#'              with a move number carefully chosen so no twill line is distinguishable.
#'              Same as the "twill_elongated" weave but with a default `subtype` of `5L`.}
#' \item{twill}{A simple diagonal pattern.
#'              Same as the "twill_elongated" weave but with a default `subtype` of `"2/1"`.}
#' \item{twill_elongated}{A generalization of the "twill" weave.
#'                        A character `subtype` `"U/D(M)"` is a standard twill weave specification:
#'                        `U` indicates number warp up, `D` indicates number warp down,
#'                        and `M` indicates the "move" number.
#'                        A character `subtype` `"U/D"` will be interpreted as a `"U/D(1)"` elongated twill weave.
#'                        An integer `subtype` `N` will provide a `"{N-1}/1(1)"` elongated twill weave
#'                        if `N` is less than 5, 6, or greater than 14 otherwise it will
#'                        provide a `"{N-1}/1(M)"` weave where `M` is the largest
#'                        possible regular "satin" move number.
#'                        Default `subtype` of `"4/3(2)"`.}
#' \item{twill_herringbone}{Adds a (vertical) "herringbone" effect to
#'                          the specified "twill_elongated" weave.
#'                          Default `subtype` of `"4/3(2)"`.}
#' \item{twill_zigzag}{Adds a (vertical) "zig-zag" effect to the specified "twill_elongated" weave.
#'                     Default `subtype` of `"4/3(2)"`.}
#' }
#' For both "matt" and "twill" weaves the `U/D` part of the subtype can be further extended
#' to `U1/D1*U2/D2`, `U1/D1*U2/D2*U3/D3`, etc.
#' For the "matt" weave the "(L+R)" part of the subtype can be further extended
#' to `(L1+R1+L2+R2)`, `(L1+R1+L2+R2+L3+R3)`, etc.
#'
#' @param type Type of weave.  See Details.
#' @param subtype Subtype of weave.  See Details.
#' @param nrow Number of rows (length of warp).
#' @param ncol Number of columns (length of weft).
#' @return A matrix of logical values indicating where the "warp"
#'         is "up" (if `TRUE`) or "down" (if `FALSE`).
#'         Indices `[1,1]` of the matrix corresponds to the bottom-left of the weave
#'         while indices `[1,ncol]` corresponds to the bottom-right of the weave.
#'         This matrix has a "pattern_weave" subclass which supports a special `print()` method.
#' @examples
#'  # supported weave names
#'  print(names_weave)
#'
#'  plain <- pattern_weave("plain", nrow = 7, ncol = 9)
#'  print(plain)
#'
#'  matt_irregular <- pattern_weave("matt_irregular", nrow = 9, ncol = 11)
#'  print(matt_irregular)
#'
#'  satin <- pattern_weave("satin", nrow = 9, ncol = 11)
#'  print(satin)
#'
#'  twill <- pattern_weave("twill", nrow = 9, ncol = 11)
#'  print(twill)
#'
#'  twill_zigzag <- pattern_weave("twill_zigzag", nrow = 18, ncol = 11)
#'  print(twill_zigzag)
#'
#' @seealso [grid.pattern_weave()] for drawing weaves onto a graphics device.
#'          See \url{https://textilestudycenter.com/derivatives-of-plain-weave/}
#'          for further information on the "matt" family of weaves,
#'          \url{https://textilelearner.net/twill-weave-features-classification-derivatives-and-uses/}
#'          for further information on the "twill" family of weaves, and
#'          \url{https://texwiz101.blogspot.com/2012/03/features-and-classification-of-satin.html}
#'          for further information on "satin" weaves.
#' @export
pattern_weave <- function(type = "plain", subtype = NULL, nrow = 5L, ncol = 5L) {
    spec <- get_weave_spec(type, subtype)

    if (is_twill(type))
        m <- pattern_weave_twill(spec, nrow, ncol)
    else
        m <- pattern_weave_matt(spec, nrow, ncol)
    class(m) <- c("pattern_weave", "matrix", "array")
    m
}

# rep_each(1:2, 1:4) -> c(1, 2,2, 1,1,1, 2,2,2,2)
rep_each <- function(x, each) {
    n <- max(lengths(list(x, each)))
    x <- rep_len(x, n)
    each <- rep_len(each, n)
    unlist(lapply(seq.int(n), function(i) rep_len(x[i], each[i])))
}

pattern_weave_matt <- function(spec, nrow, ncol) {
    m <- matrix(FALSE, nrow = nrow, ncol = ncol)
    v <- rep_each(c(TRUE, FALSE), spec$up_down)
    v <- rep_len(v, nrow)
    not_v <- !v
    repeat_up_down <- rep_each(c(TRUE, FALSE), spec$up_down_reps)
    repeat_up_down <- rep_len(repeat_up_down, ncol)
    for (j in seq.int(ncol)) {
        if (repeat_up_down[j])
            m[, j] <- v
        else
            m[, j] <- not_v
    }
    m
}

pattern_weave_twill <- function(spec, nrow, ncol) {
    m <- matrix(FALSE, nrow = nrow, ncol = ncol)
    skip <- 0L
    v0 <- rep_each(c(TRUE, FALSE), spec$up_down)
    for (j in seq_len(ncol)) {
        v <- cycle_elements(v0, -skip)
        if (spec$zigzag)
            v <- add_zigzag(v)
        if (spec$herringbone)
            v <- add_herringbone(v)
        v <- rep_len(v, nrow)
        m[, j] <- v
        skip <- skip + spec$move
    }
    m
}

#' @export
print.pattern_weave <- function(x, ...) {
    indices_x <- which(x)
    indices_o <- which(!x)
    x[indices_x] <- "X"
    x[indices_o] <- " "
    cat("/", rep_len("-", ncol(x)), "\\", "\n")
    for (i in rev(seq_len(nrow(x)))) {
        cat("|", x[i, ], "|", "\n")
    }
    cat("\\", rep_len("-", ncol(x)), "/", "\n")
    invisible(NULL)
}

#' @rdname pattern_weave
#' @export
names_weave <- c("basket",
                 "matt",
                 "matt_irregular",
                 "plain",
                 "rib_warp",
                 "satin",
                 "twill",
                 "twill_elongated",
                 "twill_herringbone",
                 "twill_zigzag")

get_weave_spec <- function(type = "plain", subtype = NULL) {
    if (!is.null(subtype) && is.na(subtype)) subtype <- NULL
    switch(type,
           # cases of irregular matt weave
           basket = get_weave_spec_matt(subtype %||% 2L),
           plain = get_weave_spec_matt(subtype %||% 1L),
           matt = get_weave_spec_matt(subtype %||% 3L),
           matt_irregular = get_weave_spec_matt(subtype %||% "3/2(4+2)"),
           rib_warp = get_weave_spec_matt(subtype %||% 2L,
                                          warp = TRUE),

           # cases of elongated twill weave
           satin = get_weave_spec_twill(subtype %||% 5L),
           twill = get_weave_spec_twill(subtype %||% "2/1"),
           twill_elongated = get_weave_spec_twill(subtype %||% "4/3(2)"),
           twill_zigzag = get_weave_spec_twill(subtype %||% "4/3(2)",
                                               zigzag = TRUE),
           twill_herringbone = get_weave_spec_twill(subtype %||% "4/3(2)",
                                                    herringbone = TRUE),

           abort(paste("Don't know weave type", type)))
}

is_twill <- function(type) grepl("^twill|^satin", type)

# elongated twill U/D(M)
# U = number warp up, D = number warp down, M = move number
get_weave_spec_twill <- function(subtype = "2/1(2)", zigzag = FALSE, herringbone = FALSE) {
    if (is_integer(subtype))
        subtype <- n_to_twill(subtype)
    if (is_ud(subtype))
        subtype <- ud_to_twill(subtype)

    up_down <- get_ud(subtype)
    move <- get_extra(subtype)
    list(up_down = up_down, move = move, herringbone = herringbone, zigzag = zigzag)
}

# irregular matt U/D(L+R)
# U = number warp up, D = number warp down,
# L = number of warp up in repeat,  R = number of warp down in repeat
get_weave_spec_matt <- function(subtype = "3/3(4+2)", warp = FALSE) {
    if (is_integer(subtype))
        subtype <- n_to_matt(subtype, warp = warp)
    if (is_ud(subtype))
        subtype <- ud_to_matt(subtype, warp = warp)

    up_down <- get_ud(subtype)
    reps <- get_extra(subtype)
    list(up_down = up_down, up_down_reps = reps)
}

n_to_matt <- function(n = 1L, warp = FALSE) {
    n <- as.integer(n)
    if (warp)
        glue("{n}/{n}(1+1)")
    else
        glue("{n}/{n}({n}+{n})")
}
ud_to_matt <- function(ud = "2/1", warp = FALSE) {
    v_ud <- get_ud(ud)
    if (warp)
        glue("{ud}(1+1)")
    else
        glue("{ud}({paste(v_ud, collapse='+')})")
}

# satin is special case of twill elongated
# legal satin move is not one, repeat number, repeat number minus one, (multiple of) a factor of repeat number
# legal: 5:2 | 7:2,3 | 8:3 | 9:2,4 | 10:3 | 11:2,3,4,5 | 12:5 | 13: 2,3,4,5,6 | 14:3,5
n_to_twill <- function(n = 1L) {
    n <- as.integer(n)
    if (n < 5L) {
        move <- 1L
    } else {
        move <- switch(as.character(n),
                       "5" = 2L,
                       "6" = 1L, # no legal satin move
                       "7" = 3L,
                       "8" = 3L,
                       "9" = 4L,
                       "10" = 3L,
                       "11" = 5L,
                       "12" = 5L,
                       "13" = 6L,
                       "14" = 5L,
                       n - 1L)
    }
    glue("{n-1}/1({move})")
}

ud_to_twill <- function(ud = "2/1") {
    glue("{ud}(1)")
}

is_integer <- function(s) is.integer(s) || grepl("^[[:digit:]]+$", s)

# "5/1" -> TRUE ; "5" -> FALSE ; "5/1(3)" -> FALSE ; "5/1(4+2)" -> FALSE
is_ud <- function(ud) grepl("^[[:digit:]]+/[[:digit:]]+(\\*[[:digit:]]+/[[:digit:]]+)*$", ud)

# "5/1(4+2)" -> c(5L, 1L) or "5/1(3)" -> c(5L, 1L)
get_ud <- function(ude) {
    ud <- as.integer(strsplit(gsub("\\(.*", "", ude), "/|\\*")[[1]])
    stopifnot(length(ud) %% 2L == 0L)
    ud
}

# "5/1(4+2)" -> c(4L, 2L) or "5/1(3)" -> c(3L)
get_extra <- function(ude) as.integer(strsplit(gsub("[[:digit:]/*]+\\((.*)\\)", "\\1", ude), "\\+")[[1]])

add_zigzag <- function(x) {
    n <- length(x)
    c(x, rev(x[-n]), x[n])
}

add_herringbone <- function(x) c(x, !rev(x))