Am Mittwoch, 5. April 2006 15:09 schrieb Chris Kuklewicz:
> Henning Thielemann wrote:
> > On Mon, 3 Apr 2006, Jared Updike wrote:
> >> or ambiguously) with your Sudoku solver? A rough mesaure of the
> >> difficulty of the unsolved puzzle could be how long the solver took to
> >> solve it (number of steps) (and the number of possible solutions)? Are
> >> puzzles with multiple solutions usually considered harder or easier?
> >> Are these considered proper puzzles?
> >
> > It's an interesting test to run a Sudoku solver on an empty array. :-)
>
> I am cleaning up my old (aka inexperienced) solver based on Knuth's dancing
> links to put on the wiki. The code is very different than most Haskell
> solutions, since it revolves around a mutable data structure (which is not
> an MArray).
>
> It "solves" an empty array in 81 steps with no backtracking. It will
> produce a list of all the solutions of an empty board quite efficiently.
>
> Cleaning up my "logic" based solver will take longer.
I've cleaned up my solver, removed a lot of redundant inference steps and made
the board a DiffArray (is that really faster?).
Now it completely solves (following all guesses) the 36,628 17-hint puzzles in
about 32 minutes (1909 secs).
It "solves" an empty board in 81 steps without false guesses, but still takes
over four seconds (that's the price for excessive inference).
I've also written a version using David F. Place's EnumSet instead of [Int],
that takes less MUT time, but more GC time, so is slower on the 36,628 test,
but faster for a single puzzle.
If anybody feels like improving the code (especially finding better names for
the functions) and/or placing it on the wiki, I'll be honoured.
Just out of curiosity, speed was not the objective when I wrote my solver, I
wanted to avoid guesswork (as much as possible), but in comparison with Cale
Gibbard's and Alson Kemp's solvers (which are much more beautifully coded),
it turned out that mine is blazingly fast, so are there faster solvers around
(in Haskell, in other languages)?
Cheers,
Daniel
--
"In My Egotistical Opinion, most people's C programs should be
indented six feet downward and covered with dirt."
-- Blair P. Houghton
module Sudoku where
import Data.Array.Diff
import Data.List
import Data.Char (isSpace, digitToInt)
import System.IO
type Position = (Int, Int)
pool :: Entry
pool = Poss [1 .. 9]
ixes :: [Int]
ixes = [0 .. 8]
data Entry
= Def !Int
| Poss ![Int]
deriving Eq
instance Show Entry where
show (Def k) = show k
show (Poss s) = case s of
[] -> "#"
[_] -> "*"
[_,_] -> ":"
_ -> " "
type Board = DiffArray Position Entry
emptyBoard :: Board
emptyBoard = listArray ((0,0),(8,8)) $ replicate 81 pool
(?) :: Board -> Position -> Entry
b ? p = b ! toGridPos p
failed :: Board -> Bool
failed = any isImp . elems
solved :: Board -> Bool
solved = all isDef . elems
unique :: Board -> Bool
unique b = case solve b of
[_] -> True
_ -> False
----------------------------------------------------------------------
-- Solving a Puzzle --
----------------------------------------------------------------------
place :: Board -> Position -> Int -> Board
place b p@(r,c) k
= case b!p of
Def n -> if k == n then b
else b // [(p, Poss [])]
Poss s -> if k `elem` s then b'
else b // [(p, Poss [])]
where
b1 = b // [(p,Def k)]
ri = [(r,i) | i <- ixes, i /= c]
ci = [(i,c) | i <- ixes, i /= r]
cn = cellNo p
good (x,y) = x /= r && y /= c
bi = filter good [toGridPos (cn,i) | i <- ixes]
b' = foldl (forbid k) b1 $ ri ++ ci ++ bi
restrict :: Board -> (Position, [Int]) -> Board
restrict b (p,[k]) = place b p k
restrict b (p,s) = case b!p of
Poss t -> b // [(p, Poss $ filter (`elem` s) t)]
Def k -> if k `elem` s then b
else b // [(p, Poss [])]
forbid :: Int -> Board -> Position -> Board
forbid k b p
= case b!p of
Poss s | k `elem` s -> b // [(p, Poss $ delete k s)]
_ -> b
certs :: Board -> [(Position, Int)]
certs b = [(p,k) | (p, Poss [k]) <- assocs b]
defCerts :: Board -> (Bool, Board)
defCerts b
= case certs b of
[] -> (False, b)
cs -> let b1 = foldl (uncurry . place) b cs
(_, b2) = defCerts b1
in (True, b2)
posCell :: Int -> Board -> Int -> Board
posCell cn b k
= let ps = [(i,mkSt e) | i <- ixes, let e = b ? (cn,i), not (isDef e)]
fp = findPos k ps
rs = nub [i `quot` 3 | i <- fp]
cs = nub [i `rem` 3 | i <- fp]
rc = filter (/= cn) [(cn `quot` 3) * 3 + i | i <- [0 .. 2]]
cc = filter (/= cn) [3 * i + (cn `rem` 3) | i <- [0 .. 2]]
ls = case (rs,cs) of
([r], _) -> [(c',3*r+i) | c' <- rc, i <- [0 .. 2]]
(_, [c]) -> [(c',3*i+c) | c' <- cc, i <- [0 .. 2]]
_ -> []
in case fp of
[i] -> place b (toGridPos (cn,i)) k
_ -> foldl (forbid k) b $ map toGridPos ls
treatCell :: Int -> Board -> Board
treatCell cn b
= foldl (posCell cn) b lst
where
lst = unions [mkSt e | i <- ixes, let e = b ? (cn,i),
not (isDef e)]
treatCells :: Board -> Board
treatCells b = foldr treatCell b [0 .. 8]
posRow :: Int -> Board -> Int -> Board
posRow r b k
= let ps = [(i,mkSt e) | i <- ixes, let e = b ! (r,i), not (isDef e)]
fp = findPos k ps
cs = nub [i `quot` 3 | i <- fp]
in case (fp,cs) of
([c],_) -> place b (r,c) k
(_,[c]) -> let ls = [(r',c') | i <- [0 .. 2], let r' = 3*(r `quot` 3) + i, r' /= r, j <- [0 .. 2], let c' = 3*c + j]
in foldl (forbid k) b ls
_ -> b
treatRow :: Int -> Board -> Board
treatRow r b
= foldl (posRow r) b lst
where
lst = unions [mkSt s | i <- ixes, let s = b ! (r,i),
not (isDef s)]
treatRows :: Board -> Board
treatRows b = foldr treatRow b [0 .. 8]
posCol :: Int -> Board -> Int -> Board
posCol c b k
= let ps = [(i,mkSt e) | i <- ixes, let e = b ! (i,c), not (isDef e)]
fp = findPos k ps
rs = nub [i `quot` 3 | i <- fp]
in case (fp,rs) of
([r],_) -> place b (r,c) k
(_,[r]) -> let ls = [(r',c') | i <- [0 .. 2], let r' = 3*r + i, j <- [0 .. 2], let c' = 3*(c `quot` 3) + j, c' /= c]
in foldl (forbid k) b ls
_ -> b
treatCol :: Int -> Board -> Board
treatCol c b
= foldl (posCol c) b lst
where
lst = unions [mkSt s | i <- ixes, let s = b ! (i,c),
not (isDef s)]
treatCols :: Board -> Board
treatCols b = foldr treatCol b [0 .. 8]
infer :: Board -> Board
infer b
= let b1 = treatCells b
c1 = certs b1
b2 = treatRows b1
c2 = certs b2
b3 = treatCols b2
c3 = certs b3
b4 = treatGroups b3
c4 = certs b4
in case (c1,c2,c3,c4) of
((_:_),_,_,_) -> b1
(_,(_:_),_,_) -> b2
(_,_,(_:_),_) -> b3
(_,_,_,(_:_)) -> b4
_ -> if b4 `equal` b then b4 else infer b4
guess :: Board -> [Board]
guess b
= let ass = filter (not . isDef . snd) $ assocs b
cmp (_,Poss s1) (_,Poss s2) = compare (length s1) (length s2)
sas = sortBy cmp ass
in case sas of
[] -> []
((p,Poss s):_) -> filter (not . failed) [place b p n | n <- s]
solve :: Board -> [Board]
solve b
| solved b = [b]
| failed b = []
| otherwise = let b1 = infer b in
case defCerts b1 of
(True,b2) -> solve b2
(_ ,b2) -> if b `equal` b2 then
do bd <- guess b
solve bd
else solve b2
----------------------------------------------------------------------
-- Inference on Groups --
----------------------------------------------------------------------
inferGroup :: Board -> [Position] -> [[(Position, [Int])]]
inferGroup b ps
= let ass = [(p,b!p) | p <- ps]
sts = [(p,s) | (p, Poss s) <- ass]
len = length sts
in do k <- [2 .. len - 2]
(xs,ys) <- select k sts
let ws = unions $ map snd xs
case compare (length ws) k of
GT -> fail "nothing found"
_ -> return $ map (`without` ws) ys
infGr :: Board -> [Position] -> Board
infGr b ps
= let ups = concat $ inferGroup b ps
in foldl restrict b ups
indGroups :: [[Position]]
indGroups = [map toGridPos [(cn,i) | i <- ixes] | cn <- ixes]
++ [[(r,c) | c <- ixes] | r <- ixes]
++ [[(r,c) | r <- ixes] | c <- ixes]
treatGroups :: Board -> Board
treatGroups b = foldl infGr b indGroups
----------------------------------------------------------------------
-- Reading and Displaying a Board --
----------------------------------------------------------------------
readGrid :: String -> Board
readGrid str
= let nlns = zip [0 .. 8] $ lines str
tr s = zip [0 .. 8] $ map read . words $ s
grd = map (\(n,l) -> map (\(k,m) -> ((n,k),m)) $ tr l) nlns
plcs = filter ((/= 0) . snd) $ concat grd
in foldl (uncurry . place) emptyBoard plcs
readLine :: String -> Board
readLine str
= let nlns = zip [0 .. 8] $ takeBy 9 str
tr s = zip [0 .. 8] $ map digitToInt s
grd = map (\(n,l) -> map (\(k,m) -> ((n,k),m)) $ tr l) nlns
plcs = filter ((/= 0) . snd) $ concat grd
in foldl (uncurry . place) emptyBoard plcs
readBoard :: String -> Board
readBoard = readLine . take 81 . filter (not . isSpace)
boardToLists :: Board -> [[Entry]]
boardToLists b = [[b!(r,c) | c <- ixes] | r <- ixes]
-- this is taken from David F. Place's sudoku solver,
-- it's prettier than my original
display :: [[Entry]] -> String
display s = stretch . (intersperse ["---+---+---\n"]) . (stitch knot) . gather $ s
where
sewRow = stretch . (intersperse ["|"]) . (stitch show) . gather
knot r = (sewRow r)++['\n']
stretch = concat . concat
stitch f = map (map f)
gather = takeBy 3
showBoard :: Board -> String
showBoard = display . boardToLists
pretty :: Board -> IO ()
pretty = putStr . showBoard
----------------------------------------------------------------------
-- Helper Functions --
----------------------------------------------------------------------
cellNo :: Position -> Int
cellNo (r,c) = (r `quot` 3) * 3 + c `quot` 3
cellInd :: Position -> Int
cellInd (r,c) =(r `rem` 3) * 3 + c `rem` 3
toCellPos :: Position -> Position
toCellPos (r,c) = (cn,ci)
where
cn = cellNo (r,c)
ci = (r `rem` 3) * 3 + c `rem` 3
toGridPos :: Position -> Position
toGridPos (cn,ci)
= (r,c)
where
r = (cn `quot` 3) * 3 + ci `quot` 3
c = (cn `rem` 3) * 3 + ci `rem` 3
-- also from David F. Place
takeBy :: Int -> [a] -> [[a]]
takeBy n xs = unfoldr f xs
where
f [] = Nothing
f xs = Just $ splitAt n xs
isDef :: Entry -> Bool
isDef e = case e of
Def _ -> True
_ -> False
isCert :: Entry -> Bool
isCert e = case e of
Poss [_] -> True
_ -> False
isImp :: Entry -> Bool
isImp e = case e of
Poss [] -> True
_ -> False
findPos :: Int -> [(Int, [Int])] -> [Int]
findPos k ps = [y | (y,s) <- ps, k `elem` s]
mkSt :: Entry -> [Int]
mkSt e = case e of
Poss s -> s
Def k -> [k]
equal :: Board -> Board -> Bool
b1 `equal` b2 = elems b1 == elems b2
without :: (a, [Int]) -> [Int] -> (a, [Int])
(x,st) `without` ts = (x, st \\ ts)
-------------------------------------------------------
select :: Int -> [a] -> [([a],[a])]
select 0 xs = [([],xs)]
select _ [] = []
select n (x:xs) = [(x:ys,zs) | (ys,zs) <- select (n-1) xs]
++ [(ys,x:zs) | (ys,zs) <- select n xs]
unions :: [[Int]] -> [Int]
unions = foldl merge []
merge :: [Int] -> [Int] -> [Int]
merge [] ys = ys
merge xs [] = xs
merge xss@(x:xs) yss@(y:ys)
= case compare x y of
LT -> x:merge xs yss
EQ -> x:merge xs ys
GT -> y:merge xss ys
-----------------------------------------------------------
module Main where
import Sudoku
unique :: Board -> Bool
unique b = case solve b of
[_] -> True
_ -> False
main :: IO ()
main = do txt <- readFile "sudoku17"
let lns = lines txt
print $ all unique $ map readBoard lns
_______________________________________________
Haskell-Cafe mailing list
[email protected]
http://www.haskell.org/mailman/listinfo/haskell-cafe
