How can I make this Sudoku algorithm get unstuck after the first fail?

Question

Im playing around with a Sudoku solver as shown below. The problem I'm having is that I don't know how to use backtracking to get the solver to go back after it fails with the first try. As shown in the last code snippet the algorithm stops when it hits the first illegal solution and returns Nothing. How can I make it go back and try another solution until it finds one?

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

Fails solving and ends up with this as the stopping point.

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

I'm going to simplify the problem by writing more generic code. Writing more generic code is frequently easier because there are fewer possibilities.

To search generically we need three things: how to tell when we are done with type a -> Bool, what branches there are to search with type a -> [a], and where to start the search from with type a.

Depth-first search generically

The strategy for a depth-first search, which is what we are trying to implement, is simple. If we are done, return the result we found. Otherwise find out what branches we can take from here, and try searching each of them in order until one of them returns a result. If there are no branches we can take from here, then we've failed to find a result.

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

A typical implementation of depth-first search, like ours, usually uses the call stack for backtracking. Depth-first search explores all of the possibilities resulting from a decision before exploring other possible decisions. Since it commits to a course of action and either solves the problem or proves that course of action is unsolvable, the state before committing to each course of action can easily be stored on the stack. The stack remembers the state of computations before making a call so that when that call returns that state is restored. This is a perfect match for the states we need to remember for backtracking in depth first search.

The evaluation of listToMaybe . catMaybes . map go . branches is driven by lazy evaluation, so the left-most thing is what really always happens first. listToMaybe is looking for the first solution, trying each possibility from catMaybes . map go . branches in turn until it finds one. catMaybes is yielding the results from map go . branches, throwing out an explored possibility that resulted in Nothing. map go is making the recursive call for each branch as it is demanded by the other functions.

Depth-first search for Sudoku

To use depthFirstSearch for your Sudoku problem, we need to provide the done and branches functions. We already have done, it's isSolved. We need to provide the branches function that finds the legal moves from a position. First we'll find all the 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))

The legal moves are only the ones that are okay.

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

This is enough to use depthFirstSearch

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

Differences from your code

Let's see how solve' from above is different from your solve'. They both use the same pieces - isSolved, isOkay, blanks, candidates, and update but they put them together slightly differently.

I'll re-write the solve' from above until it looks close to your solve'. First we'll substitute for depthFirstSearch and notice that solve' = go and use guards instead of if ... then ... else

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

I'll substitute in 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))

Then substitute for 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

We could move the update into tryInTurn, but we'd have to keep track of p somehow or assume like you did that not isSolved implies that blanks will not be []. We'll do the latter, which is what you did.

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

The big difference between this version and your version is that the recursive call to solve' happens once for each candidate instead of once for the first okay candidate.

Practical concerns

A depth-first sudoku solver is going to have a lot of trouble dealing with the absolutely huge branching factor in sudoku. It might be tenable with the least restrictive move heuristic, which for sudoku would be to choose to make the next move in the position with the fewest okay candidates.

Answer 2

Your Sudoku data structure is not powerful enough. It's equivalent to a 2-d array of Maybe Int, but for each cell you need to keep track of all of the possible digits, i.e. something like this:

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

And then the key is to write an eliminate function which removes a possibility from a cell:

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

eliminate needs to not only remove the digit d from the cell at (i,j), but it also needs to perform inference in the same row, column and box to see if any other digits can be eliminated from other cells.

The update function may be written in terms of eliminate as follows:

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

Here foldM iterates over the digits in toDump by successively calling eliminate. The fold will terminate early if eliminate returns Nothing.

What I have presented is based on this Sudoku solver which in turn is based on Peter Norvig's solution which contains an excellent explanation of the approach. To see how backtracking is done, consult the Haskell source for the search function.