{- Sudoku solver, using simple constraint propagation to limit search, by determining singleton numbers and positions, as well as some information from sufficiently narrowed positions; a puzzle is represented as a list of positions (line,column,block) paired with the range of numbers possible on that position. where needed, backtracking/failure are mapped to lists of successes. claus reinke march/april 2006 -} module Main where import Data.List import Data.Maybe(catMaybes) import Data.Char import Control.Monad(when,guard) import Control.Monad.Error -- import Debug -------------------------- puzzle input/output -- convert Char to range of possible numbers per position c2r ' ' = list2range [1..9] c2r c = list2range [read [c]] -- convert range to number if singleton, to nothing if fuzzy r2c r = case range2list r of { [n] -> head (show n); _ -> ' ' } -- basic read/write readPuzzle :: [String] -> [((Int,Int,Int),Range)] readPuzzle s = [ ((i,j,blockNum i j),c2r char) | (i,line) <- zip [1..9] s , (j,char) <- zip [1..9] line ] blockNum i j = ((i-1)`div`3)*3+((j-1)`div`3)+1 inNs n = (\(a,b)->if null a then [] else a:inNs n b) . splitAt n writePuzzle m = unlines [ map r2c line | line <- inNs 9 m ] -- the line-per-puzzle format used in the 17clues collection readPuzzleLine l = inNs 9 (map space l) where space c = if c=='0' then ' ' else c writePuzzleLine p = [ show n | (ijk,[n]) <- p ] -- prettier printing, output only -- add separators for readability add sep s@[] = [sep] add sep s@(h1:h2:h3:t) = sep:h1:h2:h3:add sep t writeLinedPuzzle m = unlines $ add "+---+---+---+" [ add '|' $ [ r2c r | (pos,r) <- line] | line <- inNs 9 m ] -- output range info, too writeFuzzyPuzzle p = unlines $ add (concat (replicate 3 "++==========+=========+=========")++"++") $ [ concat $ add "||" [' ': flagRange r | (pos,r) <- l ] | l <- inNs 9 p ] -------------------------- range operations flagRange r = [ flag i (range2list r) | i <- [1..9] ] flag i rl | i `elem` rl = head (show i) | length rl==1 = ' ' | otherwise = '-' {- list-based ranges -} type Range = [Int] n `inRange` r = n `elem` r nullRange r = null r r `withOut` n = filter (/=n) r r `narrowedBy` ns = let r' = foldl withOut r ns in (r', if any (`inRange` r) ns then getSingle r' else Nothing ) range2list r = r list2range r = r mkSingle n = [n] getSingle [x] = Just x getSingle r = Nothing singleton r = length r==1 -------------------------- are we there yet? checkSolvedPuzzle fp = ((all (singleton.snd) fp) `orElse` "undetermined positions!") >> ((and [sort l==[1..9] | l<-getLines fp]) `orElse` "inconsistent lines!") >> ((and [sort c==[1..9] | c<-getColumns fp]) `orElse` "inconsistent columns!") >> ((and [sort b==[1..9] | b<-getBlocks fp]) `orElse` "inconsistent blocks!") where c `orElse` msg = if c then Right fp else Left msg getLines fp = [[ n | (pos,r) <- l, Just n <- [getSingle r] ] | l <- inNs 9 fp] getColumns fp = [[ n | (pos,r) <- c, Just n <- [getSingle r] ] | c <- transpose $ inNs 9 fp] getBlocks fp = [[ n | ((i,j,k'),r) <- fp, k'==k, Just n <- [getSingle r] ] | k<-[1..9] ] -------------------------- propagators -- commit to a number on one position, -- eliminate number from other ranges in same line/column/block; -- take note of new singleton ranges created in the process, -- fail for inconsistent set attempts (implying empty ranges) set ((line,col,block),n) p = [ (concat ssls, concat pls) | not (any null pls) ] where (ssls,pls) = unzip (map narrow p) narrow (pos@(i,j,k),range) | (i,j)==(line,col) = ([],[ (pos,mkSingle n) | n `inRange` range ]) | i==line || j==col || k==block = case range `narrowedBy` [n] of (r',_) | nullRange r' -> ([] ,[]) (r',Just x) -> -- new singleton ([((i,j,k),x)],[(pos,r')]) (r',_ ) -> ([] ,[(pos,r')]) | otherwise = ([],[ (pos,range) | not (nullRange range) ]) -- check for uniquely and narrowly determined numbers/positions, -- narrow ranges, commit to singletons and propagate again propagate ss p = return $ while p (ss++(findSingletonPos p)) where while p ss = if p==np then p else while np (findSingletonPos np) where np = loop ss p loop ss p = case narrowPos (foldr setAndCheck p ss) of [([],np)] -> np [(ss,np)] -> loop ss np [] -> [] setAndCheck s p = check (set s p) check [(ss,p)] = foldr setAndCheck p ss check [] = [] -- positions that can only hold a single number -- this is called only once at the start; after that, -- narrowing/setting notes new singletons as they appear findSingletonRanges p = [ (pos,c) | (pos,r) <- p, Just c <- [getSingle r]] -- numbers that can only be in a single position findSingletonPos p = singles byLine++singles byCol++singles byBlock where singles byCoord = [ (pos,n) | (n,np) <- ns, coord <- [1..9] , [(pos,r)] <- [filter (byCoord coord) np] , not (singleton r) ] byLine l ((l1,_,_),r) = l==l1 byCol c ((_,c1,_),r) = c==c1 byBlock b ((_,_,b1),r) = b==b1 ns = byNums [ (n,[]) | n <- [1..9] ] p byNums ns [] = [ (n, reverse ps) | (n,ps) <- ns ] byNums ns ((pos,r):t) = byNums [if n `inRange` r then (n,(pos,r):ps) else (n,ps) |(n,ps)<-ns] t -- numbers that can only be in a single line/block, column/block, block/line, block/column -- imply that those numbers can be eliminated from other lines in that block, ...; -- findNarrowPos returns a list of (pos,number) to be eliminated findNarrowPos p = collect $ sortBy cmpByPos $ num byLines projBlock++num byCols projBlock ++num byBlocks projLine ++num byBlocks projCol where collect [] = [] collect ((ijk,n):t) = let (samePos,others) = span ((==ijk).fst) t in (ijk,nub $ n:map snd samePos):collect others cmpByPos (p1,_) (p2,_) = compare p1 p2 num ns proj2 = [ (ijk, n) -- ((coord1,coord2),n) | (n,np) <- ns, (coord1,part) <- np , (coords1@(_:_:_),notCoords1) <- [part] , [coord2] <- [nub (map proj2 coords1)] , ijk <- filter (\p->proj2 p==coord2) notCoords1 ] ns = byNums [ (n,[]) | n <- [1..9] ] p byLines = [ (n,[(i,partition (\p->projLine p==i) np) | i <- [1..9]]) | (n,np) <- ns ] byCols = [ (n,[(j,partition (\p->projCol p==j) np) | j <- [1..9]]) | (n,np) <- ns ] byBlocks = [ (n,[(k,partition (\p->projBlock p==k) np) | k <- [1..9]]) | (n,np) <- ns ] projLine (l1,_,_) = l1 projCol (_,c1,_) = c1 projBlock (_,_,b1) = b1 byNums ns [] = [ (n, reverse ps) | (n,ps) <- ns ] byNums ns ((pos,r):t) = byNums [if n `inRange` r then (n,pos:ps) else (n,ps) |(n,ps)<-ns] t -- narrowPos eliminates impossible positions, noting any new singletons arising -- (findNarrowPos returns things to eliminate in order, so we can use an adjusted zipWith) narrowPos p = [ (catMaybes ss,p') | not $ or [nullRange r|(ijk,r)<-p'] ] where (ss,p') = unzip (narrow' p (findNarrowPos p)) narrow' ps [] = map ((,)Nothing) ps narrow' (p@(ijk,r):ps) xs@((ijk',ns):t) | ijk/=ijk' = (Nothing,p):narrow' ps xs narrow' (p@(ijk,r):ps) xs@((ijk',ns):t) = p' :narrow' ps t where p' = case r `narrowedBy` ns of (r',Just x) -> (Just (ijk,x),(ijk,r')) -- new singleton (r',_ ) -> (Nothing ,(ijk,r')) narrow' ps xs = error $ "narrow': "++show (ps,xs) noNarrowPos p = [([],p)] -------------------------- solve by search, but with propagation checkGuess (cs,g) = ifE (checkSolvedPuzzle g) (putStrLn ("\nfound solution! guesses ("++show (length cs)++"): " ++show cs++"\n" ++writeLinedPuzzle g) >> return (Right g)) (return . Left) ifE c r l = either l (const r) c solve1st p = find1st (([],p):guesses p) where find1st (g:gs) = checkGuess g >>= either (const $ find1st gs) return solve p = mapM_ checkGuess (([],p):guesses p) guesses p = loop [] p where loop gs p = do {(c,p) <- candidates p; return (c:gs,p) ++ loop (c:gs) p} candidates p = do (pos,c,p) <- candidate p -- possible candidate (ss,p) <- set (pos,c) p -- commit, narrow ranges, note new singletons p <- propagate ss p -- iterate propagation of singletons return ((pos,c), p) -- return only locally consistent candidates -- every range element is a candidate, but consider each one only once candidate p = sift [ (pos,c,p) | (pos,r) <- p, let rl = range2list r, length rl > 1, c <- rl ] where sift [] = [] sift ((pos,c,p):t) = (pos,c,p):map (\(pos',c',p')->(pos',c',delete (pos,c) p')) (sift t) delete (pos,c) p = map (\(ijk,r)->if ijk==pos then (ijk,r `withOut` c) else (ijk,r) ) p -------------------------- let's try it.. -- main = mapM_ test [s1,s2,s3,s4,s5] -- main = (test.readPuzzleLine) s17_19390 -- main = (test.readPuzzleLine) s17_14994 -- main = (test.readPuzzleLine) s17_412 -- main = (test.readPuzzleLine) s17_5701 -- main = test s0 -- main = solve1st $ readPuzzle s0 {- about 17m for the whole set, use 1..1000 as smaller test -} main = do ls <- fmap lines $ readFile "sudoku17.txt" let tryIt (i,l) = do putStrLn $ "-----"++show i++"-----" test (readPuzzleLine l) mapM_ tryIt $ zip [1..] ls test s = do let p1 = readPuzzle s [p2] = propagate (findSingletonRanges p1) p1 putStrLn $ "input\n"++writeFuzzyPuzzle p1 putStrLn $ "after initial propagation\n"++writeFuzzyPuzzle p2 solve p2 -------------------------- some test cases -- from Michael Hanus' Curry solver s1 = ["9 2 5 ", " 4 6 3 ", " 3 6", " 9 2 ", " 5 8 ", " 7 4 3", "7 1 ", " 5 2 4 ", " 1 6 9"] s2 = ["819 5 ", " 2 75 ", " 371 4 6 ", "4 59 1 ", "7 3 8 2", " 3 62 7", " 5 7 921 ", " 64 9 ", " 2 438"] -- from the Haskell wiki sudoku page: s3 = [" 5 6 1" ," 48 7 " ,"8 52" ,"2 57 3 " ," " ," 3 69 5" ,"79 8" ," 1 65 " ,"5 3 6 " ] -- a mild one from The Times: s4 = ["7 6 2" ," 7 2 " ," 369 451 " ,"87 95" ," 1 3 " ,"69 21" ," 281 597 " ," 8 3 " ,"5 7 3" ] -- and a fiendish one from The Times: s5 = [" 23 7" ,"6 8 4 2 " ," 7 31" ,"5 7 " ," 9 4 " ," 2 9" ,"13 9 " ," 5 3 2 8" ,"4 16 " ] -- some "bad" cases (12 guesses, when propagation was buggy) from sudoku17.txt s17_412 = "000000051260000000008600000000071020040050000000000300000300400500900000700000000" s17_5701 = "000080010056000000030000000702010000400500600000000000000604500200000008000300000" --13??? s17_19390 = "057040006000000820040000000300100000000000045200000000100200300060070000000000000" s17_14994 = "018000700000300200070000000000071000600000040300000000500400003020080000000000060" -- last, but not least, the extreme test of no info at all: s0 = [" " ," " ," " ," " ," " ," " ," " ," " ," " ]