Personal tools

Sudoku

From HaskellWiki

(Difference between revisions)
Jump to: navigation, search
Line 221: Line 221:
   
   
  +
== 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 ==
 
== Test Boards ==

Revision as of 16:17, 4 April 2006


Here are a few sodoku solvers coded up in Haskell...

Contents

1 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



2 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


3 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.

4 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."