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]

On Sunday 22 August 2010 22:15:02, Luke Palmer wrote:

On Sun, Aug 22, 2010 at 1:18 PM, Daniel Fischer

wrote:

...

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 a sudoku solver myself, and IIRC I used lists. It always gave an answer within a second. So I believe Daniel has correctly identified the problem -- you need to prune earlier.

Indeed. The below simple backtracking agorithm with early pruning finds the first solution in 0.45s here (compiled with -O2, as usual). For an empty starting board, the first solution is found in less than 0.01s. Unfortunately, I didn't understand Andrew's code enough to stay close to it, so it looks very different. {-# LANGUAGE ParallelListComp #-} module Main (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) grid b g = (take 3 . drop y) b >>= take 3 . drop x          where -- t i = take 3 $ drop x $ b !! (y + i)                x   = 3 * (g `mod` 3)                y   = 3 * (g `div` 3) nextRow :: [[Int]] -> [Int] -> Logic [[Int]] nextRow b0 rw = do let rno = length b0 usd = filter (/= 0) rw pss = [1 .. 9] \\ usd u = 3*(rno `quot` 3) opp yes no (n,0) = let cl = col b0 n gd = grid b0 (u + n `quot` 3) in msum . map return $ yes \\ (cl ++ gd) opp _ _ (n,x) = let cl = col b0 n gd = grid b0 (u + n `quot` 3) in guard (x `notElem` (cl ++gd)) >> return x -- The above is essential. Since we only look at previous rows, -- we must check whether a given value violates the constraints foo _ no [] = return no foo yes no (p:ps) = do d <- opp yes no p foo (delete d yes) (no ++ [d]) ps row <- (foo pss [] $ zip [0 .. 8] rw) return (b0 ++ [row]) -- the actual solver sudoku :: Logic [[Int]] sudoku = go [] board where go b (r:rs) = do b1 <- nextRow b r go b1 rs go b [] = return b -- solve and print main = do       let solution = observe sudoku       sequence_ [print s | s <- solution]

On Aug 22, 2010, at 11:09 PM, Vladimir Matveev wrote:

are there any materials except LogicT.pdf from link on the logict hackage entry? I'd like to read something on this interesting topic

The functional pearl A program to solve Sudoku by Richard Bird http://www.cs.tufts.edu/~nr/comp150fp/archive/richard-bird/ sudoku.pdf is an interesting read. If you get your hands on a copy of "The Fun of Programming", which has been edited in honour of Richard Birds 60th birthday, you can have a look at Chapter 9, Combinators for logic programming by Mike Spivey and Silvija Seres I did not find this chapter online. Issue 15 of the Monad.Reader contains Adventures in Three Monads by Edward Z. Yang http://themonadreader.files.wordpress.com/2010/01/issue15.pdf which gives an introduction to the Logic monad (and two others). In my doctoral thesis I give a brief introduction to nondeterminism monads in general and how to implement some specific instances: On Functional-Logic Programming and its Application to Testing by Sebastian Fischer Section 5.1, Nondeterminism monads http://www-ps.informatik.uni-kiel.de/~sebf/thesis.pdf There are various nondeterminism monads on Hackage. If you restrict your algorithm to only use the MonadPlus interface you can experiment with all of them simply by changing a type signature. The list monad (not on Hackage because defined in the Prelude) implements backtracking via depth-first search. The Hackage package control-monad-omega [1] by Luke Palmer uses list diagonalisation to overcome limitations of the list monad. It is described to implement breadth-first search which, in my opinion, it doesn't exactly. My package level-monad [2] provides monads for iterative deepening depth-first search and breadth-first search. The latter enumerates results of the search space in breadth-first (that is level) order. The former does something similar with better space usage. The different implementations of nondeterminism monads often differ significantly in how much memory they use. The list monad uses little memory but often diverges when the search space is infinite. Breadth- first search is a complete strategy (it does not diverge infinite search spaces and, thus, eventually finds every result) but has excessive memory requirements. Oleg Kiselyov has invented a complete strategy with moderate memory requirements which I have packaged as stream-monad [3]. I recommend using the list or logic monad if the search space is finite and the stream monad or iterative deepening dfs if the search space is infinite. Cheers, Sebastian [1]: http://hackage.haskell.org/package/control-monad-omega [2]: http://hackage.haskell.org/package/level-monad [3]: http://hackage.haskell.org/package/stream-monad -- Underestimating the novelty of the future is a time-honored tradition. (D.G.)

Ah, whenever I see "div/mod 3" in a Sudoku solver, I feel that's not using the right model. It's not a square, it's a hypercube, folks! type Index = ( Int,Int,Int,Int ) neighbours :: Index -> [ Index ] neighbours (a,b,c,d) = do i <- [ 0 .. 2 ] ; j <- [ 0 .. 2 ] [ (i,j,c,d), (a,b,i,j), (a,i,c,j) ] Here is a solver that branches on the position with the least number of possible values. It is backtracking (in the List monad, could probably be rewritten in Control.Monad.Logic) type Matrix = Array Index (Either [Int] Int) solutions :: Matrix -> [ Matrix ] solutions m = case sort $ do ( i, Left xs ) <- assocs m return ( length xs, i, xs ) of [] -> return m (_,i,xs) : _ -> do x <- xs solutions $ set (i,x) m set :: (Index, Int) -> Matrix -> Matrix set (i, x) m = accum ( \ e _ -> case e of Left ys -> Left $ filter ( /= x ) ys Right y -> Right y ) ( m // [ (i, Right x ) ] ) ( zip ( neighbours i ) $ repeat () )