R/utils-d20.R

In piecepackr: Board Game Graphics

# https://mathworld.wolfram.com/RegularIcosahedron.html
# https://www.blocklayer.com/pyramid-calculator gives us pyramid side angle 37.4 degrees
# a = from vertex to adjacent vertex
# inradius = (3 * sqrt(3) + sqrt(15)) / 12) * a ~=  0.75576 * a

## d20 Top
d20TopGrob <- function(
	piece_side,
	suit,
	rank,
	cfg = pp_cfg(),
	x = unit(0.5, "npc"),
	y = unit(0.5, "npc"),
	z = unit(0, "npc"),
	angle = 0,
	type = "normal",
	width = NA,
	height = NA,
	depth = NA,
	op_scale = 0,
	op_angle = 45
) {
	cfg <- as_pp_cfg(cfg)

	x <- convertX(x, "in", valueOnly = TRUE)
	y <- convertY(y, "in", valueOnly = TRUE)
	z <- convertX(z, "in", valueOnly = TRUE)
	width <- convertX(width, "in", valueOnly = TRUE)
	height <- convertY(height, "in", valueOnly = TRUE)
	depth <- convertX(depth, "in", valueOnly = TRUE)

	#### allow limited 3D rotation #281
	axis_x <- 0
	axis_y <- 0

	xyz <- d20_xyz(suit, rank, cfg, x, y, z, angle, axis_x, axis_y, width, height, depth)
	l_xyz <- list()
	dfc <- data.frame(x = numeric(0), y = numeric(0), z = numeric(0))
	for (i in 1:20) {
		idx <- seq.int(3 * i - 2, length.out = 3)
		dfc <- rbind(dfc, as.data.frame(mean(xyz[idx])))
	}

	dfc$rank <- 1:20
	dfc <- dfc[
		painter_order(as_coord3d(dfc$x, dfc$y, dfc$z), scale = op_scale, alpha = degrees(op_angle)),
	]

	gl <- gList()
	for (i in 1:nrow(dfc)) {
		edge_rank <- dfc$rank[i]
		edge <- paste("d20_", edge_rank)
		opt <- cfg$get_piece_opt("die_face", suit, edge_rank)
		gp <- gpar(col = opt$border_color, lex = opt$border_lex, fill = opt$background_color)
		idx <- seq.int(3 * edge_rank - 2, length.out = 3)
		xyz_polygon <- xyz[idx]
		xy_polygon <- as_coord2d(xyz_polygon, alpha = degrees(op_angle), scale = op_scale)
		xy_vp <- xy_vp_convex(xyz_polygon, op_scale, op_angle)
		gl[[i]] <- at_ps_grob("die_face", suit, edge_rank, cfg, xy_vp, xy_polygon, name = edge)
	}

	# pre-compute grobCoords
	coords_xyl <- as.list(convex_hull2d(as_coord2d(
		xyz,
		alpha = degrees(op_angle),
		scale = op_scale
	)))

	gTree(
		scale = 1,
		coords_xyl = coords_xyl,
		children = gl,
		cl = c("projected_rpg_die", "coords_xyl")
	)
}

# if `rank` on top figure out rotation so one on top instead
# currently just a fixed arrangement
d20_rot_from_top <- function(rank) {
	a1 <- 180 - arccos(-sqrt(5) / 3) # 180 - dihedral angle
	a2 <- 37.4 # equilateral pentagonal pyramid side (face) angle
	# a <- 50
	stopifnot(rank <= 20)
	switch(
		rank,
		diag(3), # 01
		R_x(180) %*% R_z(180) %*% R_x(a1) %*% R_z(120), # 02
		R_z(-120) %*% R_x(a2) %*% R_z(144) %*% R_x(-a2), # 03
		R_z(120) %*% R_x(180) %*% R_z(-120) %*% R_x(a2) %*% R_z(-144) %*% R_x(-a2), # 04
		R_z(120) %*% R_x(a2) %*% R_z(-144) %*% R_x(-a2) %*% R_z(120), # 05
		R_x(180) %*% R_z(-120) %*% R_x(a2) %*% R_z(144) %*% R_x(-a2) %*% R_z(120), # 06
		R_z(180) %*% R_x(a1) %*% R_z(-120), # 07
		R_x(180) %*% R_z(180) %*% R_x(a1), # 08
		R_z(120) %*% R_x(a2) %*% R_z(-144) %*% R_x(-a2) %*% R_z(-120), # 09
		R_z(120) %*% R_x(a2) %*% R_z(-144) %*% R_x(-a2) %*% R_z(120) %*% R_x(180), # 10
		R_z(-120) %*% R_x(a2) %*% R_z(144) %*% R_x(-a2) %*% R_z(-120), # 11
		R_z(-120) %*% R_x(a2) %*% R_z(144) %*% R_x(-a2) %*% R_z(120) %*% R_x(180), # 12
		R_z(180) %*% R_x(a1), # 13
		R_x(180) %*% R_z(180) %*% R_x(a1) %*% R_z(-120), # 14
		R_z(-120) %*% R_x(a2) %*% R_z(144) %*% R_x(-a2) %*% R_z(120), # 15
		R_x(180) %*% R_z(120) %*% R_x(a2) %*% R_z(-144) %*% R_x(-a2) %*% R_z(120), # 16
		R_z(120) %*% R_x(a2) %*% R_z(-144) %*% R_x(-a2), # 17
		R_x(180) %*% R_z(-120) %*% R_x(a2) %*% R_z(144) %*% R_x(-a2), # 18
		R_z(180) %*% R_x(a1) %*% R_z(120), # 19
		R_x(180)
	) # 20
}

# if one on top figure out rotation so `rank` on top instead
d20_rot_to_top <- function(rank) {
	a1 <- 180 - arccos(-sqrt(5) / 3) # 180 - dihedral angle
	a2 <- 37.4 # equilateral pentagonal pyramid side (face) angle
	stopifnot(rank <= 20)
	switch(
		rank,
		diag(3), # 01
		R_z(-120) %*% R_x(-a1) %*% R_z(-180) %*% R_x(-180), # 02
		R_x(a2) %*% R_z(-144) %*% R_x(-a2) %*% R_z(120), # 03
		R_x(a2) %*% R_z(144) %*% R_x(-a2) %*% R_z(120) %*% R_x(-180) %*% R_z(-120), # 04
		R_z(-120) %*% R_x(a2) %*% R_z(144) %*% R_x(-a2) %*% R_z(-120), # 05
		R_z(-120) %*% R_x(a2) %*% R_z(-144) %*% R_x(-a2) %*% R_z(120) %*% R_x(-180), # 06
		R_z(120) %*% R_x(-a1) %*% R_z(-180), # 07
		R_x(-a1) %*% R_z(-180) %*% R_x(-180), # 08
		R_z(120) %*% R_x(a2) %*% R_z(144) %*% R_x(-a2) %*% R_z(-120), # 09
		R_x(-180) %*% R_z(-120) %*% R_x(a2) %*% R_z(144) %*% R_x(-a2) %*% R_z(-120), # 10
		R_z(120) %*% R_x(a2) %*% R_z(-144) %*% R_x(-a2) %*% R_z(120), # 11
		R_x(-180) %*% R_z(-120) %*% R_x(a2) %*% R_z(-144) %*% R_x(-a2) %*% R_z(120), # 12
		R_x(-a1) %*% R_z(180), # 13
		R_z(120) %*% R_x(-a1) %*% R_z(-180) %*% R_x(-180), # 14
		R_z(-120) %*% R_x(a2) %*% R_z(-144) %*% R_x(-a2) %*% R_z(120), # 15
		R_z(-120) %*% R_x(a2) %*% R_z(144) %*% R_x(-a2) %*% R_z(-120) %*% R_x(-180), # 16
		R_x(a2) %*% R_z(144) %*% R_x(-a2) %*% R_z(-120), # 17
		R_x(a2) %*% R_z(-144) %*% R_x(-a2) %*% R_z(120) %*% R_x(-180), # 18
		R_z(-120) %*% R_x(-a1) %*% R_z(-180), # 19
		R_x(-180)
	) # 20
}

d20_xyz <- function(suit, rank, cfg, x, y, z, angle, axis_x, axis_y, width, height, depth) {
	R_rank <- d20_rot_to_top(rank)
	xs <- numeric(0)
	ys <- numeric(0)
	zs <- numeric(0)
	xyz_t <- as_coord3d(
		regular_ngon_polygon2d(3, x = 0, y = 0, theta = degrees(90)),
		z = 0.5
	)$scale(
		width,
		height,
		depth
	)
	for (i in 1:20) {
		R_i <- d20_rot_from_top(i)
		xyz_i <- xyz_t$clone()$transform(R_i %*% R_rank)
		xs <- append(xs, xyz_i$x)
		ys <- append(ys, xyz_i$y)
		zs <- append(zs, xyz_i$z)
	}

	as_coord3d(xs, ys, zs)$transform(AA_to_R(angle, axis_x, axis_y))$translate(as_coord3d(x, y, z))
}

save_d20_obj <- function(
	piece_side,
	suit,
	rank,
	cfg,
	x,
	y,
	z,
	angle,
	axis_x,
	axis_y,
	width,
	height,
	depth,
	filename,
	scale,
	res
) {
	cfg <- as_pp_cfg(cfg)
	opt <- cfg$get_piece_opt(piece_side, suit, rank)

	xyz <- d20_xyz(suit, rank, cfg, x, y, z, angle, axis_x, axis_y, width, height, depth)

	p <- regular_ngon_polygon2d(3, x = 0.5, y = 0.5, theta = degrees(90))
	xy_vt <- list(
		x = rep(p$x / 4, 20) + rep(rep(0:3 / 4, each = 3), 5),
		y = rep(p$y / 5, 20) + rep(rep(4:0 / 5, each = 3), each = 4)
	)

	# textured face elements
	f <- list()
	for (i in 1:20) {
		idx <- seq.int(3 * i - 2, length.out = 3)
		f[[i]] <- list(v = idx, vt = idx)
	}

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

	write_obj(filename, v = xyz, vt = xy_vt, f = f)
	write_d20_texture("die_face", suit, rank, cfg, filename = png_filename, res = res)

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

write_d20_texture <- function(
	piece_side = "die_face",
	suit = 1,
	rank = 1,
	cfg = pp_cfg(),
	...,
	filename = tempfile(fileext = ".png"),
	res = 72
) {
	current_dev <- grDevices::dev.cur()
	if (current_dev > 1) {
		on.exit(grDevices::dev.set(current_dev), add = TRUE)
	}
	width <- cfg$get_width("die_face", suit, rank)

	args <- list(
		filename = filename,
		height = 5 * width,
		width = 4 * width,
		units = "in",
		res = res,
		bg = "transparent"
	)
	if (capabilities("cairo")) {
		args$type <- "cairo"
	}
	do.call(grDevices::png, args)

	xs <- rep(1:4 / 4 - 1 / 8, 5)
	ys <- rep(5:1 / 5 - 1 / 10, each = 4)
	for (i in 1:20) {
		pushViewport(viewport(x = xs[i], width = 1 / 4, y = ys[i], height = 1 / 5))
		draw_piece_and_bleed("die_face", suit, i, cfg)
		popViewport()
	}

	grDevices::dev.off()
	invisible(filename)
}