[Haskell-cafe] Simple Sudoku solver using Control.Monad.Logic
azwhaley
azwhaley at googlemail.com
Sun Aug 22 10:53:30 EDT 2010
Hello All,
Apologies if some have you have got this twice but I posted this once
via fa.haskell on Goggle but I don't think it goes anywhere outside
Google.
In an attempt to learn how to use monads, I've tried to write a simple
sudoku solver using the LogicT monad. I think it works but it is
extremely slow, in fact it won't finish at all if I attempt to enforce
the grid constraints. Just using row and column constraints, it will
finish for some problems.
Am I doing something dreadfully wrong here or is this just a hard
problem to solve ?
Thanks
Andrew
here's the listing :-
module Main where
import Control.Monad.Logic
import Data.List (delete, (\\))
board :: [[Int]]
board = [ [7, 9, 0, 0, 0, 0, 3, 0, 0],
[0, 2, 0, 0, 0, 6, 9, 0, 0],
[8, 0, 0, 0, 3, 0, 0, 7, 6],
[0, 0, 0, 0, 0, 5, 0, 0, 2],
[0, 0, 5, 4, 1, 8, 7, 0, 0],
[4, 0, 0, 7, 0, 0, 0, 0, 0],
[0, 0, 0, 0, 0, 0, 0, 0, 0],
[0, 0, 0, 0, 0, 0, 0, 0, 0],
[0, 0, 0, 0, 0, 0, 0, 0, 0]]
-- accessors for row, column and grid
row b = (b!!)
col b c = [x!!c | x <- b]
grid b g = (t 0) ++ (t 1) ++ (t 2)
where t i = take 3 $ drop x $ b !! (y + i)
x = 3 * (g `mod` 3)
y = 3 * (g `div` 3)
-- Ensures all numbers in the list are unique
unique :: [Int] -> Bool
unique r = null (foldl (\a x -> delete x a) [x | x <- r, x /= 0] [1..9])
choose choices = msum [return x | x <- choices]
-- Test a cell (0 = unknown value)
test :: Int -> Logic [Int] -> Logic Int
test 0 c = do choices <- c
choose choices
test x c = return x
-- helper to produce a diff list from a wrapped monadic list
mdiff :: [Logic Int] -> [Int] -> Logic [Int]
mdiff a c = do i <- sequence a
return ([1..9]\\(i++c))
-- the actual solver - attempts to limit choices early on by using
diff list of remaining values
sudoku :: Logic [[Int]]
sudoku = do
solution <- foldl (\b r -> do
m <- b
row <- sequence $ foldr (\(n,x) a ->
(test x (mdiff a $ col m n)):a) [] [(n,x) |x <- r | n <- [0..8]]
guard $ unique row
sequence [guard $ unique $ col m i | i
<- [0..8]]
return (m ++ [row])
) (return []) board
sequence $ [guard $ unique $ grid solution i | i <- [0..8]]
return solution
-- solve and print
main = do
let solution = observe sudoku
sequence [print s | s <- solution]
-------------- next part --------------
An HTML attachment was scrubbed...
URL: http://www.haskell.org/pipermail/haskell-cafe/attachments/20100822/2a6b0289/attachment.html
More information about the Haskell-Cafe
mailing list