Sudoku
Here are a few sodoku solvers coded up in Haskell...
Serious, Non-Deterministic Solver
Here is a solver by CaleGibbard [1]. It possibly looks even more naïve than it actually is. This does a backtracking search, trying possibilities until it finds one which works, and backtracking when it can no longer make a legal move.
import MonadNondet (option)
import Sudoku
import System
import Control.Monad
forM = flip mapM
solve = forM [(i,j) | i <- [1..9], j <- [1..9]] $ \(i,j) -> do
v <- valAt (i,j) -- ^ for each board position
when (v == 0) $ do -- if it's empty (we represent that with a 0)
a <- option [1..9] -- pick a number
place (i,j) a -- and try to put it there
main = do
[f] <- getArgs
xs <- readFile f
putStrLn $ evalSudoku $ do { readSudoku xs; solve; showSudoku }
Now, to the meat of the thing, the monad which makes the above look so nice. We construct a monad which is suitable for maintaining Sudoku grids and trying options nondeterministically. Note that outside of this module, it's impossible to create a state which has an invalid Sudoku grid, since the only way to update the state handles the check to ensure that the move is legal.
{-# OPTIONS_GHC -fglasgow-exts #-}
module Sudoku
(Sudoku,
readSudoku,
runSudoku,
evalSudoku,
execSudoku,
showSudoku,
valAt, rowAt, colAt, boxAt,
place)
where
import Data.Array.Diff
import MonadNondet
import Control.Monad.State
-- Nondet here is a drop-in replacement for [] (the list monad) which just runs a little faster.
newtype Sudoku a = Sudoku (StateT (DiffUArray (Int,Int) Int) Nondet a)
deriving (Functor, Monad, MonadPlus)
{- -- That is, we could also use the following, which works exactly the same way.
newtype Sudoku a = Sudoku (StateT (DiffUArray (Int,Int) Int) [] a)
deriving (Functor, Monad, MonadPlus)
-}
initialSudokuArray = listArray ((1,1),(9,9)) [0,0..]
runSudoku (Sudoku k) = runNondet (runStateT k initialSudokuArray)
evalSudoku = fst . runSudoku
execSudoku = snd . runSudoku
showSudoku = Sudoku $ do
a <- get
return $ unlines [unwords [show (a ! (i,j)) | j <- [1..9]] | i <- [1..9]]
readSudoku :: String -> Sudoku ()
readSudoku xs = sequence_ $ do
(i,ys) <- zip [1..9] (lines xs)
(j,n) <- zip [1..9] (words ys)
return $ place (i,j) (read n)
valAt' (i,j) = do
a <- get
return (a ! (i,j))
rowAt' (i,j) = mapM valAt' [(i, k) | k <- [1..9]]
colAt' (i,j) = mapM valAt' [(k, j) | k <- [1..9]]
boxAt' (i,j) = mapM valAt' [(i' + u, j' + v) | u <- [1..3], v <- [1..3]]
where i' = ((i-1) `div` 3) * 3
j' = ((j-1) `div` 3) * 3
valAt = Sudoku . valAt'
rowAt = Sudoku . rowAt'
colAt = Sudoku . colAt'
boxAt = Sudoku . boxAt'
-- This is the least trivial part.
-- It just guards to make sure that the move is legal,
-- and updates the array in the state if it is.
place :: (Int,Int) -> Int -> Sudoku ()
place (i,j) n = Sudoku $ do
v <- valAt' (i,j)
when (v == 0 && n /= 0) $ do
rs <- rowAt' (i,j)
cs <- colAt' (i,j)
bs <- boxAt' (i,j)
guard $ not . any (== n) $ rs ++ cs ++ bs
a <- get
put (a // [((i,j),n)])
This is a fast NonDeterminism monad. It's a drop-in replacement for the list monad in this case. It's twice as fast when compiled with optimisations but a little slower without. You can also find it on the wiki at NonDeterminism.
I've made a few small modifications to this one to hopefully make it more concretely readable.
{-# OPTIONS_GHC -fglasgow-exts #-}
module MonadNondet where
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Identity
newtype NondetT m a
= NondetT { foldNondetT :: (forall b. (a -> m b -> m b) -> m b -> m b) }
runNondetT :: (Monad m) => NondetT m a -> m a
runNondetT m = foldNondetT m (\x xs -> return x) (error "No solution found.")
instance (Functor m) => Functor (NondetT m) where
fmap f (NondetT g) = NondetT (\cons nil -> g (cons . f) nil)
instance (Monad m) => Monad (NondetT m) where
return a = NondetT (\cons nil -> cons a nil)
m >>= k = NondetT (\cons nil -> foldNondetT m (\x -> foldNondetT (k x) cons) nil)
instance (Monad m) => MonadPlus (NondetT m) where
mzero = NondetT (\cons nil -> nil)
m1 `mplus` m2 = NondetT (\cons -> foldNondetT m1 cons . foldNondetT m2 cons)
instance MonadTrans NondetT where
lift m = NondetT (\cons nil -> m >>= \a -> cons a nil)
newtype Nondet a = Nondet (NondetT Identity a) deriving (Functor, Monad, MonadPlus)
runNondet (Nondet x) = runIdentity (runNondetT x)
foldNondet :: Nondet a -> (a -> b -> b) -> b -> b
foldNondet (Nondet nd) cons nil =
runIdentity $ foldNondetT nd (\x xs -> return (cons x (runIdentity xs))) (return nil)
option :: (MonadPlus m) => [a] -> m a
option = msum . map return
Simple Solver
By AlsonKemp. This solver is probably similar to Cale's but I don't grok the non-deterministic monad...
Note: this solver is exhaustive and will output all of the solutions, not just the first one. In order to make it non-exchaustive, add a case statement to solve' in order to check "r" and branch on the result.
import System
import Control.Monad
import Data.List
import Data.Array.IO
type SodokuBoard = IOArray Int Int
main = do
[f] <- getArgs
a <- newArray (1, 81) 0
readFile f >>= readSodokuBoard a
putStrLn "Original:"
printSodokuBoard a
putStrLn "Solutions:"
solve a (1,1)
readSodokuBoard a xs = sequence_ $ do (i,ys) <- zip [1..9] (lines xs)
(j,n) <- zip [1..9] (words ys)
return $ writeBoard a (j,i) (read n)
printSodokuBoard a =
let printLine a y =
mapM (\x -> readBoard a (x,y)) [1..9] >>= mapM_ (putStr . show) in
putStrLn "-----------" >>
mapM_ (\y -> putStr "|" >> printLine a y >> putStrLn "|") [1..9] >>
putStrLn "-----------"
-- the meat of the program. Checks the current square.
-- If 0, then get the list of nums and try to "solve' "
-- Otherwise, go to the next square.
solve :: SodokuBoard -> (Int, Int) -> IO (Maybe SodokuBoard)
solve a (10,y) = solve a (1,y+1)
solve a (_, 10)= printSodokuBoard a >> return (Just a)
solve a (x,y) = do v <- readBoard a (x,y)
case v of
0 -> availableNums a (x,y) >>= solve' a (x,y)
_ -> solve a (x+1,y)
-- solve' handles the backtacking
where solve' a (x,y) [] = return Nothing
solve' a (x,y) (v:vs) = do writeBoard a (x,y) v -- put a guess onto the board
r <- solve a (x+1,y)
writeBoard a (x,y) 0 -- remove the guess from the board
solve' a (x,y) vs -- recurse over the remainder of the list
-- get the "taken" numbers from a row, col or box.
getRowNums a y = sequence [readBoard a (x',y) | x' <- [1..9]]
getColNums a x = sequence [readBoard a (x,y') | y' <- [1..9]]
getBoxNums a (x,y) = sequence [readBoard a (x'+u, y'+v) | u <- [0..2], v <- [0..2]]
where x' = (3 * ((x-1) `quot` 3)) + 1
y' = (3 * ((y-1) `quot` 3)) + 1
-- return the numbers that are available for a particular square
availableNums a (x,y) = do r <- getRowNums a y
c <- getColNums a x
b <- getBoxNums a (x,y)
return $ [0..9] \\ (r `union` c `union` b)
-- aliases of read and write array that flatten the index
readBoard a (x,y) = readArray a (x+9*(y-1))
writeBoard a (x,y) e = writeArray a (x+9*(y-1)) e
Complete decision tree
By Henning Thielemann.
module Sudoku where
{-
This is inspired by John Hughes "Why Functional Programming Matters".
We build a complete decision tree.
That is, all alternatives in a certain depth
have the same number of determined values.
At the bottom of the tree all possible solutions can be found.
Actually the algorithm is very stupid:
In each depth we look for the field with the least admissible choices of numbers
and prune the alternative branches for the other fields.
-}
import Data.Char (ord, chr)
import Data.Array (Array, range, (!), (//))
import Data.Tree (Tree)
import qualified Data.Tree as Tree
import Data.List (sort, minimumBy)
import Data.Maybe (catMaybes, isNothing, fromMaybe, fromJust)
import qualified Data.Array as Array
{-
Example:
ghci -Wall Sudoku.hs
*Sudoku> mapM putCLn (solutions exampleHawiki0)
-}
{- [[ATree]] contains a list of possible alternatives for each position -}
data ATree a = ANode T [[ATree a]]
type Coord = Int
type Address = (Int,Int,Int,Int)
type Element = Int
type T = Array Address (Maybe Element)
type Complete = Array Address Element
fieldBounds :: (Address, Address)
fieldBounds = ((0,0,0,0), (2,2,2,2))
squareRange :: [(Coord, Coord)]
squareRange = range ((0,0), (2,2))
alphabet :: [Element]
alphabet = [1..9]
{- * solution -}
{-
Given two sorted lists,
remove the elements of the first list from the second one.
-}
deleteSorted :: Ord a => [a] -> [a] -> [a]
deleteSorted [] ys = ys
deleteSorted _ [] = []
deleteSorted (x:xs) (y:ys) =
case compare x y of
EQ -> deleteSorted xs ys
LT -> deleteSorted xs (y:ys)
GT -> y : deleteSorted (x:xs) ys
admissibleNumbers :: [[Maybe Element]] -> [Element]
admissibleNumbers =
foldl (flip deleteSorted) alphabet .
map (sort . catMaybes)
admissibleAdditions :: T -> Address -> [Element]
admissibleAdditions sudoku (i,j,k,l) =
admissibleNumbers (map ($ sudoku)
[selectRow (i,k),
selectColumn (j,l),
selectSquare (i,j)])
allAdmissibleAdditions :: T -> [(Address, [Element])]
allAdmissibleAdditions sudoku =
let adds addr =
(addr, admissibleAdditions sudoku addr)
in map adds
(map fst (filter (isNothing . snd)
(Array.assocs sudoku)))
solutionTree :: T -> ATree T
solutionTree sudoku =
let new (addr,elms) =
map (\elm -> solutionTree (sudoku // [(addr, Just elm)])) elms
in ANode sudoku (map new (allAdmissibleAdditions sudoku))
treeAltToStandard :: ATree T -> Tree T
treeAltToStandard (ANode sudoku subs) =
Tree.Node sudoku (concatMap (map treeAltToStandard) subs)
{- Convert a tree with alternatives for each position (ATree)
into a normal tree by choosing one position and its alternative values.
We need to consider only one position per level
because the remaining positions are processed in the sub-levels.
With other words: Choosing more than one position
would lead to multiple reports of the same solution.
For reasons of efficiency
we choose the position with the least number of alternatives.
If this number is zero, the numbers tried so far are wrong.
If this number is one, then the choice is unique, but maybe still wrong.
If the number of alternatives is larger,
we have to check each alternative.
-}
treeAltToStandardOptimize :: ATree T -> Tree T
treeAltToStandardOptimize (ANode sudoku subs) =
let chooseMinLen [] = []
chooseMinLen xs = minimumBy compareLength xs
in Tree.Node sudoku (chooseMinLen
(map (map treeAltToStandardOptimize) subs))
maybeComplete :: T -> Maybe Complete
maybeComplete sudoku =
fmap (Array.array fieldBounds)
(mapM (uncurry (fmap . (,))) (Array.assocs sudoku))
{- All leafs are at the same depth,
namely the number of undetermined fields.
That's why we can safely select all Sudokus at the lowest level. -}
solutions :: T -> [Complete]
solutions sudoku =
let err = error "The lowest level should contain complete Sudokus only."
{- "last'" is more efficient than "last" here
because the program does not have to check
whether deeper levels exist.
We know that the tree is as deep
as the number of undefined fields.
This means that dropMatch returns a singleton list.
We don't check that
because then we would lose the efficiency again. -}
last' = head . dropMatch (filter isNothing (Array.elems sudoku))
in map (fromMaybe err . maybeComplete)
(last' (Tree.levels
(treeAltToStandardOptimize (solutionTree sudoku))))
{- * transformations (can be used for construction, too) -}
standard :: Complete
standard =
Array.listArray fieldBounds
(map (\(i,j,k,l) -> mod (j+k) 3 * 3 + mod (i+l) 3 + 1)
(range fieldBounds))
exampleHawiki0, exampleHawiki1 :: T
exampleHawiki0 = fromString (unlines [
" 5 6 1",
" 48 7 ",
"8 52",
"2 57 3 ",
" ",
" 3 69 5",
"79 8",
" 1 65 ",
"5 3 6 "
])
exampleHawiki1 = fromString (unlines [
" 6 8 ",
" 2 ",
" 1 ",
" 7 1 2",
"5 3 ",
" 4 ",
" 42 1 ",
"3 7 6 ",
" 5 "
])
check :: Complete -> Bool
check sudoku =
let checkParts select =
all (\addr -> sort (select addr sudoku) == alphabet) squareRange
in all checkParts [selectRow, selectColumn, selectSquare]
selectRow, selectColumn, selectSquare ::
(Coord,Coord) -> Array Address element -> [element]
selectRow (i,k) sudoku =
map (sudoku!) (range ((i,0,k,0), (i,2,k,2)))
-- map (sudoku!) (map (\(j,l) -> (i,j,k,l)) squareRange)
selectColumn (j,l) sudoku =
map (sudoku!) (range ((0,j,0,l), (2,j,2,l)))
selectSquare (i,j) sudoku =
map (sudoku!) (range ((i,j,0,0), (i,j,2,2)))
{- * conversion from and to strings -}
put, putLn :: T -> IO ()
put sudoku = putStr (toString sudoku)
putLn sudoku = putStrLn (toString sudoku)
putC, putCLn :: Complete -> IO ()
putC sudoku = putStr (toString (fmap Just sudoku))
putCLn sudoku = putStrLn (toString (fmap Just sudoku))
fromString :: String -> T
fromString str =
Array.array fieldBounds (concat
(zipWith (\(i,k) -> map (\((j,l),x) -> ((i,j,k,l),x)))
squareRange
(map (zip squareRange . map charToElem) (lines str))))
toString :: T -> String
toString sudoku =
unlines
(map (\(i,k) -> map (\(j,l) -> elemToChar (sudoku!(i,j,k,l)))
squareRange)
squareRange)
charToElem :: Char -> Maybe Element
charToElem c =
toMaybe ('0'<=c && c<='9') (ord c - ord '0')
elemToChar :: Maybe Element -> Char
elemToChar =
maybe ' ' (\c -> chr (ord '0' + c))
{- * helper functions -}
nest :: Int -> (a -> a) -> a -> a
nest 0 _ x = x
nest n f x = f (nest (n-1) f x)
toMaybe :: Bool -> a -> Maybe a
toMaybe False _ = Nothing
toMaybe True x = Just x
compareLength :: [a] -> [b] -> Ordering
compareLength (_:xs) (_:ys) = compareLength xs ys
compareLength [] [] = EQ
compareLength (_:_) [] = GT
compareLength [] (_:_) = LT
{- | Drop as many elements as the first list is long -}
dropMatch :: [b] -> [a] -> [a]
dropMatch xs ys =
map fromJust (dropWhile isNothing
(zipWith (toMaybe . null) (iterate (drop 1) xs) ys))
No guessing
By Simon Peyton Jones.
Since this page is here I thought I'd add a solver I wrote sometime last year. The main constraint I imposed is that it never guesses, and that it outputs a human-comprehensible explanation of every step of its reasoning. That means there are some puzzles it can't solve. I'd be interested to know if there are any puzzles that it gets stuck on where there is a no-guessing way forward. I made no attempt to make it fast.
There are two files: Media:SudokuPJ.hs and Media:TestPJ.hs. The latter just contains a bunch of test cases; I was too lazy to write a proper parser.
The main entry point is:
run1 :: Verbosity -> [String] -> Doc data Verbosity = All | Terse | Final
The [String] the starting board configuration (see the tests file).
Just guessing
By Chris Kuklewicz
This solver is an implementation of Knuth's "Dancing Links" algorithm for solving binary-cover problems. This algorithm represents the constraints as a sparse binary matrix, with 1's as linked nodes. The nodes are in a vertical and a horizontal doubly linked list, and each vertical list is headed by another node that represents one of the constraints. It is interesting as an example of the rare beast in Haskell: a mutable data structure. The code has been rewritten and cleaned up here Media:DancingSudoku.lhs. Its main routine is designed to handle the input from sudoku17 on stdin. Currently it only returns the first solution or calls an error, it can be modified (see comments in the file) to return all solutions in a list. An earlier version used ST.Lazy instead of ST.Strict which made operating on puzzles with many solutions more tractable.
Other trivia: It uses "mdo" and lazyness to initialize some of the doubly linked lists.
Generalized solver
By Thorkil Naur
This Su Doku solver is able to solve classes of Su Doku puzzles that extend the ordinary 9*9 puzzles. The documentation describes the solver and also some (to the present author at least) surprising properties of various reduction strategies used when solving Su Doku puzzles.
The following files comprise the Su Doku solver and related code:
Media:Format.hs Media:Merge.hs Media:SdkMSol2.hs Media:SortByF.hs Media:SuDoku.hs Media:t40.hs Media:t44.hs Media:Test.hs
For an example of use, the command
runhugs SdkMSol2 \ tn1 \ Traditional 3 \ -#123456789 \ 1-53---9- \ ---6----- \ ------271 \ 82------- \ ---487--- \ ------53- \ 23------- \ --7-59--- \ --6---8-4
produces output that, among other things, contain
tn1: Solutions: 1 7 5 3 2 8 4 9 6 9 4 2 6 7 1 3 8 5 3 6 8 5 9 4 2 7 1 8 2 9 1 3 5 6 4 7 6 5 3 4 8 7 9 1 2 7 1 4 9 6 2 5 3 8 2 3 1 8 4 6 7 5 9 4 8 7 2 5 9 1 6 3 5 9 6 7 1 3 8 2 4
Simple Small Solver
I haven't looked at the other solvers in detail yet, so I'm not sure what is good or bad about mine, but here it is:
http://darcs.brianweb.net/sudoku/Sudoku.pdf http://darcs.brianweb.net/sudoku/src/Sudoku.lhs
-Brian Alliet <brian@brianweb.net>
Add Your Own
If you have a Sudoku solver you're proud of, put it here. This ought to be a good way of helping people learn some fun, intermediate-advanced techniques in Haskell.
Test Boards
Here's an input file to test the solvers on. Zeroes represent blanks.
0 5 0 0 6 0 0 0 1 0 0 4 8 0 0 0 7 0 8 0 0 0 0 0 0 5 2 2 0 0 0 5 7 0 3 0 0 0 0 0 0 0 0 0 0 0 3 0 6 9 0 0 0 5 7 9 0 0 0 0 0 0 8 0 1 0 0 0 6 5 0 0 5 0 0 0 3 0 0 6 0
A nefarious one:
0 0 0 0 6 0 0 8 0 0 2 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 7 0 0 0 0 1 0 2 5 0 0 0 3 0 0 0 0 0 0 0 0 0 0 4 0 0 0 0 4 2 0 1 0 0 0 3 0 0 7 0 0 6 0 0 0 0 0 0 0 0 0 5 0
Chris Kuklewicz writes, "You can go get the 36,628 distict minimal puzzles from csse.uwa.edu that have only 17 clues. Then you can run all of them through your program to locate the most evil ones, and use them on your associates."