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
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.
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.
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).
> 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!
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 :: 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.
Feed the remainder of this post on stdin into the compiled version of this post to try out the solver.
Puzzles from websudoku.com