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

[Vladimir Matveev]

I think the problem is with terribly inefficient data representation.
I've written sudoku solver some time ago too using different data
structures, including Data.Array, Data.Vector and simple lists. Lists
are very inefficient in this case, because accessors for lists have
O(n) complexity. Immutable arrays from Data.Array are inefficient too,
at least in my case - I used simple backtracking algorithm - because
of their immutability. Mutable arrays were slightly better, but still
very sluggish. Then I've written two-dimensional arrays implementation
over Data.Vector library. This was the most efficient variant -
somewhere around 8 seconds. Of course, this implementation is mutable,
so I have two variants, for IO and ST s monads.
I've also written 2 versions of solving algorithm - the one that
nearly identical to C++ imperative version using ContT monad
transformer and very dirty foreach loop with breaking, and (as far as
I can see) more efficient tail-recursive algorithm with ListZipper
over free cell indices. It resembles some state machine to me, though
I think I'm incorrect in this sense :) And it was a surprise to me:
the tail-recursive algorithm was noticeable slower than the dirty
imperative version! I wanted to ask about this here on haskell-cafe,
but forgot :)
Here is the code: http://hpaste.org/fastcgi/hpaste.fcgi/view?id=29364#a29364
Profiling shows that the most of CPU time take modification functions
like (=:). I don't know how to improve the performance further then.

2010/8/22 azwhaley <azwhaley at googlemail.com>:
> 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]
> _______________________________________________
> Haskell-Cafe mailing list
> Haskell-Cafe at haskell.org
> http://www.haskell.org/mailman/listinfo/haskell-cafe
>
>