[Haskell-cafe] Simple Sudoku solver using Control.Monad.Logic
Daniel Fischer
daniel.is.fischer at web.de
Sun Aug 22 16:39:12 EDT 2010
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]
More information about the Haskell-Cafe
mailing list