https://wiki.haskell.org/api.php?action=feedcontributions&user=Lennart&feedformat=atomHaskellWiki - User contributions [en]2024-03-29T15:00:14ZUser contributionsMediaWiki 1.35.5https://wiki.haskell.org/index.php?title=Sudoku&diff=4711Sudoku2006-07-13T14:03:31Z<p>Lennart: </p>
<hr />
<div>[[Category:Idioms]]<br />
<br />
Here are a few Sudoku solvers coded up in Haskell...<br />
<br />
== Serious, Non-Deterministic Solver ==<br />
<br />
Here is a solver by CaleGibbard [http://www.haskell.org/hawiki/CaleGibbard/BSDLicense]. 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.<br />
<br />
<haskell><br />
import MonadNondet (option)<br />
import Sudoku<br />
import System<br />
import Control.Monad<br />
<br />
forM = flip mapM<br />
<br />
solve = forM [(i,j) | i <- [1..9], j <- [1..9]] $ \(i,j) -> do<br />
v <- valAt (i,j) -- ^ for each board position<br />
when (v == 0) $ do -- if it's empty (we represent that with a 0)<br />
a <- option [1..9] -- pick a number<br />
place (i,j) a -- and try to put it there<br />
<br />
main = do<br />
[f] <- getArgs<br />
xs <- readFile f<br />
putStrLn $ evalSudoku $ do { readSudoku xs; solve; showSudoku }<br />
</haskell><br />
<br />
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.<br />
<br />
<haskell><br />
{-# OPTIONS_GHC -fglasgow-exts #-}<br />
module Sudoku <br />
(Sudoku,<br />
readSudoku,<br />
runSudoku,<br />
evalSudoku,<br />
execSudoku,<br />
showSudoku,<br />
valAt, rowAt, colAt, boxAt,<br />
place)<br />
where<br />
import Data.Array.Diff<br />
import MonadNondet<br />
import Control.Monad.State<br />
<br />
-- Nondet here is a drop-in replacement for [] (the list monad) which just runs a little faster.<br />
newtype Sudoku a = Sudoku (StateT (DiffUArray (Int,Int) Int) Nondet a)<br />
deriving (Functor, Monad, MonadPlus)<br />
<br />
{- -- That is, we could also use the following, which works exactly the same way.<br />
newtype Sudoku a = Sudoku (StateT (DiffUArray (Int,Int) Int) [] a)<br />
deriving (Functor, Monad, MonadPlus)<br />
-}<br />
<br />
initialSudokuArray = listArray ((1,1),(9,9)) [0,0..]<br />
<br />
runSudoku (Sudoku k) = runNondet (runStateT k initialSudokuArray)<br />
<br />
evalSudoku = fst . runSudoku<br />
execSudoku = snd . runSudoku<br />
<br />
showSudoku = Sudoku $ do<br />
a <- get<br />
return $ unlines [unwords [show (a ! (i,j)) | j <- [1..9]] | i <- [1..9]]<br />
<br />
readSudoku :: String -> Sudoku ()<br />
readSudoku xs = sequence_ $ do<br />
(i,ys) <- zip [1..9] (lines xs)<br />
(j,n) <- zip [1..9] (words ys)<br />
return $ place (i,j) (read n)<br />
<br />
valAt' (i,j) = do<br />
a <- get<br />
return (a ! (i,j))<br />
<br />
rowAt' (i,j) = mapM valAt' [(i, k) | k <- [1..9]]<br />
<br />
colAt' (i,j) = mapM valAt' [(k, j) | k <- [1..9]] <br />
<br />
boxAt' (i,j) = mapM valAt' [(i' + u, j' + v) | u <- [1..3], v <- [1..3]]<br />
where i' = ((i-1) `div` 3) * 3<br />
j' = ((j-1) `div` 3) * 3<br />
<br />
valAt = Sudoku . valAt'<br />
rowAt = Sudoku . rowAt'<br />
colAt = Sudoku . colAt'<br />
boxAt = Sudoku . boxAt'<br />
<br />
-- This is the least trivial part.<br />
-- It just guards to make sure that the move is legal,<br />
-- and updates the array in the state if it is.<br />
place :: (Int,Int) -> Int -> Sudoku ()<br />
place (i,j) n = Sudoku $ do<br />
v <- valAt' (i,j)<br />
when (v == 0 && n /= 0) $ do<br />
rs <- rowAt' (i,j)<br />
cs <- colAt' (i,j)<br />
bs <- boxAt' (i,j)<br />
guard $ not . any (== n) $ rs ++ cs ++ bs<br />
a <- get<br />
put (a // [((i,j),n)])<br />
</haskell><br />
<br />
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.<br />
<br />
I've made a few small modifications to this one to hopefully make it more concretely readable.<br />
<br />
<haskell><br />
{-# OPTIONS_GHC -fglasgow-exts #-}<br />
<br />
module MonadNondet where<br />
<br />
import Control.Monad<br />
import Control.Monad.Trans<br />
<br />
import Control.Monad.Identity<br />
<br />
newtype NondetT m a<br />
= NondetT { foldNondetT :: (forall b. (a -> m b -> m b) -> m b -> m b) }<br />
<br />
runNondetT :: (Monad m) => NondetT m a -> m a<br />
runNondetT m = foldNondetT m (\x xs -> return x) (error "No solution found.")<br />
<br />
instance (Functor m) => Functor (NondetT m) where<br />
fmap f (NondetT g) = NondetT (\cons nil -> g (cons . f) nil)<br />
<br />
instance (Monad m) => Monad (NondetT m) where<br />
return a = NondetT (\cons nil -> cons a nil)<br />
m >>= k = NondetT (\cons nil -> foldNondetT m (\x -> foldNondetT (k x) cons) nil)<br />
<br />
instance (Monad m) => MonadPlus (NondetT m) where<br />
mzero = NondetT (\cons nil -> nil)<br />
m1 `mplus` m2 = NondetT (\cons -> foldNondetT m1 cons . foldNondetT m2 cons)<br />
<br />
instance MonadTrans NondetT where<br />
lift m = NondetT (\cons nil -> m >>= \a -> cons a nil)<br />
<br />
newtype Nondet a = Nondet (NondetT Identity a) deriving (Functor, Monad, MonadPlus)<br />
runNondet (Nondet x) = runIdentity (runNondetT x)<br />
<br />
foldNondet :: Nondet a -> (a -> b -> b) -> b -> b<br />
foldNondet (Nondet nd) cons nil =<br />
runIdentity $ foldNondetT nd (\x xs -> return (cons x (runIdentity xs))) (return nil)<br />
<br />
option :: (MonadPlus m) => [a] -> m a<br />
option = msum . map return<br />
</haskell><br />
<br />
<br />
<br />
<br />
== Simple Solver ==<br />
<br />
By AlsonKemp. This solver is probably similar to Cale's but I don't grok the non-deterministic monad...<br />
<br />
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.<br />
<br />
<haskell><br />
import System<br />
import Control.Monad<br />
import Data.List<br />
import Data.Array.IO<br />
<br />
type SodokuBoard = IOArray Int Int<br />
<br />
main = do<br />
[f] <- getArgs<br />
a <- newArray (1, 81) 0<br />
readFile f >>= readSodokuBoard a<br />
putStrLn "Original:"<br />
printSodokuBoard a<br />
putStrLn "Solutions:"<br />
solve a (1,1)<br />
<br />
readSodokuBoard a xs = sequence_ $ do (i,ys) <- zip [1..9] (lines xs)<br />
(j,n) <- zip [1..9] (words ys)<br />
return $ writeBoard a (j,i) (read n)<br />
<br />
printSodokuBoard a =<br />
let printLine a y =<br />
mapM (\x -> readBoard a (x,y)) [1..9] >>= mapM_ (putStr . show) in<br />
putStrLn "-----------" >> <br />
mapM_ (\y -> putStr "|" >> printLine a y >> putStrLn "|") [1..9] >> <br />
putStrLn "-----------"<br />
<br />
-- the meat of the program. Checks the current square.<br />
-- If 0, then get the list of nums and try to "solve' "<br />
-- Otherwise, go to the next square.<br />
solve :: SodokuBoard -> (Int, Int) -> IO (Maybe SodokuBoard)<br />
solve a (10,y) = solve a (1,y+1)<br />
solve a (_, 10)= printSodokuBoard a >> return (Just a)<br />
solve a (x,y) = do v <- readBoard a (x,y)<br />
case v of<br />
0 -> availableNums a (x,y) >>= solve' a (x,y)<br />
_ -> solve a (x+1,y)<br />
-- solve' handles the backtacking<br />
where solve' a (x,y) [] = return Nothing<br />
solve' a (x,y) (v:vs) = do writeBoard a (x,y) v -- put a guess onto the board<br />
r <- solve a (x+1,y)<br />
writeBoard a (x,y) 0 -- remove the guess from the board<br />
solve' a (x,y) vs -- recurse over the remainder of the list<br />
<br />
-- get the "taken" numbers from a row, col or box.<br />
getRowNums a y = sequence [readBoard a (x',y) | x' <- [1..9]]<br />
getColNums a x = sequence [readBoard a (x,y') | y' <- [1..9]]<br />
getBoxNums a (x,y) = sequence [readBoard a (x'+u, y'+v) | u <- [0..2], v <- [0..2]] <br />
where x' = (3 * ((x-1) `quot` 3)) + 1<br />
y' = (3 * ((y-1) `quot` 3)) + 1<br />
<br />
-- return the numbers that are available for a particular square<br />
availableNums a (x,y) = do r <- getRowNums a y <br />
c <- getColNums a x<br />
b <- getBoxNums a (x,y)<br />
return $ [0..9] \\ (r `union` c `union` b) <br />
<br />
-- aliases of read and write array that flatten the index<br />
readBoard a (x,y) = readArray a (x+9*(y-1))<br />
writeBoard a (x,y) e = writeArray a (x+9*(y-1)) e<br />
</haskell><br />
<br />
== Complete decision tree ==<br />
<br />
By Henning Thielemann.<br />
<br />
<haskell><br />
module Sudoku where<br />
<br />
{-<br />
This is inspired by John Hughes "Why Functional Programming Matters".<br />
We build a complete decision tree.<br />
That is, all alternatives in a certain depth<br />
have the same number of determined values.<br />
At the bottom of the tree all possible solutions can be found.<br />
Actually the algorithm is very stupid:<br />
In each depth we look for the field with the least admissible choices of numbers<br />
and prune the alternative branches for the other fields.<br />
-}<br />
<br />
import Data.Char (ord, chr)<br />
import Data.Array (Array, range, (!), (//))<br />
import Data.Tree (Tree)<br />
import qualified Data.Tree as Tree<br />
import Data.List (sort, minimumBy)<br />
import Data.Maybe (catMaybes, isNothing, fromMaybe, fromJust)<br />
import qualified Data.Array as Array<br />
<br />
{-<br />
Example:<br />
<br />
ghci -Wall Sudoku.hs<br />
<br />
*Sudoku> mapM putCLn (solutions exampleHawiki0)<br />
-}<br />
<br />
<br />
{- [[ATree]] contains a list of possible alternatives for each position -}<br />
data ATree a = ANode T [[ATree a]]<br />
<br />
type Coord = Int<br />
type Address = (Int,Int,Int,Int)<br />
type Element = Int<br />
<br />
type T = Array Address (Maybe Element)<br />
type Complete = Array Address Element<br />
<br />
fieldBounds :: (Address, Address)<br />
fieldBounds = ((0,0,0,0), (2,2,2,2))<br />
<br />
squareRange :: [(Coord, Coord)]<br />
squareRange = range ((0,0), (2,2))<br />
<br />
alphabet :: [Element]<br />
alphabet = [1..9]<br />
<br />
<br />
<br />
{- * solution -}<br />
<br />
{-<br />
Given two sorted lists,<br />
remove the elements of the first list from the second one.<br />
-}<br />
deleteSorted :: Ord a => [a] -> [a] -> [a]<br />
deleteSorted [] ys = ys<br />
deleteSorted _ [] = []<br />
deleteSorted (x:xs) (y:ys) =<br />
case compare x y of<br />
EQ -> deleteSorted xs ys<br />
LT -> deleteSorted xs (y:ys)<br />
GT -> y : deleteSorted (x:xs) ys<br />
<br />
admissibleNumbers :: [[Maybe Element]] -> [Element]<br />
admissibleNumbers =<br />
foldl (flip deleteSorted) alphabet .<br />
map (sort . catMaybes)<br />
<br />
admissibleAdditions :: T -> Address -> [Element]<br />
admissibleAdditions sudoku (i,j,k,l) =<br />
admissibleNumbers (map ($ sudoku)<br />
[selectRow (i,k),<br />
selectColumn (j,l),<br />
selectSquare (i,j)])<br />
<br />
allAdmissibleAdditions :: T -> [(Address, [Element])]<br />
allAdmissibleAdditions sudoku =<br />
let adds addr =<br />
(addr, admissibleAdditions sudoku addr)<br />
in map adds<br />
(map fst (filter (isNothing . snd)<br />
(Array.assocs sudoku)))<br />
<br />
<br />
<br />
solutionTree :: T -> ATree T<br />
solutionTree sudoku =<br />
let new (addr,elms) =<br />
map (\elm -> solutionTree (sudoku // [(addr, Just elm)])) elms<br />
in ANode sudoku (map new (allAdmissibleAdditions sudoku))<br />
<br />
treeAltToStandard :: ATree T -> Tree T<br />
treeAltToStandard (ANode sudoku subs) =<br />
Tree.Node sudoku (concatMap (map treeAltToStandard) subs)<br />
<br />
{- Convert a tree with alternatives for each position (ATree)<br />
into a normal tree by choosing one position and its alternative values.<br />
We need to consider only one position per level<br />
because the remaining positions are processed in the sub-levels.<br />
With other words: Choosing more than one position<br />
would lead to multiple reports of the same solution.<br />
<br />
For reasons of efficiency<br />
we choose the position with the least number of alternatives.<br />
If this number is zero, the numbers tried so far are wrong.<br />
If this number is one, then the choice is unique, but maybe still wrong.<br />
If the number of alternatives is larger,<br />
we have to check each alternative.<br />
-}<br />
treeAltToStandardOptimize :: ATree T -> Tree T<br />
treeAltToStandardOptimize (ANode sudoku subs) =<br />
let chooseMinLen [] = []<br />
chooseMinLen xs = minimumBy compareLength xs<br />
in Tree.Node sudoku (chooseMinLen<br />
(map (map treeAltToStandardOptimize) subs))<br />
<br />
maybeComplete :: T -> Maybe Complete<br />
maybeComplete sudoku =<br />
fmap (Array.array fieldBounds)<br />
(mapM (uncurry (fmap . (,))) (Array.assocs sudoku))<br />
<br />
{- All leafs are at the same depth,<br />
namely the number of undetermined fields.<br />
That's why we can safely select all Sudokus at the lowest level. -}<br />
solutions :: T -> [Complete]<br />
solutions sudoku =<br />
let err = error "The lowest level should contain complete Sudokus only."<br />
{- "last'" is more efficient than "last" here<br />
because the program does not have to check<br />
whether deeper levels exist.<br />
We know that the tree is as deep<br />
as the number of undefined fields.<br />
This means that dropMatch returns a singleton list.<br />
We don't check that<br />
because then we would lose the efficiency again. -}<br />
last' = head . dropMatch (filter isNothing (Array.elems sudoku))<br />
in map (fromMaybe err . maybeComplete)<br />
(last' (Tree.levels<br />
(treeAltToStandardOptimize (solutionTree sudoku))))<br />
<br />
<br />
<br />
{- * transformations (can be used for construction, too) -}<br />
<br />
standard :: Complete<br />
standard =<br />
Array.listArray fieldBounds<br />
(map (\(i,j,k,l) -> mod (j+k) 3 * 3 + mod (i+l) 3 + 1)<br />
(range fieldBounds))<br />
<br />
<br />
exampleHawiki0, exampleHawiki1 :: T<br />
exampleHawiki0 = fromString (unlines [<br />
" 5 6 1",<br />
" 48 7 ",<br />
"8 52",<br />
"2 57 3 ",<br />
" ",<br />
" 3 69 5",<br />
"79 8",<br />
" 1 65 ",<br />
"5 3 6 "<br />
])<br />
<br />
exampleHawiki1 = fromString (unlines [<br />
" 6 8 ",<br />
" 2 ",<br />
" 1 ",<br />
" 7 1 2",<br />
"5 3 ",<br />
" 4 ",<br />
" 42 1 ",<br />
"3 7 6 ",<br />
" 5 "<br />
])<br />
<br />
<br />
<br />
<br />
check :: Complete -> Bool<br />
check sudoku =<br />
let checkParts select =<br />
all (\addr -> sort (select addr sudoku) == alphabet) squareRange<br />
in all checkParts [selectRow, selectColumn, selectSquare]<br />
<br />
selectRow, selectColumn, selectSquare ::<br />
(Coord,Coord) -> Array Address element -> [element]<br />
selectRow (i,k) sudoku =<br />
map (sudoku!) (range ((i,0,k,0), (i,2,k,2)))<br />
-- map (sudoku!) (map (\(j,l) -> (i,j,k,l)) squareRange)<br />
selectColumn (j,l) sudoku =<br />
map (sudoku!) (range ((0,j,0,l), (2,j,2,l)))<br />
selectSquare (i,j) sudoku =<br />
map (sudoku!) (range ((i,j,0,0), (i,j,2,2)))<br />
<br />
<br />
{- * conversion from and to strings -}<br />
<br />
put, putLn :: T -> IO ()<br />
put sudoku = putStr (toString sudoku)<br />
putLn sudoku = putStrLn (toString sudoku)<br />
<br />
putC, putCLn :: Complete -> IO ()<br />
putC sudoku = putStr (toString (fmap Just sudoku))<br />
putCLn sudoku = putStrLn (toString (fmap Just sudoku))<br />
<br />
fromString :: String -> T<br />
fromString str =<br />
Array.array fieldBounds (concat<br />
(zipWith (\(i,k) -> map (\((j,l),x) -> ((i,j,k,l),x)))<br />
squareRange<br />
(map (zip squareRange . map charToElem) (lines str))))<br />
<br />
toString :: T -> String<br />
toString sudoku =<br />
unlines<br />
(map (\(i,k) -> map (\(j,l) -> elemToChar (sudoku!(i,j,k,l)))<br />
squareRange)<br />
squareRange)<br />
<br />
charToElem :: Char -> Maybe Element<br />
charToElem c =<br />
toMaybe ('0'<=c && c<='9') (ord c - ord '0')<br />
<br />
elemToChar :: Maybe Element -> Char<br />
elemToChar =<br />
maybe ' ' (\c -> chr (ord '0' + c))<br />
<br />
<br />
{- * helper functions -}<br />
<br />
nest :: Int -> (a -> a) -> a -> a<br />
nest 0 _ x = x<br />
nest n f x = f (nest (n-1) f x)<br />
<br />
toMaybe :: Bool -> a -> Maybe a<br />
toMaybe False _ = Nothing<br />
toMaybe True x = Just x<br />
<br />
compareLength :: [a] -> [b] -> Ordering<br />
compareLength (_:xs) (_:ys) = compareLength xs ys<br />
compareLength [] [] = EQ<br />
compareLength (_:_) [] = GT<br />
compareLength [] (_:_) = LT<br />
<br />
{- | Drop as many elements as the first list is long -}<br />
dropMatch :: [b] -> [a] -> [a]<br />
dropMatch xs ys =<br />
map fromJust (dropWhile isNothing<br />
(zipWith (toMaybe . null) (iterate (drop 1) xs) ys))<br />
</haskell><br />
<br />
<br />
== No guessing ==<br />
<br />
By Simon Peyton Jones.<br />
<br />
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.<br />
<br />
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.<br />
<br />
The main entry point is:<br />
<pre><br />
run1 :: Verbosity -> [String] -> Doc<br />
data Verbosity = All | Terse | Final<br />
</pre><br />
The <tt>[String]</tt> the starting board configuration (see the tests file).<br />
<br />
== Just guessing ==<br />
<br />
By ChrisKuklewicz<br />
<br />
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 [http://www.csse.uwa.edu.au/~gordon/sudoku17 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.<br />
<br />
Other trivia: It uses "mdo" and lazyness to initialize some of the doubly linked lists.<br />
<br />
== Very Smart, with only a little guessing ==<br />
<br />
by ChrisKuklewicz<br />
<br />
This solver does its best to avoid the branch and guess approach. On the 36628 puzzles of [http://www.csse.uwa.edu.au/~gordon/sudokumin.php length 17] it resorts to guessing on only 164. This extra strength comes from examining the constraints that can only be solved in exactly two ways, and how these constraints overlap and interact with each other and remaining possibilities.<br />
<br />
The [http://evenmere.org/~chrisk/chris-sudoku-deduce.tar.gz source code] compiles to take a list of puzzles as input and produces a description of the number of (good and total) guesses required, as well as a shuffled version of the input. If there was guessing, then the shuffled version could be sent back into the solver to see how the difficulty depended on luck. The list of 164 hard puzzles is included with the source code. The Deduce.hs file contains comments.<br />
<br />
The data is stored in a 9x9x9 boolean array, and the only operations are turning off possibilities and branching. For performance the array is thawed, mutated, and frozen. On the set of 36628 puzzles the speed averages 9.4 puzzles solved per second on a 1.33 GHz G4 (ghc-6.4.1 on OS X). I liked the 9x9x9 array since it emphasized the symmetry of the problem.<br />
<br />
== Generalized solver ==<br />
<br />
By Thorkil Naur<br />
<br />
This Su Doku solver is able to solve classes of Su Doku puzzles that extend the ordinary 9*9 puzzles. The [[SuDokuThorkilNaurDocument|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.<br />
<br />
The following files comprise the Su Doku solver and related code:<br />
<br />
[[Media:Format.hs]]<br />
[[Media:Merge.hs]]<br />
[[Media:SdkMSol2.hs]]<br />
[[Media:SortByF.hs]]<br />
[[Media:SuDoku.hs]]<br />
[[Media:t40.hs]]<br />
[[Media:t44.hs]]<br />
[[Media:Test.hs]]<br />
<br />
For an example of use, the command<br />
<br />
<pre><br />
runhugs SdkMSol2 \<br />
tn1 \<br />
Traditional 3 \<br />
-#123456789 \<br />
1-53---9- \<br />
---6----- \<br />
------271 \<br />
82------- \<br />
---487--- \<br />
------53- \<br />
23------- \<br />
--7-59--- \<br />
--6---8-4<br />
</pre><br />
<br />
produces output that, among other things, contain<br />
<br />
<pre><br />
tn1: Solutions:<br />
1 7 5 3 2 8 4 9 6<br />
9 4 2 6 7 1 3 8 5<br />
3 6 8 5 9 4 2 7 1<br />
8 2 9 1 3 5 6 4 7<br />
6 5 3 4 8 7 9 1 2<br />
7 1 4 9 6 2 5 3 8<br />
2 3 1 8 4 6 7 5 9<br />
4 8 7 2 5 9 1 6 3<br />
5 9 6 7 1 3 8 2 4<br />
</pre><br />
<br />
== Simple Small Solver ==<br />
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:<br />
<br />
http://darcs.brianweb.net/sudoku/Sudoku.pdf<br />
http://darcs.brianweb.net/sudoku/src/Sudoku.lhs<br />
<br />
-Brian Alliet <brian@brianweb.net><br />
<br />
== Backtrack Monad Solver ==<br />
<br />
This is a simple but fast solver that uses standard<br />
monads from the [[MonadTemplateLibrary]] in the [[StandardLibraries]].<br />
<br />
Besides being Yet Another Example of a Sudoko solver,<br />
I think it is also a nice somewhat-nontrivial example of<br />
monads in practice.<br />
<br />
The idea is that the monad StateT s [] does backtracking.<br />
It means "iterate over a list while keeping state,<br />
but re-initialize to the original state on each iteration".<br />
<br />
I have several (Unix command line) front-ends to this<br />
module, available upon request. The one I use most creates<br />
and prints six new Sudoku puzzles on a page, with<br />
fine-grain control over the difficulty of the puzzle.<br />
This has made me quite popular among friends and<br />
extended family.<br />
<br />
- [[YitzGale]]<br />
<br />
<haskell><br />
{-# OPTIONS_GHC -fglasgow-exts #-}<br />
<br />
-- Solve a Sudoku puzzle<br />
<br />
module Sudoku where<br />
<br />
import Control.Monad.State<br />
import Data.Maybe (maybeToList)<br />
import Data.List (delete)<br />
<br />
type Value = Int<br />
type Cell = (Int, Int) -- One-based coordinates<br />
<br />
type Puzzle = [[Maybe Value]]<br />
type Solution = [[Value]]<br />
<br />
-- The size of the puzzle.<br />
sqrtSize :: Int<br />
sqrtSize = 3<br />
size = sqrtSize * sqrtSize<br />
<br />
-- Besides the rows and columns, a Sudoku puzzle contains s blocks<br />
-- of s cells each, where s = size.<br />
blocks :: [[Cell]]<br />
blocks = [[(x + i, y + j) | i <- [1..sqrtSize], j <- [1..sqrtSize]] |<br />
x <- [0,sqrtSize..size-sqrtSize],<br />
y <- [0,sqrtSize..size-sqrtSize]]<br />
<br />
-- The one-based number of the block that a cell is contained in.<br />
blockNum :: Cell -> Int<br />
blockNum (row, col) = row - (row - 1) `mod` sqrtSize + (col - 1) `div` sqrtSize<br />
<br />
-- When a Sudoku puzzle has been partially filled in, the following<br />
-- data structure represents the remaining options for how to proceed.<br />
data Options = Options {<br />
cellOpts :: [[[Value]]], -- For each cell, a list of possible values<br />
rowOpts :: [[[Cell ]]], -- For each row and value, a list of cells<br />
colOpts :: [[[Cell ]]], -- For each column and value, a list of cells<br />
blkOpts :: [[[Cell ]]] -- For each block and value, a list of cells<br />
} deriving Show<br />
modifyCellOpts f = do {opts <- get; put $ opts {cellOpts = f $ cellOpts opts}}<br />
modifyRowOpts f = do {opts <- get; put $ opts {rowOpts = f $ rowOpts opts}}<br />
modifyColOpts f = do {opts <- get; put $ opts {colOpts = f $ colOpts opts}}<br />
modifyBlkOpts f = do {opts <- get; put $ opts {blkOpts = f $ blkOpts opts}}<br />
<br />
-- The full set of initial options, before any cells are constrained<br />
initOptions :: Options<br />
initOptions = Options {<br />
cellOpts = [[[1..size] | _ <- [1..size]] | _ <- [1..size]],<br />
rowOpts = [[[(r, c) | c <- [1..size]] | _ <- [1..size]] | r <- [1..size]],<br />
colOpts = [[[(r, c) | r <- [1..size]] | _ <- [1..size]] | c <- [1..size]],<br />
blkOpts = [[b | _ <- [1..size]] | b <- blocks]}<br />
<br />
solve :: Puzzle -> [Solution]<br />
solve puz = evalStateT (initPuzzle >> solutions) initOptions<br />
where<br />
initPuzzle =<br />
sequence_ [fixCell v (r, c) | (row, r) <- zip puz [1..],<br />
(val, c) <- zip row [1..],<br />
v <- maybeToList val]<br />
<br />
-- Build a list of all possible solutions given the current options.<br />
-- We use a list monad INSIDE a state monad. That way,<br />
-- the state is re-initialized on each element of the list iteration,<br />
-- allowing backtracking when an attempt fails (with mzero).<br />
solutions :: StateT Options [] Solution<br />
solutions = solveFromRow 1<br />
where<br />
solveFromRow r<br />
| r > size = return []<br />
| otherwise = do<br />
row <- solveRowFromCol r 1<br />
rows <- solveFromRow $ r + 1<br />
return $ row : rows<br />
solveRowFromCol r c<br />
| c > size = return []<br />
| otherwise = do<br />
vals <- gets $ (!! (c - 1)) . (!! (r - 1)) . cellOpts<br />
val <- lift vals<br />
fixCell val (r, c)<br />
row <- solveRowFromCol r (c + 1)<br />
return $ val : row<br />
<br />
-- Fix the value of a cell.<br />
-- More specifically - update Options to reflect the given value at<br />
-- the given cell, or mzero if that is not possible.<br />
fixCell :: (MonadState Options m, MonadPlus m) =><br />
Value -> Cell -> m ()<br />
fixCell val cell@(row, col) = do<br />
vals <- gets $ (!! (col - 1)) . (!! (row - 1)) . cellOpts<br />
guard $ val `elem` vals<br />
modifyCellOpts $ replace2 row col [val]<br />
modifyRowOpts $ replace2 row val [cell]<br />
modifyColOpts $ replace2 col val [cell]<br />
modifyBlkOpts $ replace2 blk val [cell]<br />
sequence_ [constrainCell v cell | v <- [1..size], v /= val]<br />
sequence_ [constrainCell val (row, c) | c <- [1..size], c /= col]<br />
sequence_ [constrainCell val (r, col) | r <- [1..size], r /= row]<br />
sequence_ [constrainCell val c | c <- blocks !! (blk - 1), c /= cell]<br />
where<br />
blk = blockNum cell<br />
<br />
-- Assert that the given value cannot occur in the given cell.<br />
-- Fail with mzero if that means that there are no options left.<br />
constrainCell :: (MonadState Options m, MonadPlus m) =><br />
Value -> Cell -> m ()<br />
constrainCell val cell@(row, col) = do<br />
constrainOpts row col val cellOpts modifyCellOpts (flip fixCell cell)<br />
constrainOpts row val cell rowOpts modifyRowOpts (fixCell val)<br />
constrainOpts col val cell colOpts modifyColOpts (fixCell val)<br />
constrainOpts blk val cell blkOpts modifyBlkOpts (fixCell val)<br />
where<br />
blk = blockNum cell<br />
constrainOpts x y z getOpts modifyOpts fixOpts = do<br />
zs <- gets $ (!! (y - 1)) . (!! (x - 1)) . getOpts<br />
case zs of<br />
[z'] -> guard (z' /= z)<br />
[_,_] -> when (z `elem` zs) $ fixOpts (head $ delete z zs)<br />
(_:_) -> modifyOpts $ replace2 x y (delete z zs)<br />
_ -> mzero<br />
<br />
-- Replace one element of a list.<br />
-- Coordinates are 1-based.<br />
replace :: Int -> a -> [a] -> [a]<br />
replace i x (y:ys)<br />
| i > 1 = y : replace (i - 1) x ys<br />
| otherwise = x : ys<br />
replace _ _ _ = []<br />
<br />
-- Replace one element of a 2-dimensional list.<br />
-- Coordinates are 1-based.<br />
replace2 :: Int -> Int -> a -> [[a]] -> [[a]]<br />
replace2 i j x (y:ys)<br />
| i > 1 = y : replace2 (i - 1) j x ys<br />
| otherwise = replace j x y : ys<br />
replace2 _ _ _ _ = []<br />
</haskell><br />
<br />
== In-flight entertainment ==<br />
<br />
By Lennart Augustsson<br />
<br />
When on a Lufthansa trans-atlantic flight in 2005 I picked up the in-flight magazine and found a Sudoku puzzle. I decided to finally try one. After solving half of it by hand I got bored. Surely, this mechanical task is better performed by a machine? So I pulled out my laptop and wrote a Haskell program.<br />
<br />
The program below is what I wrote on the plane, except for some comments that I've added. I have made no attempt as making it fast, so the nefarious test puzzle below takes a minute to solve.<br />
<br />
First, the solver without user interface:<br />
<haskell><br />
module Sudoku(Square, Board, ColDigit, RowDigit, BoxDigit, Digit, initialBoard, getBoard, mkSquare, setSquare, solveMany) where<br />
import Char(intToDigit, digitToInt)<br />
import List ((\\), sortBy)<br />
<br />
-- A board is just a list of Squares. It always has all the squares.<br />
data Board = Board [Square]<br />
deriving (Show)<br />
<br />
-- A Square contains its column (ColDigit), row (RowDigit), and<br />
-- which 3x3 box it belongs to (BoxDigit). The box can be computed<br />
-- from the row and column, but is kept for speed.<br />
-- A Square also contains it's status: either a list of possible<br />
-- digits that can be placed in the square OR a fixed digit (i.e.,<br />
-- the square was given by a clue or has been solved).<br />
data Square = Square ColDigit RowDigit BoxDigit (Either [Digit] Digit)<br />
deriving (Show)<br />
<br />
type ColDigit = Digit<br />
type RowDigit = Digit<br />
type BoxDigit = Digit<br />
type Digit = Char -- '1' .. '9'<br />
<br />
-- The initial board, no clues given so all digits are possible in all squares.<br />
initialBoard :: Board<br />
initialBoard = Board [ Square col row (boxDigit col row) (Left allDigits) |<br />
row <- allDigits, col <- allDigits ]<br />
<br />
-- Return a list of rows of a solved board.<br />
-- If used on an unsolved board the return value is unspecified.<br />
getBoard :: Board -> [[Char]]<br />
getBoard (Board sqs) = [ [ getDigit d | Square _ row' _ d <- sqs, row' == row ] | row <- allDigits ]<br />
where getDigit (Right d) = d<br />
getDigit _ = '0'<br />
<br />
allDigits :: [Char]<br />
allDigits = ['1' .. '9']<br />
<br />
-- Compute the box from a column and row.<br />
boxDigit :: ColDigit -> RowDigit -> BoxDigit<br />
boxDigit c r = intToDigit $ (digitToInt c - 1) `div` 3 + (digitToInt r - 1) `div` 3 * 3 + 1<br />
<br />
-- Given a column, row, and a digit make a (solved) square representing this.<br />
mkSquare :: ColDigit -> RowDigit -> Digit -> Square<br />
mkSquare col row c | col `elem` allDigits && row `elem` allDigits && c `elem` allDigits <br />
= Square col row (boxDigit col row) (Right c)<br />
mkSquare _ _ _ = error "Bad mkSquare"<br />
<br />
-- Place a given Square on a Board and return the new Board.<br />
-- Illegal setSquare calls will just error out. The main work here<br />
-- is to remove the placed digit from the other Squares on the board<br />
-- that are in the same column, row, or box.<br />
setSquare :: Square -> Board -> Board<br />
setSquare sq@(Square scol srow sbox (Right d)) (Board sqs) = Board (map set sqs)<br />
where set osq@(Square col row box ds) =<br />
if col == scol && row == srow then sq<br />
else if col == scol || row == srow || box == sbox then (Square col row box (sub ds))<br />
else osq<br />
sub (Left ds) = Left (ds \\ [d])<br />
sub (Right d') | d == d' = error "Impossible setSquare"<br />
sub dd = dd<br />
setSquare _ _ = error "Bad setSquare"<br />
<br />
-- Get the unsolved Squares from a Board.<br />
getLeftSquares :: Board -> [Square]<br />
getLeftSquares (Board sqs) = [ sq | sq@(Square _ _ _ (Left _)) <- sqs ]<br />
<br />
-- Given an initial Board return all the possible solutions starting<br />
-- from that Board.<br />
-- Note, this all happens in the list monad and makes use of lazy evaluation<br />
-- to avoid work. Using the list monad automatically handles all the backtracking<br />
-- and enumeration of solutions.<br />
solveMany :: Board -> [Board]<br />
solveMany brd =<br />
case getLeftSquares brd of<br />
[] -> return brd -- Nothing unsolved remains, we are done.<br />
sqs -> do<br />
-- Sort the unsolved Squares by the ascending length of the possible<br />
-- digits. Pick the first of those so we always solve forced Squares<br />
-- first.<br />
let Square c r b (Left ds) : _ = sortBy leftLen sqs<br />
leftLen (Square _ _ _ (Left ds1)) (Square _ _ _ (Left ds2)) = compare (length ds1) (length ds2)<br />
leftLen _ _ = error "bad leftLen"<br />
sq <- [ Square c r b (Right d) | d <- ds ] -- Try all possible moves<br />
solveMany (setSquare sq brd) -- And solve the extended Board.<br />
</haskell><br />
<br />
Second, a simple user interface (a different user interface that I have is an Excell addin):<br />
<haskell><br />
module Main where<br />
import Sudoku<br />
<br />
-- Col Row Digit<br />
solve :: [((Char, Char), Char)] -> [[Char]]<br />
solve crds =<br />
let brd = foldr add initialBoard crds<br />
add ((c, r), d) = setSquare (mkSquare c r d)<br />
in case solveMany brd of<br />
[] -> error "No solutions"<br />
b : _ -> getBoard b<br />
<br />
-- The parse assumes that squares without a clue<br />
-- contain '0'.<br />
main = interact $<br />
unlines . -- turn it into lines<br />
map (concatMap (:" ")) . -- add a space after each digit for readability<br />
solve . -- solve the puzzle<br />
filter ((`elem` ['1'..'9']) . snd) . -- get rid of non-clues<br />
zip [ (c, r) | r <- ['1'..'9'], c <- ['1'..'9'] ] . -- pair up the digits with their coordinates<br />
filter (`elem` ['0'..'9']) -- get rid of non-digits<br />
</haskell><br />
<br />
<br />
== Add Your Own ==<br />
<br />
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.<br />
<br />
== Test Boards ==<br />
<br />
Here's an input file to test the solvers on. Zeroes represent blanks.<br />
<pre><br />
0 5 0 0 6 0 0 0 1<br />
0 0 4 8 0 0 0 7 0<br />
8 0 0 0 0 0 0 5 2<br />
2 0 0 0 5 7 0 3 0<br />
0 0 0 0 0 0 0 0 0<br />
0 3 0 6 9 0 0 0 5<br />
7 9 0 0 0 0 0 0 8<br />
0 1 0 0 0 6 5 0 0<br />
5 0 0 0 3 0 0 6 0<br />
</pre><br />
<br />
A nefarious one:<br />
<br />
<pre><br />
0 0 0 0 6 0 0 8 0<br />
0 2 0 0 0 0 0 0 0<br />
0 0 1 0 0 0 0 0 0<br />
0 7 0 0 0 0 1 0 2<br />
5 0 0 0 3 0 0 0 0<br />
0 0 0 0 0 0 4 0 0<br />
0 0 4 2 0 1 0 0 0<br />
3 0 0 7 0 0 6 0 0<br />
0 0 0 0 0 0 0 5 0 <br />
</pre><br />
<br />
Chris Kuklewicz writes, "You can go get the 36,628 distict minimal puzzles from<br />
[http://www.csse.uwa.edu.au/~gordon/sudokumin.php 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."</div>Lennart