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

`applyRule`applies the specified rule, in turn, to each of row, column, and 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

> value :: Integral a => a -> [a]

> value 0 = [1..9]

> value a = a:[]

`main`function:

### 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!

## No comments:

Post a Comment