daniberg.com
Haskell Sudoku solver
This is an alternative Haskell implementation of Solving Every Sudoku Puzzle by Peter Norvig. The source code can be found on github.
The implementation follows function definitions and name conventions of the original post whenever possible. The source code comments can also be found in the python implementation to make it easier the comparison of both implementations.
The first step is to define the main entities: units, peers and squares.
cross :: String -> String -> [String]
cross a b = [ x : y : [] | x <- a, y <- b ]
digits = "123456789"
rows = "ABCDEFGHI"
cols = digits
type Square = String
type Digit = Char
-- [
-- "A1","A2","A3","A4","A5","A6","A7","A8","A9",
-- "B1","B2","B3","B4","B5","B6","B7","B8","B9",
-- "C1","C2","C3","C4","C5","C6","C7","C8","C9",
-- "D1","D2","D3","D4","D5","D6","D7","D8","D9",
-- "E1","E2","E3","E4","E5","E6","E7","E8","E9",
-- "F1","F2","F3","F4","F5","F6","F7","F8","F9",
-- "G1","G2","G3","G4","G5","G6","G7","G8","G9",
-- "H1","H2","H3","H4","H5","H6","H7","H8","H9",
-- "I1","I2","I3","I4","I5","I6","I7","I8","I9"
-- ]
squares :: [Square]
squares = cross rows cols
-- [
-- ["A1","B1","C1","D1","E1","F1","G1","H1","I1"],
-- ["A2","B2","C2","D2","E2","F2","G2","H2","I2"],
-- ["A3","B3","C3","D3","E3","F3","G3","H3","I3"],
-- ["A4","B4","C4","D4","E4","F4","G4","H4","I4"],
-- ["A5","B5","C5","D5","E5","F5","G5","H5","I5"],
-- ["A6","B6","C6","D6","E6","F6","G6","H6","I6"],
-- ["A7","B7","C7","D7","E7","F7","G7","H7","I7"],
-- ["A8","B8","C8","D8","E8","F8","G8","H8","I8"],
-- ["A9","B9","C9","D9","E9","F9","G9","H9","I9"],
--
-- ["A1","A2","A3","A4","A5","A6","A7","A8","A9"],
-- ["B1","B2","B3","B4","B5","B6","B7","B8","B9"],
-- ["C1","C2","C3","C4","C5","C6","C7","C8","C9"],
-- ["D1","D2","D3","D4","D5","D6","D7","D8","D9"],
-- ["E1","E2","E3","E4","E5","E6","E7","E8","E9"],
-- ["F1","F2","F3","F4","F5","F6","F7","F8","F9"],
-- ["G1","G2","G3","G4","G5","G6","G7","G8","G9"],
-- ["H1","H2","H3","H4","H5","H6","H7","H8","H9"],
-- ["I1","I2","I3","I4","I5","I6","I7","I8","I9"],
--
-- ["A1","A2","A3","B1","B2","B3","C1","C2","C3"],
-- ["A4","A5","A6","B4","B5","B6","C4","C5","C6"],
-- ["A7","A8","A9","B7","B8","B9","C7","C8","C9"],
-- ["D1","D2","D3","E1","E2","E3","F1","F2","F3"],
-- ["D4","D5","D6","E4","E5","E6","F4","F5","F6"],
-- ["D7","D8","D9","E7","E8","E9","F7","F8","F9"],
-- ["G1","G2","G3","H1","H2","H3","I1","I2","I3"],
-- ["G4","G5","G6","H4","H5","H6","I4","I5","I6"],
-- ["G7","G8","G9","H7","H8","H9","I7","I8","I9"]
-- ]
unitlist :: [[Square]]
unitlist =
[ cross rows (c:[]) | c <- cols ] ++
[ cross (r:[]) cols | r <- rows ] ++
[ cross rs cs | rs <- ["ABC", "DEF", "GHI"], cs <- ["123", "456", "789" ] ]
-- Map where each square is the key and values are lists of units that the
-- square belongs to.
units :: Map Square [[Square]]
units = toMap [(s, u) | s <- squares, u <- unitlist, elem s u]
toMap :: [(Square, [Square])] -> Map Square [[Square]]
toMap xs = foldl addToMap Map.empty xs where
addToMap m (k, ys) = case Map.lookup k m of
Just zs -> Map.insert k (ys : zs) m
Nothing -> Map.insert k [ys] m
-- Map where the each square is the key and the value is a list of the peers
-- which does not include the key. Each square has 20 peers.
peers :: Map Square (Set Square)
peers = Map.mapWithKey f units where
f k xss = Set.fromList $ filter (\x -> x /= k)(concat xss)
I've introduced the aliases types Square and Digit and while they don't
offer stronger guarantees they make the code easier to read.
The squares and unitlist function comments include their values to help
readers to understand how the values are generated.
Next are the functions parseGrid and gridValues.
-- Textual representation of the puzzle.
type Grid = String
-- Representation of the puzzle at any state. The key is a Square and the values
-- are a String representing the possible values of the square. If the length of
-- the String is one for all keys the puzzle has been solved.
type GridValues = Map Square String
-- Parse textual representation of the grid.
parseGrid :: Grid -> Maybe GridValues
parseGrid grid = do
let zero = Just (Map.fromList [(s, digits) | s <- squares])
xs <- gridValues grid
let gridValues' = filter (\(_, c) -> c `elem` digits) xs
foldl (\acc pair -> acc >>= (\m -> assign m pair)) zero gridValues'
-- Convert grid into a dict of {square: char} with '0' or '.' for empties.
-- In our implementation we return a list of pairs and let the caller
-- function convert it into a map.
gridValues :: Grid -> Maybe ([(Square, Char)])
gridValues grid =
let validChars = '0' : '.' : digits
chars = [ c | c <- grid, elem c validChars ] in
if length chars /= 81 then Nothing
else Just (zip squares chars)
Again, I've introduced type aliases to make the code clearer: Grid and GridValues.
Notice that different from the original python implementation the return type of
parseGrid is Maybe GridValues. A contradiction is signaled by returning
Nothing.
After that we have the functions assign and eliminate.
-- Constraint propagation
-- 1. If a square has only one possible value, then eliminate that value from the square's peers.
-- 2. If a unit has only one possible place for a value, then put the value there.
assign :: GridValues -> (Square, Digit) -> Maybe GridValues
assign values (s, d) = do
let otherValues = List.delete d (Maybe.fromMaybe "" (Map.lookup s values))
foldl eliminate' (Just values) otherValues where
eliminate' mValues d2 = mValues >>= (\values' -> eliminate values' (s, d2))
-- Eliminate d from values[s]; propagate when values or places <= 2.
-- Return values, except return Nothing if a contradiction is detected.
eliminate :: GridValues -> (Square, Digit) -> Maybe GridValues
eliminate vs (s, d) =
case Map.lookup s vs of
-- Our data is messed up
Nothing -> Nothing
-- digits as candidates
Just ds ->
-- already eliminated if not found
case List.elemIndex d ds of
Nothing -> Just vs
Just _ -> do
-- remove digit
let ds' = List.delete d ds
-- Contradiction if there are zero candidates, otherwise
-- update the map with the candidate removed
vs' <- if length ds' == 0 then Nothing
else Just $ Map.insert s ds' vs
-- (1) If a square s is reduced to one value d2, then
-- eliminate d2 from the peers.
vs'' <- if length ds' == 1
then
let d2 = head ds'
ss = Maybe.fromMaybe Set.empty (Map.lookup s peers) in
-- Short-circuit if any of the eliminate results is Nothing
foldl (\mValues s2 -> do
values <- mValues
eliminate values (s2, d2)) (Just vs') ss
else Just vs'
-- (2) If a unit u is reduced to only one place for a valud d,
-- then put it here.
uss <- Map.lookup s units
vs''' <- foldl
(\acc us -> do
acc' <- acc
let dplaces = [s | s <- us, d `elem` (Maybe.fromMaybe [] $ Map.lookup s acc')] in
case length dplaces of
0 -> Nothing -- Contradiction: no place for this value
1 -> assign acc' ((head dplaces), d)
_ -> acc) (Just vs'') uss
return vs'''
Again, both functions rely on the Maybe data structure.
The display function is not that interesting.
-- Display these values as 2D grid.
display :: GridValues -> IO ()
display values = do
let width = 1 + maximum [ Maybe.fromMaybe 0 $
fmap length $
Map.lookup s values | s <- squares]
line = List.intercalate "+" $ replicate 3 $ replicate (width * 3) '-'
table = [ buildCell r c | r <- rows, c <- cols] where
buildCell r c =
let vs = Maybe.fromMaybe "" $ Map.lookup (r : c : []) values
pre = replicate (width - length vs) ' '
pos = if c `elem` "36" then " |" else if c == '9' then "\n" else ""
ln = if r `elem` "CF" && c == '9' then (line ++ "\n") else "" in
pre ++ vs ++ pos ++ ln
putStrLn $ List.concat table
Finally, we have the search and solve function.
search :: GridValues -> Maybe GridValues
search values =
let xs = Map.toList values
allSizeOne = List.all (\(_, vs) -> length vs == 1) xs
-- Choose the infilled square s with the fewest possibilities
ys = filter (\(_, ds) -> length ds > 1) xs
(s, ds) = List.minimumBy (\(s1, v1) (s2, v2) ->
compare (length v1) (length v2)) ys
assignments = fmap (\d -> assign values (s, d) >>= search) ds in
if allSizeOne then Just values -- Solved
else join $ List.find (Maybe.isJust) assignments
solve :: Grid -> Maybe GridValues
solve grid = parseGrid grid >>= search
Instructions on how to compile and run the code can be found on github.
©2023 daniberg.com