add_cfg <- function(df, cfg=pp_cfg(), envir=NULL) {
df <- tibble::as_tibble(df)
if (hasName(df, "cfg")) {
df$cfg <- lapply(df$cfg, get_cfg, envir)
} else {
df$cfg <- rep(c(get_cfg(cfg, envir)), length.out=nrow(df))
}
df
}
add_field <- function(df, key, value) {
if (hasName(df, key)) {
df[[key]] <- ifelse(is.na(df[[key]]), value, df[[key]])
} else {
df[[key]] <- value
}
df
}
add_measurements <- function(df) {
df <- add_field(df, "width", an_pmap(df, gwh))
df <- add_field(df, "height", an_pmap(df, ghh))
df <- add_field(df, "depth", an_pmap(df, gdh))
df <- add_field(df, "angle", 0)
df
}
an_pmap <- function(...) as.numeric(purrr::pmap(...))
gwh <- function(piece_side, cfg, ..., suit=1, rank=1) cfg$get_width(piece_side, suit, rank)
ghh <- function(piece_side, cfg, ..., suit=1, rank=1) cfg$get_height(piece_side, suit, rank)
gdh <- function(piece_side, cfg, ..., suit=1, rank=1) cfg$get_depth(piece_side, suit, rank)
#' Oblique projection helper function
#'
#' Guesses \code{z} coordinates and
#' sorting order to more easily
#' make 3D graphics with \code{pmap_piece}.
#'
#' The heuristics used to generate guesses
#' for \code{z} coordinates and sorting order
#' aren't guaranteed to work in every case.
#' In some cases you may get better sorting results
#' by changing the \code{op_angle} or the dimensions of pieces.
#' @seealso \url{https://trevorldavis.com/piecepackr/3d-projections.html} for more details
#' and examples of oblique projections in \code{piecepackr}.
#' @param df A data frame with coordinates and dimensions in inches
#' @param ... Ignored
#' @param cfg Piecepack configuration list or \code{pp_cfg} object,
#' a list of \code{pp_cfg} objects,
#' or a character vector of \code{pp_cfg} objects
#' @param envir Environment (or named list) containing configuration list(s).
#' @param op_angle Intended oblique projection angle (used for re-sorting)
#' @param pt_thickness Thickness of pyramid tip i.e. value to add to the z-value of a pyramid top
#' if it is a (weakly) smaller ranked pyramid (top)
#' placed on top of a larger ranked pyramid (top).
#' @param as_top Character vector of components whose \dQuote{side}
#' should be converted to \dQuote{top} e.g. \code{c("pawn_face")}.
#' @param cfg_class Either `"list"` (default) or `"character"`.
#' Desired class of the `cfg` column in the returned tibble.
#' `"list"` is more efficient for use with `pmap_piece()` but
#' `geom_piece()` needs `"character"`.
#' @return A tibble with extra columns added
#' and re-sorted rows
#' @examples
#' df <- tibble::tibble(piece_side="tile_back",
#' x=c(2,2,2,4,6,6,4,2,5),
#' y=c(4,4,4,4,4,2,2,2,3))
#' cfg <- game_systems()$piecepack
#' pmap_piece(df, op_angle=135, trans=op_transform,
#' op_scale=0.5, default.units="in", cfg=cfg)
#' @export
op_transform <- function(df, ...,
cfg=getOption("piecepackr.cfg", pp_cfg()),
envir=getOption("piecepackr.envir"),
op_angle = getOption("piecepackr.op_angle", 45),
pt_thickness = 0.01,
as_top = character(0),
cfg_class = "list") {
for (ps in as_top) {
indices <- which(df$piece_side == ps)
piece <- get_piece(ps)
df$piece_side[indices] <- gsub(ps, paste0(piece, "_top"), df$piece_side[indices])
}
df <- add_3d_info(df, cfg = cfg, envir = envir, pt_thickness = pt_thickness, cfg_class = cfg_class)
df <- op_sort(df, op_angle = op_angle)
df
}
add_3d_info <- function(df, ..., cfg=pp_cfg(), envir=NULL, pt_thickness = 0.01, cfg_class = "list") {
# Do more stuff if units aren't in inches?
if (cfg_class == "character")
cfg_character <- get_cfg_character(df, cfg)
df <- add_cfg(df, cfg, envir)
df <- add_measurements(df)
df <- add_bounding_box(df)
df <- add_z(df, pt_thickness = pt_thickness)
df <- add_field(df, "zt", df$z + 0.5*df$depth)
df <- add_field(df, "zb", df$z - 0.5*df$depth)
if (cfg_class == "character")
df$cfg <- cfg_character
df
}
get_cfg_character <- function(df, cfg) {
if (hasName(df, "cfg")) {
df$cfg
} else if (is.null(cfg)) {
rep_len("piecepack", nrow(df))
} else if (is.character(cfg)) {
rep_len(cfg, nrow(df))
} else {
abort("Can't compute \"character\" `cfg_class`")
}
}
op_sort <- function(df, ..., op_angle=45) {
op_angle <- op_angle %% 360
if ((0 <= op_angle) && (op_angle < 90)) {
df <- df[order(df$zt, -df$yb, -df$xl), ]
} else if ((90 <= op_angle) && (op_angle < 180)) {
df <- df[order(df$zt, -df$yb, df$xr), ]
} else if ((180 <= op_angle) && (op_angle < 270)) {
df <- df[order(df$zt, df$yt, df$xr), ]
} else {
df <- df[order(df$zt, df$yt, -df$xl), ]
}
df
}
# Axis-Aligned Bounding Box (AABB)
add_bounding_box <- function(df) {
ll <- Point2D$new(0, 0)$npc_to_in(df$x, df$y, df$width, df$height, df$angle)
ul <- Point2D$new(0, 1)$npc_to_in(df$x, df$y, df$width, df$height, df$angle)
ur <- Point2D$new(1, 1)$npc_to_in(df$x, df$y, df$width, df$height, df$angle)
lr <- Point2D$new(1, 0)$npc_to_in(df$x, df$y, df$width, df$height, df$angle)
df$xll <- ll$x
df$yll <- ll$y
df$xul <- ul$x
df$yul <- ul$y
df$xlr <- lr$x
df$ylr <- lr$y
df$xur <- ur$x
df$yur <- ur$y
df$xl <- op_round(pmin(df$xll, df$xul, df$xur, df$xlr))
df$xr <- op_round(pmax(df$xll, df$xul, df$xur, df$xlr))
df$yb <- op_round(pmin(df$yll, df$yul, df$yur, df$ylr))
df$yt <- op_round(pmax(df$yll, df$yul, df$yur, df$ylr))
df
}
op_round <- function(x) round(x, 9)
do_ranges_overlap <- function(l1, r1, l2, r2) {
(less_than_equal(l1, l2) & less_than(l2, r1)) |
(less_than_equal(l2, l1) & less_than(l1, r2))
}
which_AABB_overlap <- function(dfi, dfs) {
rev(which(do_ranges_overlap(dfi$xl, dfi$xr, dfs$xl, dfs$xr) &
do_ranges_overlap(dfi$yb, dfi$yt, dfs$yb, dfs$yt)))
}
less_than <- function(x, y) 1e-6 < y - x # in case of trigonometric precision issues
less_than_equal <- function(x, y) 0 < y - x + 1e-6 # in case of trigonometric precision issues
add_z <- function(df, pt_thickness = 0.01) {
shapes <- get_shapes(df)
zp <- 0.5*df$depth
for (i in seq(length.out=nrow(df))) {
dfi <- df[i, ]
dfs <- df[seq_len(i-1L), ]
zc <- zp[i]
for (j in which_AABB_overlap(dfi, dfs)) {
if (do_shapes_overlap(shapes[[i]], shapes[[j]])) {
zc0 <- compute_z(df, zp, i, j, pt_thickness)
if (zc0 > zc) zc <- zc0
}
}
zp[i] <- zc
}
df <- add_field(df, "z", zp)
df
}
# @param df Data frame
# @param zp Depths
# @param i Index of top piece
# @param j Index of top overlapping piece underneath
# @param pt_thickness Thickness of tip of pyramid
compute_z <- function(df, zp, i, j, pt_thickness = 0.01) {
if (all(df$piece_side[c(i,j)] == "pyramid_top")) {
if (df$rank[i] <= df$rank[j]) { # top piece is (weakly) smaller
zp[j] + 0.5 * df$depth[j] + pt_thickness - 0.5 * df$depth[i]
} else { # top piece is (strictly) bigger
zp[j] - 0.5 * df$depth[j] + 0.5 * df$depth[i]
}
} else {
zp[j] + 0.5 * df$depth[j] + 0.5 * df$depth[i]
}
}
get_shapes <- function(df) {
shapes <- vector("list", nrow(df))
for (ii in seq(length.out=nrow(df))) {
dfi <- df[ii, ]
cfg <- df$cfg[[ii]]
piece_side <- df$piece_side[ii]
suit <- ifelse(hasName(df, "suit"), df$suit[ii], NA)
rank <- ifelse(hasName(df, "rank"), df$rank[ii], NA)
opt <- try(cfg$get_piece_opt(piece_side, suit, rank), silent = TRUE)
if (inherits(opt, "try-error") || opt$shape %in% c("rect", "halma", "meeple", "roundrect")) {
shapes[[ii]] <- ConvexPolygon$new(x=c(dfi$xll, dfi$xul, dfi$xur, dfi$xlr),
y=c(dfi$yll, dfi$yul, dfi$yur, dfi$ylr))
} else if (opt$shape == "circle") {
shapes[[ii]] <- Circle$new(x=dfi$x, y=dfi$y, r=min(dfi$width/2, dfi$height/2))
} else {
label <- opt$shape
if (grepl("^concave", label)) label <- gsub("concave", "convex", label)
shape <- pp_shape(label, opt$shape_t, opt$shape_r, opt$back)
xy_u <- shape$npc_coords
xy_c <- Point2D$new(xy_u)$npc_to_in(dfi$x, dfi$y, dfi$width, dfi$height, dfi$angle)
shapes[[ii]] <- ConvexPolygon$new(xy_c)
}
}
shapes
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.