在 Haskell 上实现回溯

Question

我在 Haskell 上进行回溯时遇到问题，我知道如何执行递归函数，但是当我尝试获得多个解决方案或最佳解决方案（回溯）时遇到了麻烦。

有一个包含一些字符串的列表，然后我需要获取从一个字符串到另一个字符串的解决方案，从字符串中更改一个字母，我将获得列表、第一个字符串和最后一个字符串。如果有解决方案，则返回它执行的步骤数，如果没有解决方案，则返回-1。这是一个例子：

wordF ["spice","stick","smice","stock","slice","slick","stock"] "spice" "stock"

然后我有我的清单，我需要从 "spice" 开始，然后到达 "stock" 最好的解决方案是["spice","slice","slick","stick","stock"]，从"spice" 到"stock" 有四个步骤。然后它返回4。

另一种解决方案是["spice","smice","slice","slick","stick","stock"]，通过五个步骤到达"stock"，然后返回`5。但这是一个错误的解决方案，因为还有一个比这个步骤更少的更好的解决方案。

我在回溯以获得最佳解决方案时遇到了麻烦，因为我不知道如何让我的代码搜索另一个解决方案，而不是一个..

这是我尝试制作的代码，但出现了一些错误，顺便说一句，我不知道我的“制作”回溯方式是否良好，或者是否有一些我没有看到的错误..

  wordF :: [String] -> String -> String -> (String, String, Int)
  wordF [] a b = (a, b, -1)
  wordF list a b | (notElem a list || notElem b list) = (a, b, -1)
           | otherwise = (a, b, (wordF2 list a b [a] 0 (length list)))
  wordF2 :: [String] -> String -> String -> [String] -> Int -> Int -> Int
  wordF2 list a b list_aux cont maxi | (cont==maxi) = 1000
                               | (a==b) = length list_aux
                               | (a/=b) && (cont<maxi) && notElemFound && (checkin /= "ThisWRONG") && (wording1<=wording2) = wording1
                               | (a/=b) && (cont<maxi) && notElemFound && (checkin /= "ThisWRONG") && (wording1>wording2) = wording2
                               | (a/=b) && (checkin == "ThisWRONG") = wordF2 list a b list_aux (cont+1) maxi
                               where 
                               checkin = (check_word2 a (list!!cont) (list!!cont) 0)
                               wording1 = (wordF2 list checkin b (list_aux++[checkin]) 0 maxi)
                               wording2 = (wordF2 list checkin b (list_aux++[checkin]) 1 maxi)
                               notElemFound = ((any (==(list!!cont)) list_aux) == False)
 check_word2 :: String -> String -> String -> Int -> String
 check_word2 word1 word2 word3 dif | (dif > 1) = "ThisWRONG"
                              | ((length word1 == 1) && (length word2 == 1) && (head word1 == head word2)) = word3
                              | ((length word1 == 1) && (length word2 == 1) && (head word1 /= head word2) && (dif<1)) = word3
                              | ((head word1) == (head word2)) = check_word2 (tail word1) (tail word2) word3 dif
                              | otherwise = check_word2 (tail word1) (tail word2) word3 (dif+1)

我的第一个函数wordF2 获取列表、开始、结束、用于获取当前解决方案的辅助列表以及始终存在的第一个元素 ([a])、带有 0 的计数器，以及计数器的最大大小 (length list)..

第二个函数check_word2 检查一个词是否可以传递给另一个词，比如"spice" 到"slice"，如果它不能像"spice" 到"spoca" 它返回"ThisWRONG"。

此解决方案出现模式匹配失败的错误

  Program error: pattern match failure: wordF2 ["slice","slick"] "slice" "slick" ["slice"] 0 1

我尝试了一些小案例，什么都没有，我限制我在计数和最大值的列表中得到错误的位置。

或者我可能不知道如何在 haskell 上实现回溯以获得多个解决方案、最佳解决方案等。

更新：我做了一个解决方案，但它没有回溯

wordF :: [String] -> String -> String -> (String, String, Int)
wordF [] a b = (a, b, -1)
wordF list a b | (notElem a list || notElem b list) = (a, b, -1)
           | otherwise = (a, b, (wordF1 list a b))

wordF1 :: [String] -> String -> String -> Int
wordF1 list a b | ((map length (wordF2 (subconjuntos2 (subconjuntos list) a b))) == []) = -1
            | (calculo > 0) = calculo
            | otherwise = -1
             where
             calculo = (minimum (map length (wordF2 (subconjuntos2 (subconjuntos list) a b))))-1

wordF2 :: [[String]] -> [[String]]
wordF2 [[]] = []
wordF2 (x:xs) | ((length xs == 1) && ((check_word x) == True) && ((check_word (head xs)) == True)) = x:xs
          | ((length xs == 1) && ((check_word x) == False) && ((check_word (head xs)) == True)) = xs
          | ((length xs == 1) && ((check_word x) == True) && ((check_word (head xs)) == False)) = [x]
          | ((length xs == 1) && ((check_word x) == False) && ((check_word (head xs)) == False)) = []
          | ((check_word x) == True) = x:wordF2 xs
          | ((check_word x) == False ) = wordF2 xs

check_word :: [String] -> Bool
check_word [] = False
check_word (x:xs) | ((length xs == 1) && ((check_word2 x (head xs) 0) == True)) = True
              | ((length xs >1) && ((check_word2 x (head xs) 0) == True)) = True && (check_word xs)
              | otherwise = False 

check_word2 :: String -> String -> Int -> Bool
check_word2 word1 word2 dif | (dif > 1) = False
                        | ((length word1 == 1) && (length word2 == 1) && (head word1 == head word2)) = True
                        | ((length word1 == 1) && (length word2 == 1) && (head word1 /= head word2) && (dif<1)) = True
                        | ((head word1) == (head word2)) = check_word2 (tail word1) (tail word2) dif
                        | otherwise = check_word2 (tail word1) (tail word2) (dif+1)

subconjuntos2 :: [[String]] -> String -> String -> [[String]]
subconjuntos2 [] a b     = []
subconjuntos2 (x:xs) a b | (length x <= 1) = subconjuntos2 xs a b
                     | ((head x == a) && (last x == b)) = (x:subconjuntos2 xs a b)
                     | ((head x /= a) || (last x /= b)) = (subconjuntos2 xs a b)

subconjuntos :: [a] -> [[a]]
subconjuntos []     = [[]]
subconjuntos (x:xs) = [x:ys | ys <- sub] ++ sub
where sub = subconjuntos xs

嗯，可能是它效率低下，但至少它可以解决问题.. 我搜索所有可能的解决方案，我比较 head == "slice" 和 last == "stock"，然后过滤那些解决方案并打印较短的解决方案， 谢谢，如果你们有什么建议说出来:)

Answer 1

没有经过彻底测试，但希望这会有所帮助：

import Data.Function (on)
import Data.List (minimumBy, delete)
import Control.Monad (guard)

type Word = String
type Path = [String]

wordF :: [Word] -> Word -> Word -> Path
wordF words start end = 
    start : minimumBy (compare `on` length) (generatePaths words start end)

-- Use the list monad to do the nondeterminism and backtracking.
-- Returns a list of all paths that lead from `start` to `end` 
-- in steps that `differByOne`.
generatePaths :: [Word] -> Word -> Word -> [Path]
generatePaths words start end = do
  -- Choose one of the words, nondeterministically
  word <- words

  -- If the word doesn't `differByOne` from `start`, reject the choice
  -- and backtrack.
  guard $ differsByOne word start

  if word == end
  then return [word]
  else do 
        next <- generatePaths (delete word words) word end
        return $ word : next

differsByOne :: Word -> Word -> Bool
differsByOne "" "" = False
differsByOne (a:as) (b:bs) 
    | a == b = differsByOne as bs
    | otherwise = as == bs

示例运行：

>>> wordF ["spice","stick","smice","stock","slice","slick","stock"] "spice" "stock"
["spice","slice","slick","stick","stock"]

Haskell 中的 list monad 通常被描述为一种不确定的回溯计算形式。上面的代码所做的是允许 list monad 负责生成备选方案，测试它们是否满足标准，并在失败时回溯到最近的选择点。列表单子的绑定，例如word <- words，意思是“不确定地选择一个words。guard 意思是“如果到目前为止的选择不满足这个条件，则回溯并做出不同的选择。 list monad 计算的结果是所有不违反任何guards 的选择的结果列表。

如果这看起来像列表推导式，那么列表推导式与列表单子是一样的——我选择用单子而不是推导式来表达它。

Answer 2

最近发表了几篇关于经典蛮力搜索问题的文章。

• Mark Dominus 发布了a simple example of using lists 进行简单的详尽搜索。
• Justin Le 以a small modification 跟进了上一篇文章，该文章简化了对当前搜索状态的跟踪。
• 我跟进了a further modification，它可以衡量早期拒绝部分搜索树的收益。

请注意，我的文章中的代码非常慢，因为它衡量完成的工作量以及完成工作量。我的文章有很好的例子来说明如何快速拒绝部分搜索树，但它应该被认为只是一个说明——而不是生产代码。

Answer 3

使用递归的蛮力方法：

import Data.List (filter, (\\), reverse, delete, sortBy)
import Data.Ord  (comparing)

neighbour :: String -> String -> Bool
neighbour word = (1 ==) . length . (\\ word)

process :: String -> String -> [String] -> [(Int, [String])]
process start end dict = 
  let 
    loop :: String -> String -> [String] -> [String] -> [(Int,[String])] -> [(Int,[String])]
    loop start end dict path results = 
      case next of
        [] -> results
        xs ->
          if   elem end xs
          then (length solution, solution) : results
          else results ++ branches xs
      where
        next        = filter (neighbour start) dict'
        dict'       = delete start dict
        path'       = start : path
        branches xs = [a | x <- xs, a <- loop x end dict' path' results]
        solution    = reverse (end : path')
  in
  loop start end dict [] []

shortestSolution :: Maybe Int
shortestSolution = shortest solutions
  where 
    solutions  = process start end dict
    shortest s = 
      case s of
        [] -> Nothing
        xs -> Just $ fst $ head $ sortBy (comparing fst) xs

start = "spice"
end   = "stock"
dict  = ["spice","stick","smice","slice","slick","stock"]

注意事项：

• 此代码计算所有可能的解决方案 (process) 并选择最短的解决方案 (shortestSolution)，正如 Carl 所说，您可能希望修剪部分搜索树以获得更好的性能。

• 当函数无法返回结果时，最好使用Maybe 而不是返回-1。

---

另一种使用广度优先搜索树的方法：

import Data.Tree
import Data.List( filter, (\\), delete )
import Data.Maybe

node :: String -> [String] -> Tree String
node label dict = Node{ rootLabel = label, subForest = branches label (delete label dict) }

branches :: String -> [String] -> [Tree String]
branches start dict = map (flip node dict) (filter (neighbour start) dict)

neighbour :: String -> String -> Bool
neighbour word = (1 ==) . length . (\\ word)

-- breadth first traversal
shortestBF tree end = find [tree] end 0
  where 
    find ts end depth 
      | null ts = Nothing
      | elem end (map rootLabel ts) = Just depth
      | otherwise = find (concat (map subForest ts)) end (depth+1)

result = shortestBF tree end

tree :: Tree String
tree = node start dict

start = "spice"
end   = "stock"
dict  = ["spice","stick","smice","slice","slick","stock"]