Блог

Предположим, у меня есть следующая строка:

 answer = " abcd~"
  

и следующие головоломки: * кусочки головоломки просто состоят из всех букв, расположенных рядом.

 > puzzle_df
   a ab bc cd d~
1  1  1  1  1  1

> dput(puzzle_df)
structure(list(` a` = 1, ab = 1, bc = 1, cd = 1, `d~` = 1), row.names = 1L, class = "data.frame")
  

Здесь имена столбцов фрейма данных: a, ab, bc, cd и d~ представляют части головоломки.

Используя кусочки головоломки (и количество кусочков каждой головоломки, указанное в строке 1), если на основе правил (указанных в конце) можно построить ТОЛЬКО 1 возможный ответ, то головоломка разрешима.

Мой вопрос: как я могу написать алгоритм, который может создавать все возможные комбинации, соблюдая все правила? Это потому, что если количество выходных комбинаций больше 1, то я знаю, что головоломка неразрешима; в противном случае она разрешима.

Здесь строка » abcd ~» имеет только 1 возможный результат с этими частями головоломки (разрешимый), в то время как строка » aabbabcd ~» имеет 2 возможных результата (неразрешимый — другая возможная комбинация — abaabbcd).

** Правила:

1. символ » » представляет начало строки, а «~» представляет конец строки.
2. начальная буква части головоломки должна иметь ту же букву, что и конечная буква предыдущей части головоломки. Например, «ab» может соединяться только с любыми другими частями головоломки с буквой «b» в начале, например, «bc».

Отредактировано для комментариев:

для строки " aabbabcd~" таблица кусочков головоломки должна быть:

    a aa ab ba bb bc cd d~
   1  1  2  1  1  1  1  1
  

Теперь, используя эти кусочки головоломки и соответствующее им количество, две возможные комбинации:

1. aabbabcd ~
2. abaabbcd ~

Поскольку существует 2 возможных комбинации, это неразрешимо.

Это своего рода метод грубой силы для решения проблемы. Я подозреваю, что кто-то придумает более элегантное решение, но до тех пор, вот что я бы сделал.

Сначала определите части и количество каждой части, которые у вас есть, а затем постройте вектор, содержащий все соответствующие части.

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

Затем вы можете использовать permutations() функцию from gtools , чтобы выполнить все перестановки ваших фигур. Если вы используете set=FALSE , он не удалит повторяющиеся фрагменты, чего вы и хотите.

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

Далее, вы можете отфильтровать только те случаи, когда соответствующие фрагменты начинают и заканчивают последовательность:

 perms <- perms %>% filter(V1 == " a" amp; V9 == "d~")
  

Затем вы могли бы создавать небольшие функции, которые немного упрощают поиск первого и последнего символов.

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

Затем вы можете инициализировать объект, который определяет, следует ли пара смежных столбцов правилу. Затем вы можете перебирать столбцы, чтобы определить следующие пары правил:

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

Затем определите все строки, в которых все пары соответствуют правилам:

 all_true <- apply(follow, 1, all)
  

Наконец, вы можете посмотреть на решения для тех, которые всегда следуют правилам.

 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~```

  

Если вы только хотели узнать количество раз с подходящим решением, вы могли бы просто суммировать all_true вектор:

 sum(all_true)
# [1] 8
  

РЕДАКТИРОВАТЬ: написал функцию для работы с большими входными данными.

Приведенная ниже функция строит решение последовательно, каждый раз ища оставшиеся части, которые соответствуют правилам. Это намного быстрее и, несмотря на гораздо больший объем кода, ближе к более элегантному решению, которое, как я предполагал, кто-то напишет выше.

 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 Solutionn")
    }
    # 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