R/basicPieceGrob.R

In piecepackr: Board Game Graphics

#' Piece Grob Functions
#'
#' `basicPieceGrob()` is the most common
#' \dQuote{grob} function that [grid.piece()] uses
#' to create `grid` graphical `grob` objects.
#' `picturePieceGrobFn()` is a function that returns a \dQuote{grob} function
#' that imports graphics from files found in its `directory` argument.
#'
#' @rdname basicPieceGrobs
#' @name basicPieceGrobs
#' @param cfg Piecepack configuration list or [pp_cfg()] object.
#' @inheritParams grid.piece
#' @examples
#'
#'  if (requireNamespace("grid", quietly = TRUE) && piecepackr:::device_supports_unicode()) {
#'    cfg <- pp_cfg(list(grob_fn.tile=basicPieceGrob, invert_colors=TRUE))
#'    grid.piece("tile_face", suit=1, rank=3, cfg=cfg)
#'  }
#'
#'  \donttest{# May take more than 5 seconds on CRAN servers
#'  try({
#'    if (requireNamespace("grid", quietly = TRUE) && capabilities(c("cairo"))) {
#'      cfg <- pp_cfg(list(grob_fn.tile=basicPieceGrob, invert_colors=TRUE))
#'      directory <- tempdir()
#'      save_piece_images(cfg, directory=directory, format="svg", angle=0)
#'      cfg2 <- pp_cfg(list(grob_fn=picturePieceGrobFn(directory)))
#'
#'      grid::grid.newpage()
#'      grid.piece("coin_back", suit=3, rank=5, cfg=cfg2)
#'    }
#'  })
#'  }
#' @export
basicPieceGrob <- function(piece_side, suit, rank, cfg = pp_cfg()) {
	cfg <- as_pp_cfg(cfg)
	opt <- cfg$get_piece_opt(piece_side, suit, rank)
	gTree(
		opt = opt,
		border = TRUE,
		flip = FALSE,
		scale = 1,
		fill_stroke = FALSE,
		name = NULL,
		gp = gpar(),
		vp = NULL,
		cl = "basic_piece_side"
	)
}

basicPieceGrobFn <- function(fill_stroke = FALSE) {
	force(fill_stroke)
	function(piece_side, suit, rank, cfg = pp_cfg()) {
		cfg <- as_pp_cfg(cfg)
		opt <- cfg$get_piece_opt(piece_side, suit, rank)
		gTree(
			opt = opt,
			border = TRUE,
			flip = FALSE,
			scale = 1,
			fill_stroke = fill_stroke,
			name = NULL,
			gp = gpar(),
			vp = NULL,
			cl = "basic_piece_side"
		)
	}
}

ellipsoidGrobFn <- function(shading = FALSE) {
	force(shading)
	function(piece_side, suit, rank, cfg = pp_cfg()) {
		cfg <- as_pp_cfg(cfg)
		opt <- cfg$get_piece_opt(piece_side, suit, rank)

		gTree(
			opt = opt,
			border = TRUE,
			flip = FALSE,
			scale = 1,
			shading = shading,
			name = NULL,
			gp = gpar(),
			vp = NULL,
			cl = c("basic_ellipsoid", "basic_piece_side")
		)
	}
}

#' @export
makeContext.basic_piece_side <- function(x) {
	x <- update_gp(x, gp = gpar(cex = x$scale, lex = x$scale))
	x
}

#' @export
grobCoords.basic_piece_side <- function(x, closed, ...) {
	opt <- x$opt
	shape <- pp_shape(
		opt$shape,
		opt$shape_t,
		opt$shape_r,
		opt$back,
		width = opt$shape_w,
		height = opt$shape_h
	)
	grobCoords(shape$shape(vp = x$vp), closed = closed, ...)
}

#' @export
makeContent.basic_piece_side <- function(x) {
	opt <- x$opt
	shape <- pp_shape(
		opt$shape,
		opt$shape_t,
		opt$shape_r,
		opt$back,
		width = opt$shape_w,
		height = opt$shape_h
	)
	# Possibly shrink background and gridlines to not overlap mat
	# which sometimes prevents visual glitch if no border line
	# but do not do this if mat color is transparent.
	if (any(as.logical(grDevices::col2rgb(opt$mat_color, alpha = TRUE)[4, ] < 255))) {
		bg_mat_width <- 0
	} else {
		bg_mat_width <- opt$mat_width
	}

	# Background
	background_grob <- shape$shape(
		gp = gpar(col = NA, fill = opt$background_color),
		name = "background",
		mat_width = bg_mat_width
	)
	gl_grob <- shape$gridlines(
		gp = gpar(col = opt$gridline_color, lex = opt$gridline_lex),
		name = "gridlines",
		mat_width = bg_mat_width
	)
	gp_mat <- gpar(col = NA, lwd = 0, fill = opt$mat_color)
	mat_grob <- shape$mat(opt$mat_width, gp = gp_mat, name = "mat")

	# Primary symbol
	gp_ps <- gpar(
		col = opt$ps_color,
		fontsize = opt$ps_fontsize,
		fontfamily = opt$ps_fontfamily,
		fontface = opt$ps_fontface
	)
	ps_grob <- textGrob(
		opt$ps_text,
		x = opt$ps_x,
		y = opt$ps_y,
		hjust = 0.5,
		vjust = 0.5,
		gp = gp_ps,
		name = "primary_symbol"
	)
	if (isTRUE(x$fill_stroke)) {
		ps_grob <- as_fill_stroke_grob(ps_grob, fill = opt$ps_color)
	}

	# Directional mark
	gp_dm <- gpar(
		col = opt$dm_color,
		fontsize = opt$dm_fontsize,
		fontfamily = opt$dm_fontfamily,
		fontface = opt$dm_fontface
	)
	dm_grob <- textGrob(
		opt$dm_text,
		x = opt$dm_x,
		y = opt$dm_y,
		hjust = 0.5,
		vjust = 0.5,
		gp = gp_dm,
		name = "directional_mark"
	)
	if (isTRUE(x$fill_stroke)) {
		dm_grob <- as_fill_stroke_grob(dm_grob, fill = opt$dm_color)
	}

	if (x$border) {
		gp_border <- gpar(col = opt$border_color, fill = NA, lex = opt$border_lex)
		border_grob <- shape$shape(gp = gp_border, name = "border")
	} else {
		border_grob <- nullGrob(name = "border")
	}
	if (x$flip) {
		gl <- gList(dm_grob, ps_grob, mat_grob, gl_grob, background_grob, border_grob)
	} else {
		gl <- gList(background_grob, gl_grob, mat_grob, ps_grob, dm_grob, border_grob)
	}

	setChildren(x, gl)
}

#' @export
makeContent.basic_ellipsoid <- function(x) {
	opt <- x$opt
	shape <- pp_shape(
		opt$shape,
		opt$shape_t,
		opt$shape_r,
		opt$back,
		width = opt$shape_w,
		height = opt$shape_h
	)

	gp_background <- gpar(col = NA, fill = opt$background_color)
	background_grob <- shape$shape(gp = gp_background, name = "background")

	if (x$shading) {
		if (has_radial_gradients()) {
			rgr <- radialGradient(
				c(update_alpha_col(opt$background_color, 0.500), "#00000080"),
				r1 = 0.1
			)
			gp_gr <- gpar(col = opt$border_color, fill = rgr)
			shading_grob <- shape$shape(gp = gp_gr, name = "shading")
		} else {
			rgr_inform()
			shading_grob <- nullGrob(name = "shading")
		}
	} else {
		shading_grob <- nullGrob(name = "shading")
	}

	if (x$border) {
		gp_border <- gpar(col = opt$border_color, fill = NA, lex = opt$border_lex)
		border_grob <- shape$shape(gp = gp_border, name = "border")
	} else {
		border_grob <- nullGrob(name = "border")
	}
	if (x$flip) {
		# Do anything with shading?
		gl <- gList(background_grob, border_grob)
	} else {
		gl <- gList(background_grob, shading_grob, border_grob)
	}

	setChildren(x, gl)
}

#' @rdname basicPieceGrobs
#' @param directory Directory that `picturePieceGrobFn` will look in for piece graphics.
#' @param filename_fn Function that takes arguments `directory`, `piece_side`, `suit`,
#'        `rank`, and optionally `cfg` and returns the (full path) filename of the image that the
#'        function returned by `picturePieceGrobFn` should import.
#' @export
picturePieceGrobFn <- function(directory, filename_fn = find_pp_file) {
	function(piece_side, suit, rank, cfg) {
		if (hasName(formals(filename_fn), "cfg")) {
			f <- filename_fn(directory, piece_side, suit, rank, cfg)
		} else {
			f <- filename_fn(directory, piece_side, suit, rank)
		}
		file2grob(f)
	}
}

find_pp_file <- function(directory, piece_side, suit, rank, cfg) {
	for (format in c("svgz", "svg", "png", "jpg", "jpeg")) {
		f <- piece_filename_helper(directory, piece_side, format, suit, rank, cfg)
		if (file.exists(f)) {
			return(f)
		}
	}
	abort(paste("Couldn't find suitable", piece_side, "image in", directory))
}

piece_filename_helper <- function(directory, piece_side, format, suit, rank, cfg) {
	if (piece_side %in% intersect(cfg$lacks_rank, cfg$lacks_suit)) {
		piece_filename(directory, piece_side, format, 0)
	} else if (piece_side %in% cfg$lacks_rank) {
		piece_filename(directory, piece_side, format, 0, suit = suit)
	} else if (piece_side %in% cfg$lacks_suit) {
		piece_filename(directory, piece_side, format, 0, rank = rank)
	} else {
		piece_filename(directory, piece_side, format, 0, suit = suit, rank = rank)
	}
}

#' @rdname basicPieceGrobs
#' @export
pyramidTopGrob <- function(piece_side, suit, rank, cfg = pp_cfg()) {
	gTree(suit = suit, rank = rank, cfg = cfg, scale = 1, cl = "pyramid_top")
}

#' @export
makeContent.pyramid_top <- function(x) {
	width <- convertWidth(unit(1, "npc"), "in", valueOnly = TRUE)
	height <- convertHeight(unit(1, "npc"), "in", valueOnly = TRUE)

	# face at top
	xy_vp <- list(x = c(width, width, 0, 0), y = c(0.5 * height, height, height, 0.5 * height))
	xy_polygon <- list(x = c(0.5 * height, width, 0), y = c(0.5 * height, height, height))
	g1 <- at_ps_grob("pyramid_face", x$suit, x$rank, x$cfg, xy_vp, xy_polygon, "face")
	g1$scale <- x$scale

	# back at bottom
	xy_vp <- list(x = width * rect_xy$x, y = 0.5 * height * rect_xy$y)
	xy_polygon <- list(x = width * pyramid_xy$x, y = 0.5 * height * pyramid_xy$y)
	g2 <- at_ps_grob("pyramid_back", x$suit, x$rank, x$cfg, xy_vp, xy_polygon, "back")
	g2$scale <- x$scale

	# left at left
	xy_vp <- list(x = c(0.5 * width, 0, 0, 0.5 * width), y = c(height, height, 0, 0))
	xy_polygon <- list(x = c(0.5 * width, 0, 0), y = c(0.5 * height, height, 0))
	g3 <- at_ps_grob("pyramid_left", x$suit, x$rank, x$cfg, xy_vp, xy_polygon, "left")
	g3$scale <- x$scale

	# right at right
	xy_vp <- list(x = c(0.5 * width, width, width, 0.5 * width), y = c(0, 0, height, height))
	xy_polygon <- list(x = c(0.5 * width, width, width), y = c(0.5 * height, 0, height))
	g4 <- at_ps_grob("pyramid_right", x$suit, x$rank, x$cfg, xy_vp, xy_polygon, "right")
	g4$scale <- x$scale

	gl <- gList(g1, g2, g3, g4)

	setChildren(x, gl)
}

#' @export
grobCoords.pyramid_top <- function(x, closed, ...) {
	grobCoords(rectGrob(vp = x$vp), closed = closed, ...)
}

#' @rdname basicPieceGrobs
#' @export
previewLayoutGrob <- function(piece_side, suit, rank, cfg = pp_cfg()) {
	cfg <- as_pp_cfg(cfg)

	t_width <- cfg$get_width("tile_face")
	c_width <- cfg$get_width("coin_face")
	d_width <- cfg$get_width("die_face")
	s_width <- cfg$get_width("saucer_face")
	p_height <- cfg$get_height("pawn_face")
	preview_width <- 3 * t_width

	gl <- gList()
	cs_tiles <- rep("tile_face", 6)
	suit_tiles <- 1:6
	rank_tiles <- rep(2, 6)
	if (cfg$n_suits < 5) {
		cs_tiles[5] <- "tile_back"
		suit_tiles[5] <- NA
		rank_tiles[5] <- NA
	}
	if (cfg$n_suits < 6) {
		cs_tiles[6] <- "tile_back"
		suit_tiles[6] <- NA
		rank_tiles[6] <- NA
	}
	x_tiles <- c(1, 5, 5, 1, 3, 3)
	y_tiles <- c(5, 5, 3, 3, 5, 3)
	gl[["tiles"]] <- pieceGrob(
		cs_tiles,
		suit_tiles,
		rank_tiles,
		cfg,
		x_tiles,
		y_tiles,
		default.units = "in",
		name = "tiles"
	)

	cs_coins <- rep(c("coin_face", "coin_back"), each = 3)
	suit_coins <- c(rep(NA, 3), 4:2)
	rank_coins <- c(1:3, rep(NA, 3))
	x_coins <- rep(1:3, 2) * c_width - 0.5 * c_width
	y_coins <- 0.5 * t_width + rep(c(0.5, -0.5), each = 3) * c_width
	if (cfg$n_suits > 4) {
		suit_coins[5] <- 5
	}
	if (cfg$n_suits > 5) {
		suit_coins[6] <- 6
	}

	gl[["coins"]] <- pieceGrob(
		cs_coins,
		suit_coins,
		rank_coins,
		cfg,
		x_coins,
		y_coins,
		default.units = "in",
		name = "coins"
	)

	gl[["saucers"]] <- pieceGrob(
		c("saucer_face", "saucer_back"),
		c(1, NA),
		NA,
		cfg,
		t_width + 1.5 * d_width,
		0.5 * t_width + c(0.5, -0.5) * s_width,
		default.units = "in",
		name = "saucers"
	)

	gl[["pawns"]] <- pieceGrob(
		c("pawn_face", "pawn_back"),
		2,
		NA,
		cfg,
		t_width + 3 * d_width,
		0.5 * t_width + c(0.5, -0.5) * p_height,
		angle = c(0, 180),
		default.units = "in",
		name = "pawns"
	)

	gl[["suitrankdie"]] <- pieceGrob(
		"suitrankdie_layoutRF",
		NA,
		NA,
		cfg,
		preview_width - 2 * d_width,
		0.5 * t_width,
		default.units = "in",
		name = "suitrankdie"
	)

	gTree(children = gl, cl = "preview_layout")
}

dieLayoutGrobRF <- function(piece_side, suit, rank, cfg) {
	piecepackDieGrob(suit, cfg)
}

dieLayoutGrobLF <- function(piece_side, suit, rank, cfg) {
	piecepackDieGrob(suit, cfg, flip = TRUE)
}

suitdieLayoutGrobRF <- function(piece_side, suit, rank, cfg) {
	suitdieGrob(cfg)
}

suitdieLayouGrobtLF <- function(piece_side, suit, rank, cfg) {
	suitdieGrob(cfg, flip = TRUE)
}

suitrankdieLayoutGrobRF <- function(piece_side, suit, rank, cfg) {
	suit <- get_suit_die_suits(cfg)
	piecepackDieGrob(suit, cfg)
}
suitrankdieLayoutGrobLF <- function(piece_side, suit, rank, cfg) {
	suit <- get_suit_die_suits(cfg)
	piecepackDieGrob(suit, cfg, flip = TRUE)
}

## Layout functions
x_die_layoutRF <- c(1 / 4, 2 / 4, 2 / 4, 3 / 4, 3 / 4, 4 / 4) - 1 / 8
x_die_layoutLF <- c(4 / 4, 3 / 4, 3 / 4, 2 / 4, 2 / 4, 1 / 4) - 1 / 8
y_die_layout <- c(1 / 3, 1 / 3, 2 / 3, 2 / 3, 3 / 3, 3 / 3) - 1 / 6

piecepackDieGrob <- function(suit, cfg, flip = FALSE, arrangement = cfg$die_arrangement) {
	cfg <- as_pp_cfg(cfg)
	rs <- get_die_face_info(suit, arrangement)
	angle <- rep(c(0, -90), 3)
	if (flip) {
		x <- x_die_layoutLF
		angle <- -angle
	} else {
		x <- x_die_layoutRF
	}
	angle <- angle + rs$angle
	gl <- gList()
	for (ii in 1:6) {
		gl[[ii]] <- pieceGrob(
			"die_face",
			rs$suit[ii],
			rs$rank[ii],
			cfg,
			x = x[ii],
			y = y_die_layout[ii],
			default.units = "npc",
			width = 1 / 4,
			height = 1 / 3,
			angle = angle[ii]
		)
	}
	gTree(children = gl, name = "die_layout")
}

suitdieGrob <- function(cfg, flip = FALSE) {
	angle <- rep(c(-90, 0), 3)
	if (flip) {
		x <- x_die_layoutLF
		angle <- -angle
	} else {
		x <- x_die_layoutRF
	}
	suit <- get_suit_die_suits(cfg)
	gl <- gList()
	for (ii in 1:6) {
		vp <- viewport(x = x[ii], y = y_die_layout[ii], angle = angle[ii])
		gl[[ii]] <- pieceGrob("suitdie_face", suit[ii], NA, cfg, default.units = "npc", vp = vp)
	}
	gTree(children = gl, name = "suitdie_layout")
}

get_suit_die_suits <- function(cfg) {
	n_suits <- cfg$n_suits
	if (n_suits < 4) {
		rep(n_suits:1, length.out = 6)
	} else if (n_suits == 4) {
		c(5, 6, 4:1)
	} else if (n_suits > 4) {
		6:1
	}
}

pawnLayoutGrob <- function(piece_side, suit, rank, cfg) {
	gl <- gList()
	suppressWarnings({
		ph <- cfg$get_height("pawn_face")
		pb <- 3 / 7 * ph
		denominator <- 2 * (ph + pb)
		yf <- 0.5 * ph / denominator
		height <- ph / denominator
		gl[[1]] <- pieceGrob(
			"pawn_face",
			suit,
			NA,
			cfg,
			y = 1 / 2 - yf,
			height = height,
			default.units = "npc",
			name = "pawn_face"
		)
		gl[[2]] <- pieceGrob(
			"pawn_back",
			suit,
			NA,
			cfg,
			y = 1 / 2 + yf,
			height = height,
			angle = 180,
			default.units = "npc",
			name = "pawn_back"
		)
	})
	opt <- cfg$get_piece_opt("pawn_face", suit, 0)
	gp <- gpar(col = opt$border_color, fill = NA)
	gl[[3]] <- linesGrob(y = 0.5, gp = gpar(col = opt$border_color, fill = NA, lty = "dashed"))
	gl[[4]] <- rectGrob(gp = gp)
	ll <- 0.07
	gl[[5]] <- segmentsGrob(0.5, 0, 0.5, ll, gp = gp)
	gl[[6]] <- segmentsGrob(0.5, 1, 0.5, 1 - ll, gp = gp)
	gTree(children = gl, name = "pawn_layout")
}

pyramidLayoutGrob <- function(piece_side, suit, rank, cfg) {
	w <- cfg$get_width("pyramid_face", rank = rank)
	h <- cfg$get_height("pyramid_face", rank = rank)
	d <- sqrt(h^2 + (0.5 * w)^2)
	t <- c(72, 36, 0, -36, -72)
	r <- h
	x <- 0.5 * to_x(t, r)
	y <- d + 0.5 * to_y(t, r)
	pieces <- c("pyramid_face", "pyramid_right", "pyramid_back", "pyramid_left", "pyramid_face")
	angles <- c(90 + 72, 90 + 36, 90, 90 - 36, 90 - 72)
	df <- tibble(piece_side = pieces, x = x, y = y, suit = suit, rank = rank, angle = angles)
	g <- pmap_piece(df, cfg = cfg, default.units = "inches", draw = FALSE)
	grobTree(g, name = "pyramid_layout")
}