[Haskell-cafe] Simple Sudoku solver using Control.Monad.Logic

[azwhaley]

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