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]