Haskell Sudoku Solver

Question

Any comments on the following Sudoku solver? Comments I'm particularly interested are (but not limited to...)

• Algorithm. It created a list of "potentials" for each cell, and trims them down until it's solved. Anything better?
• How's my use of the State monad? I'm not that familiar, so don't know if I'm doing anything weird.
• Factoring out repeated code. Specifically there are lots of similarities between the row/column/cell cases, and I couldn't quite work out how to do a "monadic for loop" when working with each row/column/cell.
• There are lots of "matrix"-y operations, so lots of working with indexes, and multiplying / dividing things about. This doesn't feel very type safe, and I fear runtime exceptions
• Is there something better that the [[Int]]s that are used for the current state of the grid? Maybe with better type safety?
• There is no error handling... suggestions?
• Any inefficiencies spotted.
• Naming. I'm not quite sure what idiomatic naming is in Haskell.

---

import Control.Monad.Loops import Control.Monad.State.Strict import Data.List import Data.List.Split type GridState = [[Int]] initial = [ Nothing, Nothing, Just 3, Nothing, Nothing, Just 7, Just 1, Nothing, Nothing, Nothing, Just 4, Just 1, Nothing, Just 2, Nothing, Nothing, Nothing, Just 5, Just 9, Nothing, Just 6, Nothing, Just 5, Just 1, Just 2, Just 3, Nothing, Just 6, Nothing, Nothing, Just 5, Just 8, Nothing, Just 9, Nothing, Nothing, Nothing, Nothing, Just 8, Nothing, Nothing, Nothing, Just 7, Nothing, Nothing, Nothing, Nothing, Just 2, Nothing, Just 4, Just 9, Nothing, Nothing, Just 6, Nothing, Just 2, Just 9, Just 8, Just 7, Nothing, Just 3, Nothing, Just 1, Just 8, Nothing, Nothing, Nothing, Just 6, Nothing, Just 5, Nothing, Nothing, Nothing, Nothing, Just 5, Just 9, Nothing, Nothing, Just 4, Nothing, Nothing ] main :: IO () main = putStrLn $ niceString $ snd $ runState iteration $ toPotentials initial niceString :: [[Int]] -> String niceString matrix = intercalate "\n" $ chunksOf 18 asStrings where asStrings = intercalate " " $ map (show . head) matrix getRowInState :: Int -> State GridState [[Int]] getRowInState i = state $ \s -> (row i s, s) replaceRowInState :: Int -> [[Int]] -> State GridState () replaceRowInState i newRow = state $ \s -> ((), replaceRow i s newRow) getColumnInState :: Int -> State GridState [[Int]] getColumnInState i = state $ \s -> (column i s, s) replaceColumnInState :: Int -> [[Int]] -> State GridState () replaceColumnInState i newColumn = state $ \s -> ((), replaceColumn i s newColumn) getCellInState :: (Int, Int) -> State GridState [[Int]] getCellInState (i,j) = state $ \s -> (cell (i,j) s, s) replaceCellInState :: (Int, Int) -> [[Int]] -> State GridState () replaceCellInState (i,j) newCell = state $ \s -> ((), replaceCell (i,j) s newCell) isNotSolved :: State GridState Bool isNotSolved = state $ \s -> (any (\xs -> length xs > 1) s, s) iteration :: State GridState [()] iteration = do whileM isNotSolved iterationGrid iterationGrid :: State GridState () iterationGrid = do iterationRow 0 iterationRow 1 iterationRow 2 iterationRow 3 iterationRow 4 iterationRow 5 iterationRow 6 iterationRow 7 iterationRow 8 iterationColumn 0 iterationColumn 1 iterationColumn 2 iterationColumn 3 iterationColumn 4 iterationColumn 5 iterationColumn 6 iterationColumn 7 iterationColumn 8 iterationCell (0, 0) iterationCell (1, 0) iterationCell (2, 0) iterationCell (0, 1) iterationCell (1, 1) iterationCell (2, 1) iterationCell (0, 2) iterationCell (1, 2) iterationCell (2, 2) iterationRow :: Int -> State GridState () iterationRow i = do row <- getRowInState i replaceRowInState i $ reducePotentials row iterationColumn :: Int -> State GridState () iterationColumn i = do column <- getColumnInState i replaceColumnInState i $ reducePotentials column iterationCell :: (Int, Int) -> State GridState () iterationCell (i, j) = do cell <- getCellInState (i,j) replaceCellInState (i,j) $ reducePotentials cell -- Dealing with "potentials" -- toPotentials :: [Maybe Int] -> [[Int]] toPotentials matrix = map toPotential matrix toPotential :: Maybe Int -> [Int] toPotential Nothing = [1..9] toPotential (Just x) = [x] reducePotentials :: (Eq a) => [[a]] -> [[a]] reducePotentials subMatrix = map (withoutPotential) subMatrix where withoutPotential [x] = [x] withoutPotential xs = xs \\ (certains subMatrix) certains :: [[a]] -> [a] certains subMatrix = map (\ xs -> xs !! 0) $ filter (\xs -> length xs == 1) subMatrix --- Matrix / utilitiy operations --- row :: Int -> [a] -> [a] row i matrix = [fst x_i | x_i <- indexed, rowOfIndex (snd x_i) == i] where indexed = zip matrix [0..] replaceRow :: Int -> [a] -> [a] -> [a] replaceRow i matrix newRow = map replace indexed where indexed = zip matrix [0..] replace x_i | rowOfIndex (snd x_i) == i = newRow !! (columnOfIndex $ snd x_i) | otherwise = matrix !! snd x_i replaceColumn :: Int -> [a] -> [a] -> [a] replaceColumn i matrix newColumn = map replace indexed where indexed = zip matrix [0..] replace x_i | columnOfIndex (snd x_i) == i = newColumn !! (rowOfIndex $ snd x_i) | otherwise = matrix !! snd x_i replaceCell :: (Int, Int) -> [a] -> [a] -> [a] replaceCell (i, j) matrix newCell = map replace indexed where indexed = zip matrix [0..] replace x_i | cellOfIndex (snd x_i) == (i, j) = newCell !! (indexInNewCell $ snd x_i) | otherwise = matrix !! snd x_i indexInNewCell i_parent = (rowInCell i_parent) * 3 + columnInCell i_parent rowInCell i_parent = (i_parent - i * 9 * 3) `quot` 9 columnInCell i_parent = i_parent `mod` 3 column :: Int -> [a] -> [a] column i matrix = [fst x_i | x_i <- indexed, columnOfIndex (snd x_i) == i] where indexed = zip matrix [0..] cell :: (Int, Int) -> [a] -> [a] cell (i,j) matrix = [fst x_i | x_i <- indexed, cellOfIndex (snd x_i) == (i, j)] where indexed = zip matrix [0..] rowOfIndex :: Int -> Int rowOfIndex i = i `quot` 9 columnOfIndex :: Int -> Int columnOfIndex i = i `mod` 9 cellOfIndex :: Int -> (Int, Int) cellOfIndex i = ((rowOfIndex i) `quot` 3, (columnOfIndex i) `quot` 3) isBetween :: Int -> Int -> Int -> Bool isBetween a b x = a <= x && x < b 

Answer 1

hlint gives a bunch of valid advice. mapM_ collapses 9 lines into one thrice. gets and modify encapsulate the use cases of the InState functions. iterationGroup can replace three names simply by turning the differing functions into arguments. Since I didn't want to write a type signature there, ghci now wants FlexibleContexts. (!! 0) smells, use head. So does head, use list comprehensions and pattern matching.

matrix !! snd x_i...... why not fst x_i? :( Also, use pattern matching instead of fst and snd.

Let's also inline some stuff that's only used once. isBetween is unused.

{-# LANGUAGE FlexibleContexts #-} main :: IO () main = putStrLn $ niceString $ execState iteration $ map toPotential initial niceString :: [[Int]] -> String niceString matrix = intercalate "\n" $ chunksOf 18 asStrings where asStrings = unwords $ map (show . head) matrix isNotSolved :: State GridState Bool isNotSolved = gets $ any (\xs -> length xs > 1) iteration :: State GridState [()] iteration = whileM isNotSolved $ do mapM_ (iterationGroup row replaceRow ) [0..8] mapM_ (iterationGroup column replaceColumn) [0..8] mapM_ (iterationGroup cell replaceCell ) [(x,y) | x <- [0..2], y <- [0..2]] iterationGroup f g x = do group <- gets $ f x modify $ \s -> g x s $ reducePotentials group -- Dealing with "potentials" -- toPotential :: Maybe Int -> [Int] toPotential Nothing = [1..9] toPotential (Just x) = [x] reducePotentials :: (Eq a) => [[a]] -> [[a]] reducePotentials subMatrix = map withoutPotential subMatrix where withoutPotential [x] = [x] withoutPotential xs = xs \\ [x | [x] <- subMatrix] --- Matrix / utilitiy operations --- replaceGroup groupOfIndex otherOfIndex i matrix newGroup = map replace indexed where indexed = zip matrix [0..] replace (x, i') | groupOfIndex i' == i = newGroup !! otherOfIndex i' | otherwise = x replaceRow :: Int -> [a] -> [a] -> [a] replaceRow = replaceGroup rowOfIndex columnOfIndex replaceColumn :: Int -> [a] -> [a] -> [a] replaceColumn = replaceGroup columnOfIndex rowOfIndex replaceCell :: (Int, Int) -> [a] -> [a] -> [a] replaceCell (i, j) = replaceGroup cellOfIndex indexInNewCell (i, j) where indexInNewCell i_parent = rowInCell i_parent * 3 + columnInCell i_parent rowInCell i_parent = (i_parent - i * 9 * 3) `quot` 9 columnInCell i_parent = i_parent `mod` 3 row :: Int -> [a] -> [a] row i matrix = [x | (x, i') <- zip matrix [0..], rowOfIndex i' == i] column :: Int -> [a] -> [a] column i matrix = [x | (x, i') <- zip matrix [0..], columnOfIndex i' == i] cell :: (Int, Int) -> [a] -> [a] cell index matrix = [x | (x, index') <- zip matrix [0..], cellOfIndex index' == index] rowOfIndex :: Int -> Int rowOfIndex i = i `quot` 9 columnOfIndex :: Int -> Int columnOfIndex i = i `mod` 9 cellOfIndex :: Int -> (Int, Int) cellOfIndex i = (rowOfIndex i `quot` 3, columnOfIndex i `quot` 3) 

We're passing around a lot of setters and getters and indices, if only there was a library that specialized in that...

Enter lens.

import Control.Lens iteration :: State GridState [()] iteration = whileM (gets $ any (\xs -> length xs > 1)) $ mapM_ iterationGroup groups groups :: [[Int]] groups = rows ++ columns ++ cells where rows = chunksOf 9 [0..80] columns = transpose rows cells = map concat $ chunksOf 3 $ concat $ transpose $ map (chunksOf 3) columns -- Apply reducePotentials to the list of matrix entries determined by the index list. iterationGroup :: [Int] -> State GridState () iterationGroup is = partsOf (traversed . indices (`elem` is)) %= reducePotentials 

Answer 2

Efficiency-wise, I don't think your data structure is ideal. Your operations to replace rows and columns will cause a lot of copying, and you also perform a lot of random access into the lists, which can involve lots of link following to reach the right index (with only 9 entries in each list it isn't hugely bad, but still with considering). If you switch from the State monad to ST you can use mutable arrays instead, which ought to be faster (I would expect execution time somewhere between half and a third your current version).

Answer 3

With strong influence from the answer from Gurkenglas

• Using Control.Lens, along with the indices of each of the subgrids to avoid lots of the boilerplate of getting/replacing them.
• Using mapM_ rather than manually copying/pasting code for type of subgrid
• Using pattern matching in a list comprehension to get lists of length 1 rather than filter/length/head, so [x | [x] <- subMatrix]
• Moved a fair number of things inline, or into where in the places where they are used, rather than functions defined globally.
• Using gets to easily wire in a function to convert the state to another value. In this case, a Bool that gives the solved status.

(Unmeasured) efficiency

• Create more of the state transformers/lenses upfront, so less is done each iteration

Logic clarity

• Changed the function of IsNotSolved to IsSolved, and whileM_ to untilM_. Minor thing, but usually clearer to avoid a predicate that is "not" something.

Regarding types

• Created my own type for the values in the grid. The fact they are integers is incidental, and given there are lots of indices of lists floating around, think it's safer
  • to make sure they cannot be confused
  • to make sure that the compiler forbids a non valid value to go in the grid
• Use a type of MatrixIndex rather than Int. Not really for safety as such, but clarity for the type signatures

Along with a few minor things, mostly from hlint

• execState rather than snd $ runState
• unwords rather than intercalate " "
• Sections for partially apply infix operators (specifically ==)

And added a bit of point-free style about the place.

---

import Control.Lens import Control.Monad.Loops import Control.Monad.State.Strict import Data.List import Data.List.Split import Data.Maybe data SudokuValue = S1 | S2 | S3 | S4 | S5 | S6 | S7 | S8 | S9 deriving (Eq, Enum) instance Show SudokuValue where show s = show $ fromJust (s `elemIndex` [S1 ..]) + 1 type MatrixIndex = Int initial = [ Nothing, Nothing, Just S3, Nothing, Nothing, Just S7, Just S1, Nothing, Nothing, Nothing, Just S4, Just S1, Nothing, Just S2, Nothing, Nothing, Nothing, Just S5, Just S9, Nothing, Just S6, Nothing, Just S5, Just S1, Just S2, Just S3, Nothing, Just S6, Nothing, Nothing, Just S5, Just S8, Nothing, Just S9, Nothing, Nothing, Nothing, Nothing, Just S8, Nothing, Nothing, Nothing, Just S7, Nothing, Nothing, Nothing, Nothing, Just S2, Nothing, Just S4, Just S9, Nothing, Nothing, Just S6, Nothing, Just S2, Just S9, Just S8, Just S7, Nothing, Just S3, Nothing, Just S1, Just S8, Nothing, Nothing, Nothing, Just S6, Nothing, Just S5, Nothing, Nothing, Nothing, Nothing, Just S5, Just S9, Nothing, Nothing, Just S4, Nothing, Nothing ] main :: IO () main = putStrLn $ niceString $ execState iteration $ map toPotential initial where niceString = intercalate "\n" . (chunksOf 18) . unwords . map (show . head) toPotential Nothing = [S1 ..] toPotential (Just x) = [x] iteration :: State [[SudokuValue]] () iteration = untilM_ groupTransforms isSolved where isSolved = gets (all ((1 ==) . length)) groups :: [[MatrixIndex]] groups = rows ++ columns ++ cells where rows = chunksOf 9 [0..80] columns = transpose rows cells = concatMap (map concat . chunksOf 3) $ transpose $ map (chunksOf 3) columns groupTransforms :: State [[SudokuValue]] () groupTransforms = mapM_ groupTransform groups where groupTransform group = partsOf (traversed . indices (`elem` group)) %= reducePotentials reducePotentials :: [[SudokuValue]] -> [[SudokuValue]] reducePotentials subMatrix = map withoutPotential subMatrix where withoutPotential [x] = [x] withoutPotential xs = xs \\ [x | [x] <- subMatrix]