piecepackr3d: 3D Board Game Graphics

Documented in write_obj

#' Write Wavefront OBJ files of board game pieces
#'
#' \code{write_obj} creates Wavefront OBJ files (including associated MTL and texture image).
#' @inheritParams piece3d
#' @param filename Name of Wavefront OBJ object.
#' @return A list with named elements "obj", "mtl", "png" with the created filenames.
#' @examples
#'     cfg <- piecepackr::game_systems("dejavu3d")$piecepack
#'     files <- write_obj("tile_face", suit = 3, rank = 3, cfg = cfg)
#'     print(files)
#' @export
write_obj <- function(piece_side = "tile_face", suit = 1, rank = 1, cfg = pp_cfg(),
                         ...,
                         x = 0, y = 0, z = 0,
                         angle = 0, axis_x = 0, axis_y = 0,
                         width = NA, height = NA, depth = NA,
                         filename = tempfile(fileext = ".obj"), scale = 1, res = 72) {

    cfg <- as_pp_cfg(cfg)
    suit <- ifelse(is.na(suit), 1, suit)
    rank <- ifelse(is.na(rank), 1, rank)
    if (is.na(angle)) angle <- 0
    if (is.na(axis_x)) axis_x <- 0
    if (is.na(axis_y)) axis_y <- 0
    if (is.na(width)) width <- cfg$get_width(piece_side, suit, rank)
    if (is.na(height)) height <- cfg$get_height(piece_side, suit, rank)
    if (is.na(depth)) depth <- cfg$get_depth(piece_side, suit, rank)
    if (is.na(z)) z <- 0.5 * depth
    width <- scale * width
    height <- scale * height
    depth <- scale * depth

    if (grepl("tile|coin|saucer|pawn|matchstick|bit|board|card", piece_side)) {
        f <- write_2s_obj
    } else if (piece_side == "pyramid_top") {
        f <- write_pt_obj
    } else {
        stop("Don't know how to draw ", piece_side, " yet with rgl.")
    }
    f(piece_side, suit, rank, cfg,
      x = x, y = y, z = z, angle = angle, axis_x = axis_x, axis_y = axis_y,
      width = width, height = height, depth = depth,
      filename = filename, res = res)
}

write_2s_texture <- function(piece_side = "tile_face", suit = 1, rank = 1, cfg = pp_cfg(),
                             ...,
                             filename = tempfile(fileext = ".png"), res = 72) {
    opt <- cfg$get_piece_opt(piece_side, suit, rank)

    height <- cfg$get_height(piece_side, suit, rank)
    width <- cfg$get_width(piece_side, suit, rank)
    png(filename, height = height, width = 2.5 * width,
        units = "in", res = res, bg = "transparent")

    # front
    pushViewport(viewport(x = 0.2, width = 0.4))
    grid.piece(piece_side, suit, rank, cfg)
    popViewport()

    # edge
    pushViewport(viewport(x = 0.5, width = 0.1))
    grid.rect(gp = gpar(col = "transparent", fill = opt$edge_color))
    popViewport()

    # back
    opp_piece_side <- if (grepl("_face", piece_side)) {
        gsub("face", "back", piece_side)
    } else {
        gsub("back", "face", piece_side)
    }
    pushViewport(viewport(x = 0.8, width = 0.4))
    grid.piece(opp_piece_side, suit, rank, cfg)
    popViewport()
    dev.off()

    invisible(filename)
}

write_mtl <- function(mtl_filename, png_filename) {
    writeLines(c("newmtl material_0", paste("map_Kd", png_filename)),
               mtl_filename)
}

write_2s_obj <- function(piece_side = "tile_face", suit = 1, rank = 1, cfg = pp_cfg(),
                         ...,
                         x = 0, y = 0, z = 0,
                         angle = 0, axis_x = 0, axis_y = 0,
                         width = NA, height = NA, depth = NA,
                         filename = tempfile(fileext = ".obj"), res = 72) {

    cfg <- as_pp_cfg(cfg)

    ext <- tools::file_ext(filename)
    mtl_filename <- gsub(paste0("\\.", ext, "$"), ".mtl", filename)
    png_filename <- gsub(paste0("\\.", ext, "$"), ".png", filename)

    write_2s_texture(piece_side, suit, rank, cfg, filename = png_filename, res = res)
    write_mtl(mtl_filename, basename(png_filename))

    opt <- cfg$get_piece_opt(piece_side, suit, rank)

    # 1st half "top" vertices
    # 2nd half "bottom" vertices
    pc <- piecepackr:::Point3D$new(x, y, z)
    xy_npc <- piecepackr:::Point$new(piecepackr:::get_shape_xy(opt$shape, opt$shape_t, opt$shape_r))
    xy <- xy_npc$npc_to_in(0, 0, 1, 1, angle) #### Support 3D rotation
    xyz_t <- piecepackr:::Point3D$new(xy, z = 0.5)
    xyz_b <- piecepackr:::Point3D$new(xy, z = -0.5)
    xs <- c(xyz_t$x, xyz_b$x)
    ys <- c(xyz_t$y, xyz_b$y)
    zs <- c(xyz_t$z, xyz_b$z)
    xyz <- piecepackr:::Point3D$new(xs, ys, zs)$dilate(width, height, depth)$translate(pc)

    nv <- length(xyz) / 2

    # geometric vertices
    v <- paste("v", xyz$x, xyz$y, xyz$z)
    cat("# Written by piecepackr3d",
        paste("mtllib", basename(mtl_filename)),
        "# geometric vertices", v,
        sep = "\n", file = filename)

    # texture coordinates, nb. obj has y axis in opposite direction
    xy_vt_t <- xy_npc$dilate(width = 0.4)
    xy_vt_b <- xy_npc$dilate(width = 0.4)$translate(x = 0.6)
    xy_vt_e <- list(x = c(0.55, 0.45, 0.45, 0.55), y = c(1, 0, 0, 1))
    vt_t <- paste("vt", xy_vt_t$x, xy_vt_t$y)
    vt_b <- paste("vt", xy_vt_b$x, xy_vt_b$y)
    vt_e <- paste("vt", xy_vt_e$x, xy_vt_e$y)
    cat("# texture coordinates", vt_t, vt_b, vt_e,
        sep = "\n", file = filename, append = TRUE)

    # faces
    f_t <- paste("f", paste0(seq(nv), "/", seq(nv), collapse = " "))
    f_b <- paste("f", paste0(nv + rev(seq(nv)), "/", nv + seq(nv), collapse = " "))
    cat("# Textured polygonal face element", "usemtl material_0", f_t, f_b,
        sep = "\n", file = filename, append = TRUE)
    # sides
    for (ii in seq(nv)) {
        ir <- ii %% nv + 1
        il <- ir %% nv + 1
        cat(paste("f", paste0(c(ir, il, il + nv, ir + nv), "/", 2 * nv + 1:4, collapse = " ")),
            sep = "\n", file = filename, append = TRUE)
    }
    invisible(list(obj = filename, mtl = mtl_filename, png = png_filename))
}

write_pyramid_texture <- function(piece_side = "pyramid_face", suit = 1, rank = 1, cfg = pp_cfg(),
                             ...,
                             filename = tempfile(fileext = ".png"), res = 72) {

    height <- cfg$get_height("pyramid_face", suit, rank)
    width <- cfg$get_width("pyramid_face", suit, rank)

    png(filename, height = height, width = 4 * width,
        units = "in", res = res, bg = "transparent")

    pushViewport(viewport(x = 0.125, width = 0.25))
    grid.piece("pyramid_face", suit, rank, cfg)
    popViewport()

    pushViewport(viewport(x = 0.375, width = 0.25))
    grid.piece("pyramid_left", suit, rank, cfg)
    popViewport()

    pushViewport(viewport(x = 0.625, width = 0.25))
    grid.piece("pyramid_back", suit, rank, cfg)
    popViewport()

    pushViewport(viewport(x = 0.875, width = 0.25))
    grid.piece("pyramid_right", suit, rank, cfg)
    popViewport()
    dev.off()

    invisible(filename)
}

write_pt_obj <- function(piece_side = "pyramid_top", suit = 1, rank = 1, cfg = pp_cfg(),
                         ...,
                         x = 0, y = 0, z = 0,
                         angle = 0, axis_x = 0, axis_y = 0,
                         width = NA, height = NA, depth = NA,
                         filename = tempfile(fileext = ".obj"), res = 72) {

    cfg <- as_pp_cfg(cfg)

    ext <- tools::file_ext(filename)
    mtl_filename <- gsub(paste0("\\.", ext, "$"), ".mtl", filename)
    png_filename <- gsub(paste0("\\.", ext, "$"), ".png", filename)

    write_pyramid_texture(piece_side, suit, rank, cfg, filename = png_filename, res = res)
    write_mtl(mtl_filename, basename(png_filename))

    pc <- piecepackr:::Point3D$new(x, y, z)
    xy_npc <- piecepackr:::Point$new(piecepackr:::rect_xy)
    xy <- xy_npc$npc_to_in(0, 0, 1, 1, angle) #### Support 3D rotation
    xyz_t <- piecepackr:::Point3D$new(x = 0.0, y = 0.0, z = 0.5)
    xyz_b <- piecepackr:::Point3D$new(xy, z = -0.5)
    xs <- c(xyz_t$x, xyz_b$x)
    ys <- c(xyz_t$y, xyz_b$y)
    zs <- c(xyz_t$z, xyz_b$z)
    xyz <- piecepackr:::Point3D$new(xs, ys, zs)$dilate(width, height, depth)$translate(pc)

    # geometric vertices
    v <- paste("v", xyz$x, xyz$y, xyz$z)
    cat("# Written by piecepackr3d",
        paste("mtllib", basename(mtl_filename)),
        "# geometric vertices", v,
        sep = "\n", file = filename)

    # texture coordinates, nb. obj has y axis in opposite direction
    xy_vt <- list(x = seq(0, 1, 0.125), y = rep(c(0, 1), length.out = 9))
    cat("# texture coordinates", paste("vt", xy_vt$x, xy_vt$y),
        sep = "\n", file = filename, append = TRUE)

    cat("# Textured polygonal face element", "usemtl material_0",
        "f 2/3 3/5 1/4", # left
        "f 3/5 4/7 1/6", # back
        "f 4/7 5/9 1/8", # right
        "f 5/1 2/3 1/2", # front
        sep = "\n", file = filename, append = TRUE)

    invisible(list(obj = filename, mtl = mtl_filename, png = png_filename))
}