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

22 Aug 2010

      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]