# Puzzle Algorithm showing all possible combination in r

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)
#  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]
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
``````