Puzzle Algorithm showing all possible combination in r

Question

This is a sort of brute force way of solving the problem. I suspect someone will come up with a more elegant solution, but until then, here’s what I would do.

First, define the pieces and the number of each piece you have, and then build a vector that has all of the relevant pieces.

puzzle <- c("+a", "aa", "ab", "ba", "bb", "bc", "cd", "d~")
npieces <- c(1,1,2,1,1,1,1,1)
puzzle <- rep(puzzle, npieces)

Next, you can use the permutations() function from gtools to make all of the permutations of your pieces. If you use set=FALSE, it will not delete duplicate pieces, which is what you want.

perms <- gtools::permutations(n=length(puzzle), 
                              r=length(puzzle), 
                              v=puzzle, 
                              set=FALSE) %>% 
  as.data.frame

Next, you can filter down to only those cases where the appropriate pieces start and end the sequence:

perms <- perms %>% filter(V1 == "+a" & V9 == "d~")

Then, you could build little functions that make finding the first and last characters a bit easier.

last_char <- function(x)substr(x, (nchar(x)), nchar(x))
first_char <- function(x)substr(x, 1, 1)

Then you could initialize an object that identifies whether a pair of adjacent columns follows the rule. You could then loop over the columns to identify rule following pairs:

follow <- NULL
for(i in 1:(ncol(perms)-1)){
  follow <- cbind(follow, last_char(perms[,i]) == first_char(perms[,(i+1)]))
}

Next, identify all of the rows where all pairs follow the rules:

all_true <- apply(follow, 1, all)

Finally, you can look at the solutions for those that always follow the rules.

perms[which(all_true), ]
#      V1 V2 V3 V4 V5 V6 V7 V8 V9
# 25   +a aa ab ba ab bb bc cd d~
# 55   +a aa ab bb ba ab bc cd d~
# 145  +a aa ab ba ab bb bc cd d~
# 175  +a aa ab bb ba ab bc cd d~
# 961  +a ab ba aa ab bb bc cd d~
# 1129 +a ab bb ba aa ab bc cd d~
# 1681 +a ab ba aa ab bb bc cd d~
# 1849 +a ab bb ba aa ab bc cd d~```

If you only wanted to know the number of times with an appropriate solution, you could just sum the all_true vector:

sum(all_true)
# [1] 8

EDIT: wrote a function to work with larger inputs.

The function below builds the solution sequentially, each time looking for remaining pieces that fit with the rules. This is much faster and, while much more code, is closer to the more elegant solution that I imagined someone would write above.

puzzle_solve <- function(puzzle){
  # define first and last character functions
  last_char <- function(x)substr(x, (nchar(x)), nchar(x))
  first_char <- function(x)substr(x, 1, 1)

  # pick the start and end of the puzzle
  start <- grep("^\\+", puzzle, value=TRUE)
  end <- grep("~$", puzzle, value=TRUE)
  # save the remaining pieces
  remains <- puzzle[-which(puzzle %in% c(start, end))]
  
  # find all of the matching remaining pieces for the first run
  ind <- which(last_char(start) == first_char(remains))
  # put matching pieces along side the existing starting piece. 
  used <- cbind(start, remains[ind])
  # for each row of used, find the remaining puzzle pieces. 
  remains <- t(apply(used[,-1, drop=FALSE], 1, function (x){
    out <- sapply(x, function(z)min(which(remains == z)))
    remains[-out]
  }))
  # continue until there are no remaining pieces. 
  while(length(remains) > 0){
    # find all of the matching remaining pieces for the first run
    ind <- lapply(1:nrow(used), function(i)remains[i, which(last_char(used[i, ncol(used)]) == first_char(remains[i,]))])
    # identify the lengths of all of the matching pices for each
    # row of the used matrix
    u <- rep(seq_along(ind), sapply(ind, length))
    # if there are no matching pieces for any row, identify that
    # no solution exists. 
    if(length(u) == 0){
      stop("No Solution\n")
    }
    # if solutions still exist
    else{
      # expand the remains matrix to match the new size of the used matrix
      remains <- remains[u, , drop=FALSE]
      # expand the used matrix 
      u <- used[u, , drop=FALSE]
      # add the puzzle pieces 
      used <- cbind(u, c(unlist(ind)))
      # find the remaining pieces
      remains <- lapply(1:nrow(used), function(i){
        out <- min(which(remains[i, ] == used[i,ncol(used)]))
        remains[i, -out]
      })
      # turn the remains list back into a matrix
      remains <- as.matrix(do.call(rbind, remains))
    }
  }
  # if there is a solutiuon, find the solutions that match up 
  # with the end piece
  
  used <- used[which(last_char(used[,ncol(used)]) == first_char(end)), , drop=FALSE]
  # attach end piece
  used <- cbind(used, rep(end, nrow(used)))
  colnames(used) <- NULL
  # return the result
  used <- as.data.frame(used)
  if(any(duplicated(used))){
    used <- used[-which(duplicated(used)), ]
  }
  return(used)
}

## With multiple solutions
puzzle <- c("+a", "aa", "ab", "ba", "bb", "bc", "cd", "d~")
npieces <- c(1,1,2,1,1,1,1,1)
puzzle <- rep(puzzle, npieces)

p <- puzzle_solve(puzzle)
p
#   V1 V2 V3 V4 V5 V6 V7 V8 V9
# 1 +a aa ab ba ab bb bc cd d~
# 2 +a aa ab bb ba ab bc cd d~
# 5 +a ab ba aa ab bb bc cd d~
# 6 +a ab bb ba aa ab bc cd d~

## With a single solution
puzzle <- c("+a", "ab", "bc", "cd", "d~")
npieces <- rep(1, length(puzzle))
puzzle <- rep(puzzle, npieces)
puzzle_solve(puzzle)
#   V1 V2 V3 V4 V5
# 1 +a ab bc cd d~
 
## With no solution 
puzzle <- c("+a", "aa", "ab", "ba", "bb", "bc", "cd", "d~")
npieces <- c(1,1,1,1,1,1,1,1)
puzzle <- rep(puzzle, npieces)
puzzle_solve(puzzle)
# Error in puzzle_solve(puzzle) : No Solution

Leave a Comment Cancel Reply