diff --git a/.gitignore b/.gitignore index 7daae70..f8e2038 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,7 @@ *.png *.swp +.claude/ codecov.yml README.html diff --git a/DESCRIPTION b/DESCRIPTION index 45ae112..6c9b761 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,7 +2,7 @@ Encoding: UTF-8 Package: ppgamer Type: Package Title: Players for Piecepack Games like Fuji-san -Version: 0.1.2-1 +Version: 0.2.0-1 Authors@R: c(person("Trevor L.", "Davis", role=c("aut", "cre"), email="trevor.l.davis@gmail.com", comment = c(ORCID = "0000-0001-6341-4639"))) @@ -13,17 +13,18 @@ BugReports: https://github.com/piecepackr/ppgamer/issues LazyLoad: yes Depends: R (>= 3.4.0) Imports: - dplyr, - rlang, - stringr, - tibble, + dplyr, + rlang, + stringr, + tibble, Suggests: - igraph, - ppcli, - ppn (>= 0.1.0-2), - testthat, - withr, - vdiffr, + igraph, + piecepackr, + ppcli, + ppn (>= 0.1.0-2), + testthat, + withr, + vdiffr, Remotes: piecepackr/ppcli, piecepackr/ppn Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.3 diff --git a/NAMESPACE b/NAMESPACE index bf5ecd8..eb9bfa3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,5 +1,6 @@ # Generated by roxygen2: do not edit by hand +export(solve_dominosa) export(solve_fujisan) importFrom(dplyr,near) importFrom(rlang,.data) diff --git a/NEWS.md b/NEWS.md index d436242..1058c70 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,7 +1,8 @@ -ppgames 0.1.2 (development) +ppgames 0.2.0 (development) =========================== -* No user-facing changes. +* `solve_dominosa()` solves Dominosa (Domino Solitaire) +* `solve_fujisan()` gains a `pawns` argument to support solving from an intermediate pawns position using a FEN-like string (e.g. `"S12M/A12C"`) (#1). ppgamer 0.1.1 ============= diff --git a/R/dominosa.R b/R/dominosa.R new file mode 100644 index 0000000..8f9b70b --- /dev/null +++ b/R/dominosa.R @@ -0,0 +1,316 @@ +parse_dominosa_pips <- function(pips) { + if (is.matrix(pips)) { + storage.mode(pips) <- "integer" + pips + } else if (is.character(pips)) { + rows <- strsplit(pips, "/")[[1]] + rows <- lapply(rows, function(r) as.integer(process_ranks(r)) - 1L) + lens <- lengths(rows) + if (length(unique(lens)) != 1L) { + abort("All rows in `pips` must have the same length.") + } + do.call(rbind, rows) + } else { + abort(str_glue("`pips` must be a matrix or character string, not {class(pips)[1L]}.")) + } +} + +validate_dominosa_pips <- function(pips) { + n <- max(pips) + n_cells <- length(pips) + expected_cells <- (n + 1L) * (n + 2L) + if (n_cells != expected_cells) { + abort(str_glue( + "For a double-{n} domino set the grid must have {expected_cells} cells, but `pips` has {n_cells} cells." + )) + } + expected_count <- n + 2L + bad <- integer(0) + for (k in 0:n) { + if (sum(pips == k) != expected_count) bad <- c(bad, k) + } + if (length(bad) > 0L) { + abort(str_glue( + "For a double-{n} domino set each pip value must appear exactly {expected_count} time(s). The following pip values have incorrect counts: {paste(bad, collapse = ', ')}." + )) + } +} + +# Compute 1-based domino type ID for sorted pip pair (p_lo <= p_hi). +# Ordering: (0,0)=1, (0,1)=2, ..., (0,n)=n+1, (1,1)=n+2, ... +domino_id <- function(p_lo, p_hi, n) { + as.integer(p_lo * (n + 1L) - (p_lo * (p_lo - 1L)) %/% 2L + (p_hi - p_lo) + 1L) +} + +build_dominosa_placements <- function(pips, n_rows, n_cols, n) { + # Horizontal pairs: (r,c)-(r,c+1) + h_r <- rep(seq_len(n_rows), each = n_cols - 1L) + h_c <- rep(seq_len(n_cols - 1L), times = n_rows) + h_p1 <- pips[cbind(h_r, h_c)] + h_p2 <- pips[cbind(h_r, h_c + 1L)] + + # Vertical pairs: (r,c)-(r+1,c) + v_r <- rep(seq_len(n_rows - 1L), each = n_cols) + v_c <- rep(seq_len(n_cols), times = n_rows - 1L) + v_p1 <- pips[cbind(v_r, v_c)] + v_p2 <- pips[cbind(v_r + 1L, v_c)] + + all_p1 <- c(h_p1, v_p1) + all_p2 <- c(h_p2, v_p2) + p_lo <- pmin(all_p1, all_p2) + p_hi <- pmax(all_p1, all_p2) + + list( + cell1 = c( + (h_r - 1L) * n_cols + h_c, + (v_r - 1L) * n_cols + v_c + ), + cell2 = c( + (h_r - 1L) * n_cols + h_c + 1L, + v_r * n_cols + v_c + ), + did = domino_id(p_lo, p_hi, n) + ) +} + +# Commits a single placement `pid` as solution for its domino +# Then eliminates everything that conflicts with this placement +assign_placement <- function(pid, eliminated, cell_pids, domino_pids, pl_cell1, pl_cell2, pl_did) { + to_elim <- c( + cell_pids[[pl_cell1[pid]]], # all other placements that touch cell 1 + cell_pids[[pl_cell2[pid]]], # all other placements that touch cell 2 + domino_pids[[pl_did[pid]]] # all other placements for this domino type + ) + eliminated[to_elim[to_elim != pid]] <- TRUE + eliminated +} + +# Constraint propagation +# Repeatedly scans for forced assignments until no more can be deduced +propagate_dominosa <- function( + eliminated, + cell_pids, + domino_pids, + pl_cell1, + pl_cell2, + pl_did, + n_cells, + n_dom +) { + repeat { + prev <- eliminated + + for (d in seq_len(n_dom)) { + pids <- domino_pids[[d]] + active <- pids[!eliminated[pids]] + if (length(active) == 0L) { + # domino can't be placed => unsolvable + return(NULL) + } + if (length(active) == 1L) { + # Forced assignment + eliminated <- assign_placement( + active, + eliminated, + cell_pids, + domino_pids, + pl_cell1, + pl_cell2, + pl_did + ) + } + } + + for (ci in seq_len(n_cells)) { + pids <- cell_pids[[ci]] + active <- pids[!eliminated[pids]] + if (length(active) == 0L) { + # cell has no placements => unsolvable + return(NULL) + } + if (length(active) == 1L) { + # Forced assignment + eliminated <- assign_placement( + active, + eliminated, + cell_pids, + domino_pids, + pl_cell1, + pl_cell2, + pl_did + ) + } + } + + if (identical(eliminated, prev)) break + } + eliminated +} + +search_dominosa <- function( + eliminated, + cell_pids, + domino_pids, + pl_cell1, + pl_cell2, + pl_did, + n_cells, + n_dom +) { + # Check for all forced placements first + eliminated <- propagate_dominosa( + eliminated, + cell_pids, + domino_pids, + pl_cell1, + pl_cell2, + pl_did, + n_cells, + n_dom + ) + if (is.null(eliminated)) { + return(NULL) + } + + active_counts <- vapply(domino_pids, function(pids) sum(!eliminated[pids]), integer(1L)) + if (all(active_counts == 1L)) { + # If all dominoes have exactly one placement left we have our solution + return(eliminated) + } + + # Minimum Remaining Values (MRV) + # Branch on domino with fewest remaining candidates (>= 2) + unresolved <- which(active_counts >= 2L) + d <- unresolved[which.min(active_counts[unresolved])] + pids <- domino_pids[[d]] + candidates <- pids[!eliminated[pids]] + + for (pid in candidates) { + result <- search_dominosa( + assign_placement(pid, eliminated, cell_pids, domino_pids, pl_cell1, pl_cell2, pl_did), + cell_pids, + domino_pids, + pl_cell1, + pl_cell2, + pl_did, + n_cells, + n_dom + ) + if (!is.null(result)) return(result) + } + NULL +} + +#' Solve Dominosa puzzle +#' +#' Solves a Dominosa (Domino Solitaire) puzzle given a grid of pip values. +#' +#' @param pips A matrix of non-negative integer pip values, +#' or a string with rows of integers separated by `"/"`. +#' For a double-`n` domino set the grid must have `(n + 1)(n + 2)` cells +#' and each pip value `0`:`n` must appear exactly `n + 2` times. +#' @return A list with components: +#' \describe{ +#' \item{`domino_ids`}{An integer matrix of the same dimensions as `pips` +#' where cells belonging to the same domino share the same integer value.} +#' \item{`pips`}{The input `pips` matrix.} +#' \item{`ppn`}{A string of Portable Piecepack Notation for the solution.} +#' } +#' @seealso and +#' for more information about Dominosa. +#' @examples +#' pips <- matrix(c(0, 1, 0, 1, 3, +#' 3, 1, 0, 2, 2, +#' 3, 2, 1, 0, 3, +#' 2, 3, 1, 0, 2), nrow = 4L, byrow = TRUE) +#' s <- solve_dominosa(pips) +#' if (rlang::is_installed(c("piecepackr", "ppn"))) { +#' g <- ppn::read_ppn(textConnection(s$ppn))[[1]] +#' envir <- piecepackr::game_systems(round = TRUE) +#' ppn::plot_move(g, open_device = FALSE, annotate = FALSE, envir = envir, scale = 0.95) +#' } +#' @export +solve_dominosa <- function(pips) { + pips <- parse_dominosa_pips(pips) + validate_dominosa_pips(pips) + + n <- max(pips) + n_rows <- nrow(pips) + n_cols <- ncol(pips) + n_cells <- n_rows * n_cols + n_dom <- ((n + 1L) * (n + 2L)) %/% 2L + + pl <- build_dominosa_placements(pips, n_rows, n_cols, n) + pl_cell1 <- pl$cell1 + pl_cell2 <- pl$cell2 + pl_did <- pl$did + n_pl <- length(pl_did) + + cell_pids <- lapply(seq_len(n_cells), function(ci) which(pl_cell1 == ci | pl_cell2 == ci)) + domino_pids <- lapply(seq_len(n_dom), function(d) which(pl_did == d)) + + result <- search_dominosa( + rep(FALSE, n_pl), + cell_pids, + domino_pids, + pl_cell1, + pl_cell2, + pl_did, + n_cells, + n_dom + ) + + if (is.null(result)) { + abort("No solution exists for this Dominosa puzzle.") + } + + dom_ids <- matrix(0L, nrow = n_rows, ncol = n_cols) + for (d in seq_len(n_dom)) { + pids <- domino_pids[[d]] + pid <- pids[!result[pids]] + for (cell in c(pl_cell1[pid], pl_cell2[pid])) { + r <- (cell - 1L) %/% n_cols + 1L + cc <- (cell - 1L) %% n_cols + 1L + dom_ids[r, cc] <- as.integer(d) + } + } + + sol <- list(domino_ids = dom_ids, pips = pips) + sol$ppn <- dominosa2ppn(sol) + sol +} + +dominosa2ppn <- function(sol) { + pips <- sol$pips + dom_ids <- sol$domino_ids + y_max <- nrow(pips) + n_dom <- max(dom_ids) + + pieces <- character(n_dom) + for (i in seq_len(n_dom)) { + cells <- which(dom_ids == i, arr.ind = TRUE) + r1 <- cells[1L, 1L] + c1 <- cells[1L, 2L] + r2 <- cells[2L, 1L] + c2 <- cells[2L, 2L] + p1 <- pips[r1, c1] + p2 <- pips[r2, c2] + if (r1 == r2) { + # Horizontal with `<` (90° CCW): 1st number appears on LEFT, 2nd on RIGHT. + x <- c1 + 0.5 + y <- y_max + 1L - r1 + rotation <- "<" + } else { + # Vertical (0°): 1st number appears on TOP, 2nd on BOTTOM. + x <- c1 + y <- y_max + 0.5 - r1 + rotation <- "" + } + pieces[i] <- str_glue("`{p1}-{p2}'{rotation}@({x},{y})") + } + + paste0( + "---\nGameType: Dominosa\nSetUp: None\n...\n", + str_glue("Solution. {paste(pieces, collapse = ' ')}\n") + ) +} diff --git a/R/fujisan.R b/R/fujisan.R index 511a130..9ab8fe3 100644 --- a/R/fujisan.R +++ b/R/fujisan.R @@ -128,8 +128,8 @@ path2movetext <- function(p) { } p <- stringr::str_split(p, "_") p <- lapply(p, n2alg) - movetext <- character(length(p) - 1) - for (ii in seq(length(p) - 1)) { + movetext <- character(length(p) - 1L) + for (ii in seq_len(length(p) - 1L)) { b <- p[[ii]] a <- p[[ii + 1]] i <- intersect(b, a) @@ -149,7 +149,7 @@ path2counter_intuitive <- function(p) { p <- stringr::str_split(p, "_") p <- lapply(p, n2alg) n_counter_intuitive <- 0 - for (ii in seq(length(p) - 1)) { + for (ii in seq_len(length(p) - 1L)) { b <- p[[ii]] a <- p[[ii + 1]] i <- intersect(b, a) @@ -180,6 +180,45 @@ alg2level <- function(alg) { ) } +parse_fujisan_pawns <- function(pawns) { + rows <- strsplit(pawns, "/")[[1]] + if (length(rows) != 2L) { + abort(str_glue( + "The `pawns` string must have exactly one '/' separator but got: {sQuote(pawns)}" + )) + } + pos1 <- parse_fujisan_pawn_row(rows[1L], 1L, pawns) + pos2 <- parse_fujisan_pawn_row(rows[2L], 2L, pawns) + all_pos <- c(pos1, pos2) + if (length(all_pos) != 4L) { + abort(str_glue( + "The `pawns` string must contain exactly 4 pawns but got {length(all_pos)}: {sQuote(pawns)}" + )) + } + all_pos +} + +parse_fujisan_pawn_row <- function(row_str, row_num, pawns) { + tokens <- regmatches(row_str, gregexpr("[A-Z]|[0-9]+", row_str))[[1]] + positions <- integer(0) + col <- 1L + for (tok in tokens) { + if (grepl("^[0-9]+$", tok)) { + col <- col + as.integer(tok) + } else { + offset <- if (row_num == 1L) 0L else 14L + positions <- c(positions, offset + col) + col <- col + 1L + } + } + if (col != 15L) { + abort(str_glue( + "Row {row_num} of pawns string {sQuote(pawns)} covers {col - 1L} columns but must cover exactly 14" + )) + } + positions +} + coins2string <- function(coins, sep = "/") { coins <- c(coins[1, ], coins[2, ]) coins <- as.character(coins) @@ -205,12 +244,22 @@ dice2ppn <- function(coins, dice) { } } +pawns2ppn <- function(pawns) { + if (is.null(pawns) || pawns == "S12M/A12C") { + "" + } else { + str_glue('\n Pawns: "{pawns}"', pawns = pawns) + } +} + sol2ppn <- function(sol) { movetext <- paste(path2movetext(sol$shortest_path), collapse = "\n") + is_default_pawns <- is.null(sol$pawn_string) || sol$pawn_string == "S12M/A12C" metadata <- str_glue( - '---\nGameType:\n Name: Fujisan\n Coins: "{coins}"{dice}\n...', + '---\nGameType:\n Name: Fujisan\n Coins: "{coins}"{dice}{pawns}\n...', coins = coins2string(sol$coins, "/"), - dice = dice2ppn(sol$coins, sol$dice) + dice = if (is_default_pawns) dice2ppn(sol$coins, sol$dice) else "", + pawns = pawns2ppn(sol$pawn_string) ) paste0(metadata, "\n", movetext, "\n") } @@ -235,31 +284,35 @@ first_move_needs_dice <- function(coins) { #' Solves a game of Fujisan (if possible). #' @param coins A vector or matrix of Fujisan coin layout. Default is a random layout. #' @param dice A vector of Fujisan dice layout. Default is random dice. Usually not needed. +#' @param pawns A FEN-like string of the pawns position. The four pawns `S`, `M`, `C`, and +#' `A` are represented by their letter and empty spaces by a number. The two rows are +#' separated by `/`. Default is `"S12M/A12C"` (all pawns at starting corners). #' @return A list with solution of Fujisan solution, its length, coin layout, dice (if needed), -#' and portable piecepack notation. -#' @rdname game_solvers +#' pawn position string, and portable piecepack notation. #' @examples #' puzzle2 <- matrix(c(4, 4, 4, 5, 2, 0, 2, 4, 0, 3, 1, 1, #' 1, 2, 5, 3, 3, 5, 3, 2, 5, 1, 0, 0), nrow = 2, byrow = TRUE) -#' s2 <- solve_fujisan(coins = puzzle2) -#' if (rlang::is_installed(c("piecepackr", "ppn"))) { -#' g2 <- ppn::read_ppn(textConnection(s2$ppn))[[1]] -#' ppn::plot_move(g2) -#' } +#' s <- solve_fujisan(coins = puzzle2) +#' print(s$shortest_distance) # minimum number of moves to solve game #' @export -solve_fujisan <- function(coins = random_fujisan_coins(), dice = random_dice() - 1) { +solve_fujisan <- function( + coins = random_fujisan_coins(), + dice = random_dice() - 1, + pawns = "S12M/A12C" +) { rlang::check_installed("igraph") if (is.vector(coins)) { coins <- process_ranks(coins) - 1 coins <- matrix(coins, nrow = 2, byrow = TRUE) } dice <- process_ranks(dice) - 1 + initial_state <- state2string(parse_fujisan_pawns(pawns)) edges <- do.call(rbind, apply(get_states(), 2, states2edges, coins, dice)) g <- igraph::graph_from_edgelist(edges, directed = TRUE) te <- try( { - initial <- igraph::V(g)["1_14_15_28"] + initial <- igraph::V(g)[initial_state] final <- igraph::V(g)["7_8_21_22"] d <- igraph::distances(g, v = initial, to = final, mode = "out") d <- as.integer(d) @@ -272,7 +325,8 @@ solve_fujisan <- function(coins = random_fujisan_coins(), dice = random_dice() - } else { p <- names(igraph::shortest_paths(g, from = initial, to = final)$vpath[[1]]) } - if (!first_move_needs_dice(coins)) { + is_default_pawns <- initial_state == "1_14_15_28" + if (!is_default_pawns || !first_move_needs_dice(coins)) { dice <- NA_integer_ } sol <- list( @@ -282,6 +336,7 @@ solve_fujisan <- function(coins = random_fujisan_coins(), dice = random_dice() - dice = dice, coin_string = coins2string(coins), dice_string = dice2string(dice), + pawn_string = pawns, n_counter_intuitive = path2counter_intuitive(p) ) sol$ppn <- sol2ppn(sol) diff --git a/README.Rmd b/README.Rmd index 67ee9f9..a66bebf 100644 --- a/README.Rmd +++ b/README.Rmd @@ -13,9 +13,10 @@ ## Overview -* Currently this package only provides a [Fuji-san](https://www.ludism.org/ppwiki/Fuji-san) solver `solve_fujisan()` which can compute the shortest solution (if it exists) to a given Fuji-san puzzle and output the PPN text to record/visualize the solution. -* In the future it may provide computer players for other board games and/or puzzles. -* This is an extraction and refinement of functionality originally contained in the experimental [{ppgames}](https://www.github.com/piecepackr/ppgames) package. +* Currently this package only provides the following solvers: + + * `solve_dominosa()` which computes a solution (if it exists) to a given [Dominosa](https://www.solitairelaboratory.com/puzzlelaboratory/DominoGG.html). + * `solve_fujisan()` which can compute the shortest solution (if it exists) to a given [Fuji-san](https://www.ludism.org/ppwiki/Fuji-san) puzzle and output the PPN text to record/visualize the solution. ## Installation @@ -25,6 +26,27 @@ remotes::install_github("piecepackr/ppgamer") ## Examples +```{r hidden, echo = FALSE} +knitr::opts_chunk$set(fig.path = "man/figures/README-", fig.cap = '') +``` + +```{r dominosa, fig.width = 9, fig.height = 8, fig.alt = "Solution to a Dominosa puzzle"} +library("ppgamer") +library("ppn") # `remotes::install_github("piecepackr/ppn")` +pips <- matrix(c(2, 5, 1, 6, 6, 4, 3, 5, + 0, 1, 3, 3, 0, 2, 6, 6, + 0, 3, 4, 5, 0, 4, 3, 0, + 0, 2, 6, 1, 3, 5, 4, 0, + 3, 6, 5, 5, 4, 5, 4, 1, + 1, 2, 4, 6, 0, 6, 2, 2, + 4, 3, 2, 2, 1, 1, 1, 5 + ), nrow = 7, byrow = TRUE) +s <- solve_dominosa(pips = pips) +game <- read_ppn(textConnection(s$ppn))[[1]] +envir <- piecepackr::game_systems(round = TRUE) +plot_move(game, open_device = FALSE, annotate = FALSE, envir = envir, scale = 0.95) +``` + ```r library("igraph") library("piecepackr") @@ -41,7 +63,7 @@ piecepack_suits <- list(suit_text="\U0001f31e,\U0001f31c,\U0001f451,\u269c,\uaa5 suit_fontfamily="Noto Emoji,Noto Sans Symbols2,Noto Emoji,Noto Sans Symbols,Noto Sans Cham", suit_cex="0.6,0.7,0.75,0.9,0.9") traditional_ranks <- list(use_suit_as_ace=TRUE, rank_text=",a,2,3,4,5") -cfg3d <- list(width.pawn=0.75, height.pawn=0.75, depth.pawn=0.375, +cfg3d <- list(width.pawn=0.75, height.pawn=0.75, depth.pawn=0.375, dm_text.pawn="", shape.pawn="convex6", invert_colors.pawn=TRUE, edge_color.coin="tan", edge_color.tile="tan") cfg <- pp_cfg(c(piecepack_suits, dark_colorscheme, traditional_ranks, cfg3d)) @@ -49,7 +71,7 @@ cfg <- pp_cfg(c(piecepack_suits, dark_colorscheme, traditional_ranks, cfg3d)) animate_game(game, op_scale=1, op_angle=90, trans=op_transform, cfg=cfg, file="fujisan.gif") ``` -![Animation of a Fuji-san game](https://www.trevorldavis.com/piecepackr/images/knitr/fujisan.gif) +Animation of a Fuji-san game ## Related links diff --git a/README.md b/README.md index 719136f..24d0a0e 100644 --- a/README.md +++ b/README.md @@ -13,19 +13,42 @@ ## Overview -* Currently this package only provides a [Fuji-san](https://www.ludism.org/ppwiki/Fuji-san) solver `solve_fujisan()` which can compute the shortest solution (if it exists) to a given Fuji-san puzzle and output the PPN text to record/visualize the solution. -* In the future it may provide computer players for other board games and/or puzzles. -* This is an extraction and refinement of functionality originally contained in the experimental [{ppgames}](https://www.github.com/piecepackr/ppgames) package. +* Currently this package only provides the following solvers: + + * `solve_dominosa()` which computes a solution (if it exists) to a given [Dominosa](https://www.solitairelaboratory.com/puzzlelaboratory/DominoGG.html). + * `solve_fujisan()` which can compute the shortest solution (if it exists) to a given [Fuji-san](https://www.ludism.org/ppwiki/Fuji-san) puzzle and output the PPN text to record/visualize the solution. ## Installation -```r +``` r remotes::install_github("piecepackr/ppgamer") ``` ## Examples + + + +``` r +library("ppgamer") +library("ppn") # `remotes::install_github("piecepackr/ppn")` +pips <- matrix(c(2, 5, 1, 6, 6, 4, 3, 5, + 0, 1, 3, 3, 0, 2, 6, 6, + 0, 3, 4, 5, 0, 4, 3, 0, + 0, 2, 6, 1, 3, 5, 4, 0, + 3, 6, 5, 5, 4, 5, 4, 1, + 1, 2, 4, 6, 0, 6, 2, 2, + 4, 3, 2, 2, 1, 1, 1, 5 + ), nrow = 7, byrow = TRUE) +s <- solve_dominosa(pips = pips) +game <- read_ppn(textConnection(s$ppn))[[1]] +envir <- piecepackr::game_systems(round = TRUE) +plot_move(game, open_device = FALSE, annotate = FALSE, envir = envir, scale = 0.95) +``` + +Solution to a Dominosa puzzle + ```r library("igraph") library("piecepackr") @@ -42,7 +65,7 @@ piecepack_suits <- list(suit_text="\U0001f31e,\U0001f31c,\U0001f451,\u269c,\uaa5 suit_fontfamily="Noto Emoji,Noto Sans Symbols2,Noto Emoji,Noto Sans Symbols,Noto Sans Cham", suit_cex="0.6,0.7,0.75,0.9,0.9") traditional_ranks <- list(use_suit_as_ace=TRUE, rank_text=",a,2,3,4,5") -cfg3d <- list(width.pawn=0.75, height.pawn=0.75, depth.pawn=0.375, +cfg3d <- list(width.pawn=0.75, height.pawn=0.75, depth.pawn=0.375, dm_text.pawn="", shape.pawn="convex6", invert_colors.pawn=TRUE, edge_color.coin="tan", edge_color.tile="tan") cfg <- pp_cfg(c(piecepack_suits, dark_colorscheme, traditional_ranks, cfg3d)) @@ -50,7 +73,7 @@ cfg <- pp_cfg(c(piecepack_suits, dark_colorscheme, traditional_ranks, cfg3d)) animate_game(game, op_scale=1, op_angle=90, trans=op_transform, cfg=cfg, file="fujisan.gif") ``` -![Animation of a Fuji-san game](https://www.trevorldavis.com/piecepackr/images/knitr/fujisan.gif) +Animation of a Fuji-san game ## Related links diff --git a/_pkgdown.yml b/_pkgdown.yml index 2ead74d..66ac3eb 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -8,4 +8,5 @@ reference: - title: "Piecepack puzzle solvers" desc: "Functions to solve puzzles" contents: + - solve_dominosa - solve_fujisan diff --git a/man/figures/README-dominosa-1.png b/man/figures/README-dominosa-1.png new file mode 100644 index 0000000..5f850d6 Binary files /dev/null and b/man/figures/README-dominosa-1.png differ diff --git a/man/solve_dominosa.Rd b/man/solve_dominosa.Rd new file mode 100644 index 0000000..2d0f6d3 --- /dev/null +++ b/man/solve_dominosa.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/dominosa.R +\name{solve_dominosa} +\alias{solve_dominosa} +\title{Solve Dominosa puzzle} +\usage{ +solve_dominosa(pips) +} +\arguments{ +\item{pips}{A matrix of non-negative integer pip values, +or a string with rows of integers separated by \code{"/"}. +For a double-\code{n} domino set the grid must have \code{(n + 1)(n + 2)} cells +and each pip value \code{0}:\code{n} must appear exactly \code{n + 2} times.} +} +\value{ +A list with components: +\describe{ +\item{\code{domino_ids}}{An integer matrix of the same dimensions as \code{pips} +where cells belonging to the same domino share the same integer value.} +\item{\code{pips}}{The input \code{pips} matrix.} +\item{\code{ppn}}{A string of Portable Piecepack Notation for the solution.} +} +} +\description{ +Solves a Dominosa (Domino Solitaire) puzzle given a grid of pip values. +} +\examples{ +pips <- matrix(c(0, 1, 0, 1, 3, + 3, 1, 0, 2, 2, + 3, 2, 1, 0, 3, + 2, 3, 1, 0, 2), nrow = 4L, byrow = TRUE) +s <- solve_dominosa(pips) +if (rlang::is_installed(c("piecepackr", "ppn"))) { + g <- ppn::read_ppn(textConnection(s$ppn))[[1]] + envir <- piecepackr::game_systems(round = TRUE) + ppn::plot_move(g, open_device = FALSE, annotate = FALSE, envir = envir, scale = 0.95) +} +} +\seealso{ +\url{https://www.solitairelaboratory.com/puzzlelaboratory/DominoGG.html} and +\url{https://puzzlebreaks.com/dominosa/} for more information about Dominosa. +} diff --git a/man/game_solvers.Rd b/man/solve_fujisan.Rd similarity index 55% rename from man/game_solvers.Rd rename to man/solve_fujisan.Rd index 19f1ca4..875ba78 100644 --- a/man/game_solvers.Rd +++ b/man/solve_fujisan.Rd @@ -4,16 +4,24 @@ \alias{solve_fujisan} \title{Solve Fujisan game} \usage{ -solve_fujisan(coins = random_fujisan_coins(), dice = random_dice() - 1) +solve_fujisan( + coins = random_fujisan_coins(), + dice = random_dice() - 1, + pawns = "S12M/A12C" +) } \arguments{ \item{coins}{A vector or matrix of Fujisan coin layout. Default is a random layout.} \item{dice}{A vector of Fujisan dice layout. Default is random dice. Usually not needed.} + +\item{pawns}{A FEN-like string of the pawns position. The four pawns \code{S}, \code{M}, \code{C}, and +\code{A} are represented by their letter and empty spaces by a number. The two rows are +separated by \code{/}. Default is \code{"S12M/A12C"} (all pawns at starting corners).} } \value{ A list with solution of Fujisan solution, its length, coin layout, dice (if needed), -and portable piecepack notation. +pawn position string, and portable piecepack notation. } \description{ Solves a game of Fujisan (if possible). @@ -21,9 +29,6 @@ Solves a game of Fujisan (if possible). \examples{ puzzle2 <- matrix(c(4, 4, 4, 5, 2, 0, 2, 4, 0, 3, 1, 1, 1, 2, 5, 3, 3, 5, 3, 2, 5, 1, 0, 0), nrow = 2, byrow = TRUE) - s2 <- solve_fujisan(coins = puzzle2) - if (rlang::is_installed(c("piecepackr", "ppn"))) { - g2 <- ppn::read_ppn(textConnection(s2$ppn))[[1]] - ppn::plot_move(g2) - } + s <- solve_fujisan(coins = puzzle2) + print(s$shortest_distance) # minimum number of moves to solve game } diff --git a/tests/testthat/_snaps/dominosa.md b/tests/testthat/_snaps/dominosa.md new file mode 100644 index 0000000..045a5c3 --- /dev/null +++ b/tests/testthat/_snaps/dominosa.md @@ -0,0 +1,63 @@ +# solve_dominosa() works as expected + + Code + cat(s1$ppn) + Output + --- + GameType: Dominosa + SetUp: None + ... + Solution. `0-0'<@(1.5,2) `1-0'<@(1.5,1) `1-1'@(3,1.5) + +--- + + Code + ppn::cat_move(g1, move = "Solution.", color = FALSE) + Output + ┌───┬─┐ + │ ┃ │·│ + ├───┤━│ + │·┃ │·│ + └───┴─┘ + + +# solve_dominosa() errors on invalid input + + Code + solve_dominosa(matrix(c(0L, 0L, 1L, 1L), nrow = 1L)) + Condition + Error in `validate_dominosa_pips()`: + ! For a double-1 domino set the grid must have 6 cells, but `pips` has 4 cells. + +--- + + Code + solve_dominosa(matrix(c(1L, 1L, 1L, 1L, 0L, 0L), nrow = 2L, byrow = TRUE)) + Condition + Error in `validate_dominosa_pips()`: + ! For a double-1 domino set each pip value must appear exactly 3 time(s). The following pip values have incorrect counts: 0, 1. + +--- + + Code + solve_dominosa("010/101") + Condition + Error in `solve_dominosa()`: + ! No solution exists for this Dominosa puzzle. + +--- + + Code + solve_dominosa("0101/10") + Condition + Error in `parse_dominosa_pips()`: + ! All rows in `pips` must have the same length. + +--- + + Code + solve_dominosa(as.data.frame(pips1)) + Condition + Error in `parse_dominosa_pips()`: + ! `pips` must be a matrix or character string, not data.frame. + diff --git a/tests/testthat/_snaps/fujisan.md b/tests/testthat/_snaps/fujisan.md index 2615811..78dbd93 100644 --- a/tests/testthat/_snaps/fujisan.md +++ b/tests/testthat/_snaps/fujisan.md @@ -1,3 +1,35 @@ +# parse_fujisan_pawns() works as expected + + Code + parse_fujisan_pawns("S12M") + Condition + Error in `parse_fujisan_pawns()`: + ! The `pawns` string must have exactly one '/' separator but got: 'S12M' + +--- + + Code + parse_fujisan_pawns("S12M/A11C") + Condition + Error in `parse_fujisan_pawn_row()`: + ! Row 2 of pawns string 'S12M/A11C' covers 13 columns but must cover exactly 14 + +--- + + Code + parse_fujisan_pawns("S13M/A12C") + Condition + Error in `parse_fujisan_pawn_row()`: + ! Row 1 of pawns string 'S13M/A12C' covers 15 columns but must cover exactly 14 + +--- + + Code + parse_fujisan_pawns("S13/A12C") + Condition + Error in `parse_fujisan_pawns()`: + ! The `pawns` string must contain exactly 4 pawns but got 3: 'S13/A12C' + # fujisan solver works as expected Code diff --git a/tests/testthat/test-dominosa.R b/tests/testthat/test-dominosa.R new file mode 100644 index 0000000..5fcde52 --- /dev/null +++ b/tests/testthat/test-dominosa.R @@ -0,0 +1,100 @@ +test_that("solve_dominosa() works as expected", { + # double-0: trivial single domino + pips0 <- matrix(c(0L, 0L), nrow = 1L) + s0 <- solve_dominosa(pips0) + expect_equal(s0$domino_ids, matrix(c(1L, 1L), nrow = 1L)) + + # double-1: 2x3 grid + # fmt: skip + pips1 <- matrix(c( + 0L, 0L, 1L, + 1L, 0L, 1L + ), nrow = 2L, byrow = TRUE) + s1 <- solve_dominosa(pips1) + expect_equal( + s1$domino_ids, + # fmt: skip + matrix(c( + 1L, 1L, 3L, + 2L, 2L, 3L + ), nrow = 2L, byrow = TRUE) + ) + + # string input equivalent to pips1 + expect_equal(solve_dominosa("001/101")$domino_ids, s1$domino_ids) + + # ppn output + expect_snapshot(cat(s1$ppn)) + + skip_if_not_installed("ppn") + skip_if_not_installed("ppcli") + skip_on_os("windows") + g1 <- ppn::read_ppn(textConnection(s1$ppn))[[1]] + expect_snapshot(ppn::cat_move(g1, move = "Solution.", color = FALSE)) + + # double-2: 3x4 grid + # fmt: skip + pips2 <- matrix(c( + 0L, 0L, 2L, 2L, + 0L, 1L, 2L, 0L, + 1L, 1L, 1L, 2L + ), nrow = 3L, byrow = TRUE) + s2 <- solve_dominosa(pips2) + # Verify all 6 domino types present and each pip pair is valid + expect_setequal(as.vector(s2$domino_ids), 1:6) + for (d in 1:6) { + cells <- which(s2$domino_ids == d, arr.ind = TRUE) + expect_equal(nrow(cells), 2L) + p <- sort(c(pips2[cells[1, 1], cells[1, 2]], pips2[cells[2, 1], cells[2, 2]])) + expected_pip <- switch( + d, + `1` = c(0L, 0L), + `2` = c(0L, 1L), + `3` = c(0L, 2L), + `4` = c(1L, 1L), + `5` = c(1L, 2L), + `6` = c(2L, 2L) + ) + expect_equal(p, expected_pip) + } +}) + +test_that("solve_dominosa() errors on invalid input", { + # Wrong grid size + expect_snapshot( + error = TRUE, + solve_dominosa(matrix(c(0L, 0L, 1L, 1L), nrow = 1L)) + ) + # Wrong pip distribution: pip 0 appears 2 times, pip 1 appears 4 times + expect_snapshot( + error = TRUE, + solve_dominosa(matrix(c(1L, 1L, 1L, 1L, 0L, 0L), nrow = 2L, byrow = TRUE)) + ) + # Valid distribution but no solution exists + expect_snapshot( + error = TRUE, + solve_dominosa("010/101") + ) + # Unbalanced strings + expect_snapshot( + error = TRUE, + solve_dominosa("0101/10") + ) + # Wrong type + pips1 <- matrix( + c( + 0L, + 0L, + 1L, + 1L, + 0L, + 1L + ), + nrow = 2L, + byrow = TRUE + ) + expect_snapshot( + error = TRUE, + solve_dominosa(as.data.frame(pips1)) + ) +}) diff --git a/tests/testthat/test-fujisan.R b/tests/testthat/test-fujisan.R index f88b596..b672e81 100644 --- a/tests/testthat/test-fujisan.R +++ b/tests/testthat/test-fujisan.R @@ -1,3 +1,14 @@ +test_that("parse_fujisan_pawns() works as expected", { + expect_equal(parse_fujisan_pawns("S12M/A12C"), c(1L, 14L, 15L, 28L)) + expect_equal(parse_fujisan_pawns("6SM6/6AC6"), c(7L, 8L, 21L, 22L)) + expect_equal(parse_fujisan_pawns("S12S/A12A"), c(1L, 14L, 15L, 28L)) + expect_equal(parse_fujisan_pawns("6PP6/6PP6"), c(7L, 8L, 21L, 22L)) + expect_snapshot(error = TRUE, parse_fujisan_pawns("S12M")) + expect_snapshot(error = TRUE, parse_fujisan_pawns("S12M/A11C")) + expect_snapshot(error = TRUE, parse_fujisan_pawns("S13M/A12C")) + expect_snapshot(error = TRUE, parse_fujisan_pawns("S13/A12C")) +}) + test_that("fujisan solver works as expected", { coins <- "235334140030554141221205" dice <- "0000" @@ -20,43 +31,27 @@ test_that("fujisan solver works as expected", { withr::local_seed(42) random_fujisan_coins() }, + # fmt: skip matrix( c( - 1L, - 2L, - 3L, - 1L, - 1L, - 3L, - 0L, - 3L, - 5L, - 4L, - 0L, - 2L, - 2L, - 4L, - 4L, - 1L, - 0L, - 3L, - 4L, - 5L, - 0L, - 5L, - 5L, - 2L + 1L, 2L, 3L, 1L, 1L, 3L, 0L, 3L, 5L, 4L, 0L, 2L, + 2L, 4L, 4L, 1L, 0L, 3L, 4L, 5L, 0L, 5L, 5L, 2L ), nrow = 2L ) ) puzzle2 <- matrix( - c(4, 4, 4, 5, 2, 0, 2, 4, 0, 3, 1, 1, 1, 2, 5, 3, 3, 5, 3, 2, 5, 1, 0, 0), + # fmt: skip + c( + 4, 4, 4, 5, 2, 0, 2, 4, 0, 3, 1, 1, + 1, 2, 5, 3, 3, 5, 3, 2, 5, 1, 0, 0 + ), nrow = 2, byrow = TRUE ) s2 <- solve_fujisan(coins = puzzle2) + expect_equal(solve_fujisan(coins = puzzle2, pawns = "6SM6/6AC6")$shortest_distance, 0L) g2 <- ppn::read_ppn(textConnection(s2$ppn))[[1]] expect_snapshot(ppn::cat_move(g2, move = "SetupFn.", color = FALSE))