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

On Sunday 22 August 2010 20:12:16, Vladimir Matveev wrote:

I think the problem is with terribly inefficient data representation.

Worse, it's a terribly inefficient algorithm. The constraints are applied too late, so a huge number of partial boards are created only to be pruned afterwards. Since the ratio between obviously invalid rows and potentially valid rows is large, the constraints should be applied already during the construction of candidate rows to avoid obviously dead branches.

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.

Since the lists are short, that's not so big a problem here.

Immutable arrays from Data.Array are inefficient too,

They were pretty good for my solver. What's bad is branching.

at least in my case - I used simple backtracking algorithm -

Which of course happens a lot in a 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

I'll take a look.

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 :

...

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]