The concept behind this solver is that the puzzle is represented by a collection of constraints, and the solver transforms these constraints until the puzzle is solved.
This approach works for many, but not all, Sudoku puzzles. At least it's fast!
First off: I'll be needing a few libraries to help out
> import Data.Array
> import Data.List hiding (group)
> import Text.ParserCombinators.Parsec
> import System.IO
Data Types
Let's start with the type I'm using to represent a Sudoku puzzle:
> type Sudoku a = Array (Int,Int) [a]
Each cell in the Sudoku puzzle is represented by a list of allowed values. A puzzle is solved when each cell can only take a single value.
A few functions to operate on the values of a Sudoku cell:
isD returns true if the supplied list is of length 1.
> isD :: [a] -> Bool
> isD (_:[]) = True
> isD _ = False
stripD takes in a list of length 1, and returns the single value in the list.
> stripD :: [a] -> a
> stripD (a:[]) = a
> stripD _ = error "List supplied was not of unit length"
And now for functions that operate on whole puzzles:
isSolved returns true if the Sudoku puzzle is solved.
> isSolved :: Sudoku a -> Bool
> isSolved = and . map isD . elems
getS returns the contents of the cells specified by the input list, packed with the cell they came from
> getS :: Sudoku a -> [(Int,Int)] -> [((Int,Int),[a])]
> getS s ixs = [(ix, (s ! ix)) | ix <- ixs]
I drag the indices around for ease of reconstruction back into an array.
Solving
A Sudoku puzzle is initially presented with some cells filled in, and some cells empty.
In this solver, each cell of the Sudoku data-type contains a list of values that cell may take. So initially, each cell would either contain a list with a single element, or the list of numbers from 1 to 9.
The solver applies rules to groups of cells to add further constraints to the cells:
> type Rule a = [[a]] -> [[a]]
The solver takes a list of such rules, and applies them until they have no further effect. The rules that come first in the list are tried first. Once a rule succeeds in doing something, the solver then goes back to the beginning of the list.
> solveWithRules :: Eq a => [Rule a] -> Sudoku a -> Sudoku a
> solveWithRules [] s = s
> solveWithRules x s = helper x s where
> helper [] s = s
> helper (r:rs) s = if isSolved nextS
> then nextS
> else if s == nextS
> then helper rs nextS
> else helper x nextS
> where nextS = applyRule r s
applyRule takes a single rule and applies it to a Sudoku puzzle:
> applyRule :: Eq a => Rule a -> Sudoku a -> Sudoku a
> applyRule r = foldr1 (.) $ map (apply r) [group, column, row]
There are three interesting partitions of the cells of a Sudoku grid:
- By row
- By column
- By 3x3 sub-grid
> column, row, group :: Int -> [(Int,Int)]
> column n = [(x,n) | x <- [1..9]]
> row n = [(n,x) | x <- [1..9]]
> group n = [(x,y) | x <- [rowL !! (n-1)..(rowL !! (n-1))+2],
> y <- [columnL !! (n-1) .. (columnL !! (n-1))+2]] where
> rowL = [1,1,1,4,4,4,7,7,7]
> columnL = [1, 4, 7, 1, 4, 7, 1, 4, 7]
The function apply takes the rule and the partition, and performs the application of the rule:
> apply :: Eq a => Rule a -> (Int -> [(Int,Int)]) -> Sudoku a -> Sudoku a
> apply r partition = \x -> array ((1,1),(9,9))
> $ concat
> $ map (liftE r)
> $ map (getS x)
> $ map partition [1..9]
The function liftE is needed to convert a rule (which is of type [[a]] -> [[a]]) to be of type [((Int,Int),[a])] -> [((Int,Int),[a])]
> liftE :: ([a] -> [b]) -> [(i, a)] -> [(i, b)]
> liftE f = \x -> zip (fst (unzip x)) $ f $ snd (unzip x)
So I've laid out all of the mechanisms for applying rules to Sudoku puzzles. the next step is to define these rules.
Rules
All of the rules analyze a set of Sudoku cells, and further constrain the values of those cells (or do nothing).
Here's an example, rule a1:
> a1 :: Eq a => Rule a
> a1 x = map helper x where
> helper (a:[]) = a:[]
> helper as = [b | b <- as, not $ elem b definites]
> definites = [stripD y | y <- x, isD y]
Put simply: If a cell is fully constrained to a value, no other cell is allowd to take that value.
This reduction rule can be taken further: If two cells are jointly constrained to two values, no other cells may take those values, if three cells are jointly constrained to three values ... and on and on.
In order to apply the generalized form of rule a1, I'll need to figure out every way I can break a list of nine Sudoku cells into two groups:
> combos :: Integral n => [([n],[n])]
> combos = map (\x -> (x,[0..8]\\x)) $ powerset [0..8]
combos is a list of pairs of lists, representing every way to split a list of nine elements into two groups. Using a set of puzzle cells as an accumulator, I can fold across this list (or portions of it).
But first:
> powerset :: [a] -> [[a]]
> powerset [] = [[]]
> powerset (x:xs) = let p = powerset xs in p ++ map (x:) p
I didn't come up with this implementation of powerset, and I don't remember who did. Sorry!
Also, I'm really only interested in a portion of the combos list at any given time:
> subCombos n = filter ( (==n) . fromIntegral . length . fst) combos
subCombos n represents all of the ways to divide up a list into two groups such that one of the groups has n elements.
And here is the "super" rule:
> a :: (Eq a, Integral n) => n -> Rule a
> a n = \y -> foldr helper y (subCombos n) where
> helper (a,b) x = if length (valuesIn a x) == length a
> then mapIndices (remove (valuesIn a x)) b x
> else x
(a 1) should produce the same result as a1. In practice, (a 1) is slower than a1.
I've used a few new functions up there:
> valuesIn :: (Integral n, Eq a) => [n] -> [[a]] -> [a]
> valuesIn a x = nub . concat . map ((x!!) . fromIntegral) $ a
Given a list of indices and a list of constraints, valuesIn returns a flat list of the values specified by the constraints at the indices given.
> remove :: Eq a => [a] -> [a] -> [a]
> remove a bs = [x | x <- bs, not (elem x a)]
remove takes in two lists, and returns a list composed of elements in the second list but not in the first. There's probably something a lot like this in the standard library.
> mapIndices :: Integral n => (a -> a) -> [n] -> [a] -> [a]
> mapIndices f ns as = helper 0 f ns as where
> helper _ _ [] as = as
> helper _ _ _ [] = []
> helper i f ns (a:as) = if elem i ns
> then (f a):(helper (i+1) f (delete i ns) as)
> else a:(helper (i+1) f ns as)
mapIndices is a lot like map, but it passes through any list elements which are not at the indices specified.
Those are the rules!
Parsing
Parsec may be a bit much for this. Ah well.
A Sudoku puzzle consists of a bunch of numbers. Whitespace is ignored. Any non-numeric text preceding the numbers is ignored. The parser also consumes any non-numeric text following the Sudoku puzzle.
> parseSudoku :: (Integral a, Read a) => Parser (Sudoku a)
> parseSudoku = do many (noneOf nums)
> x <- many1 (do y <- digit
> many space
> return y)
> many (noneOf nums)
> return $ sudoku $ map (read . return) x
> where nums = ['0'..'9']
I use a function sudoku in there. It creates a Sudoku puzzle from a list a more-friendly way:
> sudoku :: Integral a => [a] -> Sudoku a
> sudoku xs | (length xs == 81) = array ((1,1),(9,9))
> $ zip [(x,y)| x <- [1..9], y <- [1..9] ]
> $ map value xs
> | otherwise = error "Suduko must be constructed of 81 entries."
Here I use the value function:
That covers parsing. It's time to look at the main function:
> value :: Integral a => a -> [a]
> value 0 = [1..9]
> value a = a:[]
Main
> main :: IO ()
> main = do x <- hGetContents stdin
> case (parse (many1 parseSudoku) "" x) of
> Left err -> do putStr "Error reading input"
> print err
> Right a -> foldr1 (>>) $ map (printSudoku . solveWithRules rules) a
> where rules = [a1, a 6, a 2]
Here's the breakdown:
- I parse the standard input to a list of Sudoku puzzles
- For each Sudoku, I attempt to solve them with a specified set of rules
- Then I print them
Here's how printing is handled:
> printSudoku :: Show a => Sudoku a -> IO ()
> printSudoku = printEntries . map unValue . elems
> unValue :: Show a => [a] -> Char
> unValue (a:[]) = head (show a)
> unValue [] = '/'
> unValue _ = '_'
> printEntries :: String -> IO ()
> printEntries [] = putStrLn "\n"
> printEntries s = do putStrLn (take 9 s)
> printEntries (drop 9 s)
elems takes an array and returns it's contents as a list. I then replace the contraint lists with single characters, and then I print them out nine at a time.
Test cases
Feed the remainder of this post on stdin into the compiled version of this post to try out the solver.
Puzzles from websudoku.com
Rating: Hard
000070009
400080001
093000008
040006200
010758040
006300080
700000560
600020004
500090000
+++
002150000
603002000
000003028
001006070
950000061
080400300
210600000
000200607
000039200
+++
200100730
000490020
060008000
006000004
940070012
800000900
000300090
050026000
037009005
+++
003040800
000006130
000350042
300000000
147000365
000000004
890025000
026100000
005080400
+++
040006003
000705800
000800460
020008007
006000200
800400050
039004000
007502000
200100040
+++
000900103
010607000
080000020
036080007
700109008
800070410
040000030
000204090
605001000
+++
090800701
060010000
000900200
038709005
000000000
400502680
004005000
000040060
105008070
+++
200600970
030000050
640007001
000003006
001502700
500400000
900200037
050000090
012009005
+++
080000000
000430090
100052006
761500030
005000100
030001975
200140009
040087000
000000040
+++
090800700
080001060
000050200
020500040
708010603
030006020
005020000
010300080
009007010
+++
070902000
050040107
400100082
086000000
200000006
000000290
830005004
607020010
000403070
+++
010008000
785030001
000001950
000020004
043000210
200050000
094700000
800090427
000400030
+++
003000000
100967002
020300068
609000010
040000050
010000409
450001080
200685001
000000600
+++
063078001
098500000
040000000
000250100
025000680
004061000
000000090
000004720
300680410
+++
000005800
090230070
730001002
100000085
600000001
920000004
200500067
060092010
001300000
+++
003059408
000810009
000000050
009002006
012000570
600300100
070000000
900024000
104980700
+++
580700200
000405080
000000007
079106000
062000150
000203470
600000000
020609000
008002015
Wow!
