Question

我正在玩一个Sudoku解算器，如下所示。我遇到的问题是，我不知道如何使用回溯来让解算器在第一次尝试失败后返回。如最后一个代码片段所示，算法在遇到第一个非法解决方案时停止并返回Nothing。我怎样才能让它返回并尝试另一种解决方案，直到找到一个？

-- Updates a specific sudoku with a value at a specific position
update :: Sudoku -> Pos -> Maybe Int -> Sudoku

-- Returns all the blank possitions in a sudoku
blanks :: Sudoku -> [Pos]

-- checks so that the size is correct 9x9
isSudoku :: Sudoku -> Bool

-- Checks if it is a legal sudoku, no number twise on any line col or box
isOkay :: Sudoku -> Bool

-- Checks if there are no empty cells in the sudoku
isSolved :: Sudoku -> Bool


solve :: Sudoku -> Maybe Sudoku
solve s
  | not $ isSudoku s && isOkay s = Nothing
  | otherwise = solve' $ pure s

solve' :: Maybe Sudoku -> Maybe Sudoku
solve' Nothing = Nothing --There is no solution
solve' (Just  s)
  | isSolved s = pure s -- We found a solution
  | otherwise = solve' newSud -- Continue looking for solution
    where
      (p:_) = blanks s
      newSud = solveCell (candidates s p)
      solveCell [] =  Nothing
      solveCell (c:cs)
        | isOkay $ update s p (pure c) = Just $ update s p (pure c)
        | otherwise = solveCell cs

失败解决并以此为终点。

Just (Sudoku {rows = [
[Just 1,Just 2,Just 3,Just 4,Just 5,Just 6,Just 7,Just 8,Just 9],
[Just 4,Just 5,Just 6,Just 1,Just 2,Just 3,Just 8,Just 7,Nothing]
[Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing],
[Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing],
[Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing],
[Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing],
[Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing],
[Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing],
[Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing]]})

Answer 1

我将通过编写更通用的代码来简化问题。编写更通用的代码通常更容易，因为可能性更小。

要进行一般搜索，我们需要三件事：如何判断done类型a -> Bool何时，branches搜索类型a -> [a]，以及从类型a开始搜索。

深度优先搜索

我们正在尝试实施的depth-first search策略很简单。如果我们是done，请返回我们找到的结果。否则，找出我们可以从这里获取的分支，并尝试按顺序搜索每个分支，直到其中一个返回结果。如果我们可以从这里拿到分支，那么我们就找不到结果了。

import Data.Maybe

depthFirstSearch :: (a -> Bool) -> (a -> [a]) -> a -> Maybe a
depthFirstSearch done branches = go
    where 
        go x =
            if done x
            then Just x
            else listToMaybe . catMaybes . map go . branches $ x

像我们这样的深度优先搜索的典型实现通常使用调用堆栈进行回溯。深度优先搜索在探索其他可能的决策之前探索了决策产生的所有可能性。由于它致力于一个行动过程并且要么解决问题，要么证明行动方案是无法解决的，那么在承诺每个行动方案之前的状态可以很容易地存储在堆栈中。堆栈在进行调用之前会记住计算的状态，以便在该调用返回时恢复该状态。这是我们需要记住的用于深度回溯深度搜索的状态的完美匹配。

listToMaybe . catMaybes . map go . branches的评估是由懒惰的评估驱动的，因此最左边的事情是最先发生的事情。 listToMaybe正在寻找第一个解决方案，从catMaybes . map go . branches依次尝试每种可能性，直到找到一个。{1}}。 catMaybes正在产生map go . branches的结果，抛出了导致Nothing的可能性。 map go正在为每个分支进行递归调用，因为其他函数需要它。

Depth-first搜索Sudoku

要对您的数独问题使用depthFirstSearch，我们需要提供done和branches功能。我们已经done，它是isSolved。我们需要提供branches函数，从一个位置找到合法的移动。首先，我们会找到所有moves。

-- You might have something more clever for this
candidates :: Sudoku -> Pos -> [Int]
candidates _ _ = [1..9] 

moves :: Sudoku -> [Sudoku]
moves s = do
    -- We only need to consider putting all the numbers in one position, not putting all the numbers in all positions
    p <- take 1 . blanks $ s
    c <- candidates s p
    return (update s p (Just c))

合法举措只是那些没事的。

legalMoves :: Sudoku -> [Sudoku]
legalMoves = filter isOkay . moves

这足以使用depthFirstSearch

solve' :: Sudoku -> Maybe Sudoku
solve' = depthFirstSearch isSolved legalMoves

与您的代码的区别

让我们看看上面的solve'与solve'的不同之处。他们都使用相同的部分 - isSolved，isOkay，blanks，candidates和update，但他们将它们放在一起的方式略有不同。

我会从上面重写solve'，直到它看起来接近你的solve'。首先，我们将替换depthFirstSearch并注意solve' = go并使用警卫代替if ... then ... else

solve' :: Sudoku -> Maybe Sudoku
solve' s
    | isSolved s = Just s
    | otherwise  = listToMaybe . catMaybes . map solve' . legalMoves $ s

我将在legalMoves s

中替换

solve' :: Sudoku -> Maybe Sudoku
solve' s
    | isSolved s = Just s
    | otherwise  = listToMaybe . catMaybes . map solve' $ newSuds
        where
            newSuds = filter isOkay $ do
                -- We only need to consider a single putting all the numbers in one position, not puutting all the numbers in all positions
                p <- take 1 . blanks $ s
                c <- candidates s p
                return (update s p (Just c))

然后替换listToMaybe . catMaybes . map solve'

solve' :: Sudoku -> Maybe Sudoku
solve' s
    | isSolved s = Just s
    | otherwise = tryInTurn newSuds
        where
            newSuds = filter isOkay $ do
                -- We only need to consider a single putting all the numbers in one position, not puutting all the numbers in all positions
                p <- take 1 . blanks $ s
                c <- candidates s p
                return (update s p (Just c))
            tryInTurn [] = Nothing
            tryInTurn (s:ss) =
                case solve' s of
                    (Just solution) -> Just solution
                    otherwise       -> tryInTurn ss

我们可以将update移到tryInTurn，但我们必须以某种方式跟踪p，或者假设你做的不是isSolved暗示blanks 1}}不会是[]。我们会做后者，这就是你所做的。

solve' :: Sudoku -> Maybe Sudoku
solve' s
    | isSolved s = Just s
    | otherwise = solveCell (candidates s p)
        where
            (p:_) = blanks s
            solveCell  [] = Nothing
            solveCell  (c:cs)
                | isOkay $ update s p (Just c) = 
                    case solve' (update s p (Just c)) of
                        (Just solution) -> Just solution
                        otherwise       -> solveCell cs
                | otherwise = solveCell cs

此版本与您的版本之间的最大区别在于，对solve'的递归调用会针对每个候选发生一次，而不是针对第一个正常候选者执行一次。

实际问题

深度优先的数独求解器在处理数独中绝对巨大的分支因子时会遇到很多麻烦。它可能是最不具有限制性的移动启发式的，这对于数独来说将选择使用最少的候选者进行下一步的移动。

Answer 2

您的Sudoku数据结构不够强大。它等同于Maybe Int的二维数组，但是对于每个单元格，您需要跟踪所有可能的数字，例如：

data Sudoku = Sudoku { rows :: [[ [Int] ]] }

然后关键是编写一个eliminate函数，它可以消除单元格的可能性：

eliminate :: Sudoku -> (Int,Int) -> Int -> Maybe Sudoku
eliminate s ((i,j),d) = ...

eliminate不仅需要从d的单元格中删除数字(i,j)，还需要在同一行，列和框中执行推理，以查看是否还有其他内容数字可以从其他单元格中删除。

update函数可以按eliminate编写，如下所示：

update :: Sudoku -> (Int,Int) -> Int -> Maybe Sudoku
update sud (i,j) d =
  let ds = ...digits in sud at (i,j)...
      toDump = delete d ds  -- the digits to remove
      foldM (\s x -> eliminate s (i,j) x) sud toDump

此处foldM通过连续调用toDump来迭代eliminate中的数字。如果eliminate返回Nothing，则弃牌会提前终止。

我所提供的内容基于this Sudoku solver，后者又基于Peter Norvig's solution，其中包含对该方法的出色解释。要了解如何完成回溯，请查阅Haskell源代码以了解search函数。

如何在第一次失败后让这个数独算法失效？

2 个答案:

深度优先搜索

Depth-first搜索Sudoku

与您的代码的区别

实际问题