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

[Daniel Fischer]

On Sunday 22 August 2010 22:15:02, Luke Palmer wrote:
> On Sun, Aug 22, 2010 at 1:18 PM, Daniel Fischer
>
> <daniel.is.fischer at web.de> 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]