在 Haskell 上实施回溯

Question

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

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

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

然后我有了我的列表，我需要从 "spice" 开始，然后到达 "stock" 最好的解决方案是 ["spice","slice","slick","stick","stock"]，从 "spice" 到 "stock" 有四个步骤。然后 return 4.

另一种解决方案是 ["spice","smice","slice","slick","stick","stock"] 需要五个步骤才能到达 "stock" 然后 return `5。但这是一个错误的解决方案，因为还有另一种方法比这个方法用更少的步骤更好。

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

这是我尝试编写的代码，但我遇到了一些错误，顺便说一句，我不知道我 "make" 回溯的方法是否好，或者是否有一些我没有看到的错误..

  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" 它 returns "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

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

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

请注意，我文章中的代码非常慢，因为它既要测量已完成的工作量，又要实际执行。我的文章有关于如何快速拒绝部分搜索树的很好的示例，但它应该被视为只是一个说明 - 而不是生产代码。

Answer 2

使用递归的蛮力方法：

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) 和 select 最短的解决方案 (shortestSolution)，正如 Carl 所说，您可能想要修剪部分搜索树以获得更好的性能。
当函数无法获得 return 结果时，最好使用 Maybe 而不是 returning -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"]

Answer 3

未经过全面测试，但希望这会有所帮助：

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 中的列表 monad 通常被描述为一种不确定的回溯计算形式。上面的代码所做的是允许列表 monad 承担生成备选方案的责任，测试它们是否满足标准，并在失败时回溯到最近的选择点。列表 monad 的绑定，例如word <- words，意思是"nondeterministically pick one of the words. guard means "如果到目前为止的选择不满足这个条件，回溯并做出不同的选择。列表 monad 计算的结果是来自不违反任何 guards.

的选择的所有结果的列表。

如果这看起来像列表推导，那么，列表推导与列表 monad 是一回事——我选择用 monad 而不是推导来表达它。

在 Haskell 上实施回溯

Implementing Backtracking on Haskell

haskell

backtracking