{-# LANGUAGE TupleSections, ScopedTypeVariables, RankNTypes #-} module Exercise03 where import Text.Printf (printf) import Data.List import qualified Data.IntSet as IS import Data.IntSet (IntSet) import qualified Data.Set as S import Data.Set (Set) import qualified Data.Map as M import Data.Map (Map) import qualified Data.IntMap as IM import Data.IntMap (IntMap) import Data.Array import Data.Maybe import Data.Char import Control.Arrow import Control.Monad import Control.Applicative -- HA 3.1a) i selectRow :: [[Int]] -> Int -> [Int] selectRow xss i = undefined -- HA 3.1a) ii selectColumn :: [[Int]] -> Int -> [Int] selectColumn xss i = undefined -- HA 3.1a) iii intRoot :: Int -> Int intRoot = floor . sqrt . fromIntegral chunksOf :: Int -> [e] -> [[e]] chunksOf i [] = [] chunksOf i ls = case splitAt i ls of (ls1, ls2) -> ls1 : chunksOf i ls2 data Sudoku = Sudoku {size :: !Int, blockSize :: !Int, content :: !(Array Pos IntSet), openPositions :: !(Set Pos), seenSets :: !(Array Pos (Set Pos))} instance Eq Sudoku where sud1 == sud2 = size sud1 == size sud2 && content sud1 == content sud2 instance Ord Sudoku where sud1 <= sud2 = size sud1 == size sud2 && and (zipWith IS.isSubsetOf (elems (content sud1)) (elems (content sud2))) showCell :: IntSet -> String showCell s = if IS.null s then "0" else concatMap show (IS.toAscList s) instance Show Sudoku where show sud = unlines $ map (unwords . map pad) tbl where n = size sud tbl = [[showCell (cell sud (i, j)) | j <- [0..n-1]] | i <- [0..n-1]] m = maximum (map length (concat tbl)) pad xs = replicate (m - length xs) ' ' ++ xs difficulty :: Sudoku -> Double difficulty sud = sum $ map (\s -> let n = fromIntegral (IS.size s) in log n) (elems (content sud)) mkSudoku :: [[Int]] -> Sudoku mkSudoku sud = case fastSimplify (foldl (\sud (pos,x) -> setCellInternal sud pos x) sud' [(pos, x) | (pos, x) <- ps, x /= 0]) of Just sud' -> sud' Nothing -> error "invalid sudoku" where n = length sud ps = [((i, j), x) | (i, row) <- zip [0..] sud, (j, x) <- zip [0..] row] a = listArray ((0,0),(n-1,n-1)) (repeat (IS.fromList [1..n])) seenSets = listArray ((0,0),(n-1,n-1)) [mkSeenSet n pos | pos <- liftM2 (,) [0..n-1] [0..n-1]] sud' = Sudoku n (intRoot n) a (S.fromList [pos | (pos, x) <- ps, x == 0]) seenSets destSudoku :: Sudoku -> [[Int]] destSudoku sud = chunksOf (size sud) (map (\s -> if IS.size s == 1 then IS.findMin s else 0) (elems (content sud))) cell :: Sudoku -> Pos -> IntSet cell sud pos = content sud ! pos setCellInternal :: Sudoku -> Pos -> Int -> Sudoku setCellInternal sud (i,j) x = Sudoku n m (a // upds) (S.delete (i,j) (openPositions sud)) (seenSets sud) where n = size sud m = blockSize sud a = content sud deleteFrom poss = [(pos', IS.delete x (a ! pos')) | pos' <- poss] idxs k = [0..k-1] ++ [k+1..n-1] sqIdxs = delete (i, j) $ liftM2 (,) [i' .. i'+m-1] [j' .. j'+m-1] where i' = i `div` m * m j' = j `div` m * m upds = ((i,j), if x `IS.member` (a ! (i,j)) then IS.singleton x else IS.empty) : deleteFrom (map (i,) (idxs j) ++ map (,j) (idxs i) ++ sqIdxs) boxPosOf :: Sudoku -> Pos -> Pos boxPosOf sud (i, j) = (i `div` m * m, j `div` m * m) where m = blockSize sud boxOf :: Sudoku -> Pos -> [Pos] boxOf sud pos = liftM2 (,) [i' .. i'+m-1] [j' .. j'+m-1] where (i', j') = boxPosOf sud pos m = blockSize sud rowOf :: Sudoku -> Pos -> [Pos] rowOf sud (i, _) = map (i,) [0..size sud - 1] colOf :: Sudoku -> Pos -> [Pos] colOf sud (_, j) = map (,j) [0..size sud - 1] mkSeenSet :: Int -> Pos -> S.Set Pos mkSeenSet n pos = S.unions $ map (S.delete pos . S.fromList) [rowOf' pos, colOf' pos, boxOf' pos] where rowOf' (i, _) = map (i,) [0..n-1] colOf' (_, j) = map (,j) [0..n-1] boxOf' (i, j) = liftM2 (,) [i' .. i'+m-1] [j' .. j'+m-1] where (i', j') = (i `div` m * m, j `div` m * m) m = intRoot n seenSet :: Sudoku -> Pos -> S.Set Pos seenSet sud pos = seenSets sud ! pos --seenSet sud pos = S.unions $ map (S.delete pos . S.fromList) [rowOf sud pos, colOf sud pos, boxOf sud pos] setCell' :: Sudoku -> Pos -> Int -> Maybe Sudoku setCell' sud pos x = simplifySudoku (setCellInternal sud pos x) repeatSimplification :: (Sudoku -> Maybe Sudoku) -> Sudoku -> Maybe Sudoku repeatSimplification f sud | not (isValid sud) = Nothing | isSolved sud = Just sud | otherwise = case sud' of Nothing -> Nothing Just sud' -> if sud' /= sud then repeatSimplification f sud' else Just sud where sud' = f sud repeatSimplification' f = fastSimplify >=> repeatSimplification f >=> fastSimplify fastSimplify :: Sudoku -> Maybe Sudoku fastSimplify sud | null poss = Just sud | not (isValid sud') = Nothing | otherwise = fastSimplify sud' where sud' = foldl' (\sud (pos, x) -> setCellInternal sud pos x) sud poss poss = nakedSingles sud simplifyHiddenSingles :: Sudoku -> Maybe Sudoku simplifyHiddenSingles sud = Just $ foldl' (\sud (pos, x) -> setCellInternal sud pos x) sud (hiddenSingles sud) simplify2 :: Sudoku -> Maybe Sudoku simplify2 sud = case forcedGroups sud of Nothing -> Nothing Just gs -> Just $ foldl' f sud gs where f sud (ps1, ps2, s) = sud {content = content sud // upds} where upds = [(p, cell sud p `IS.intersection` s) | p <- ps1] ++ [(p, cell sud p IS.\\ s) | p <- ps2] xWings :: Sudoku -> [([Pos], Int)] xWings sud = do rowMode <- [True, False] let colIdx = if rowMode then snd else fst let rowIdx = if rowMode then fst else snd (row1, remainingRows) <- pickElementAndRemainder (if rowMode then rowPositions sud else colPositions sud) x <- [1..size sud] let cands1 = candidates x row1 guard (length cands1 == 2) row2 <- remainingRows let cands2 = candidates x row2 guard (map colIdx cands1 == map colIdx cands2) let ps = concatMap (if rowMode then colOf sud else rowOf sud) cands1 let ps' = [p | p <- ps, rowIdx p `notElem` map (rowIdx . head) [cands1, cands2], x `IS.member` cell sud p] guard (not (null ps')) return (ps', x) where candidates x ps = [p | p <- ps, x `IS.member` cell sud p] yWings :: Sudoku -> [([Pos], Int)] yWings sud = do pivot <- positions sud let sPivot = cell sud pivot guard (IS.size sPivot == 2) let seenPivot = S.toAscList (seenSet sud pivot) let wings = [p | p <- seenPivot, let s = cell sud p, IS.size s == 2 && IS.size (IS.intersection sPivot s) == 1] (wing1, wing2) <- pick2 wings let (sWing1, sWing2) = (cell sud wing1, cell sud wing2) guard (IS.size (IS.intersection sWing1 sWing2) == 1 && IS.intersection sWing1 sPivot /= IS.intersection sWing2 sPivot) let z = IS.findMin (IS.intersection sWing1 sWing2) let ps = S.toAscList (S.intersection (seenSet sud wing1) (seenSet sud wing2)) let ps' = [p | p <- ps, z `IS.member` cell sud p] guard (not (null ps')) return (ps', z) xyzWings :: Sudoku -> [([Pos], Int)] xyzWings sud = do b1 <- squarePositions sud pivot <- b1 let sPivot = cell sud pivot guard (IS.size sPivot == 3) wing1 <- delete pivot b1 let sWing1 = cell sud wing1 guard (IS.size sWing1 == 2 && IS.isSubsetOf sWing1 sPivot) b2 <- rowPositions sud ++ colPositions sud guard (pivot `elem` b2 && wing1 `notElem` b2) let b12 = delete pivot (intersect b1 b2) wing2 <- b2 \\ b1 let sWing2 = cell sud wing2 guard (IS.size sWing2 == 2 && IS.isSubsetOf sWing2 sPivot && IS.size (IS.intersection sWing1 sWing2) == 1) let z = IS.findMin (IS.intersection sWing1 sWing2) let ps = [p | p <- b12, z `IS.member` cell sud p] guard (not (null ps)) return (ps, z) where bs = blocks sud showIntSet :: IntSet -> String showIntSet s = if IS.null s then "0" else concatMap show (IS.toAscList s) positions :: Sudoku -> [Pos] positions sud = liftM2 (,) [0..n-1] [0..n-1] where n = size sud xyWings :: Sudoku -> [([Pos], Int)] xyWings sud = do pivot <- positions sud let sPivot = cell sud pivot guard (IS.size sPivot == 2) let seenPivot = seenSet sud pivot (wing1, wing2) <- pick2 [p | p <- S.toAscList seenPivot, let s = cell sud p, IS.size s == 2 && IS.size (IS.intersection s sPivot) == 1] let (sWing1, sWing2) = (cell sud wing1, cell sud wing2) let x = IS.findMin (IS.intersection sWing1 sPivot) let y = IS.findMin (IS.intersection sWing2 sPivot) let z = IS.findMin (IS.delete x sWing1) guard (IS.intersection sWing1 sWing2 == IS.singleton z) let ps = filter (\p -> z `IS.member` cell sud p) $ S.toAscList (S.intersection (seenSet sud wing1) (seenSet sud wing2)) guard (not (null ps)) return (ps, z) where bs = blocks sud sameRow :: [Pos] -> Bool sameRow [] = True sameRow ((i, _) : ps) = all (== i) (map fst ps) sameCol :: [Pos] -> Bool sameCol [] = True sameCol ((_, j) : ps) = all (== j) (map snd ps) sameBox :: Sudoku -> [Pos] -> Bool sameBox sud [] = True sameBox sud (p : ps) = all (== boxPosOf sud p) (map (boxPosOf sud) ps) pointingGroups :: Sudoku -> [([Pos], Int)] pointingGroups sud = do box <- squarePositions sud let boxId = boxPosOf sud (head box) x <- [1..size sud] let candidatePositions = [p | p <- box, x `IS.member` cell sud p] guard (length candidatePositions > 1) if sameRow candidatePositions then do let ps = [p | p <- rowOf sud (head candidatePositions), boxPosOf sud p /= boxId, x `IS.member` cell sud p] guard (not (null ps)) return (ps, x) else if sameCol candidatePositions then do let ps = [p | p <- colOf sud (head candidatePositions), boxPosOf sud p /= boxId, x `IS.member` cell sud p] guard (not (null ps)) return (ps, x) else [] boxLineReductions :: Sudoku -> [([Pos], Int)] boxLineReductions sud = do line <- rowPositions sud ++ colPositions sud x <- [1..size sud] let candidatePositions = [p | p <- line, x `IS.member` cell sud p] guard (length candidatePositions > 1) if sameBox sud candidatePositions then do let ps = [p | p <- boxOf sud (head candidatePositions), p `notElem` line, x `IS.member` cell sud p] guard (not (null ps)) return (ps, x) else [] simplify3 :: Sudoku -> Maybe Sudoku simplify3 sud = Just $ foldl' f sud (xWings sud ++ yWings sud ++ xyWings sud ++ xyzWings sud ++ pointingGroups sud ++ boxLineReductions sud) where f sud (ps, z) = sud {content = content sud // upds} where upds = [(p, IS.delete z (cell sud p)) | p <- ps] strongLinksInBlock :: Sudoku -> [Pos] -> [(Int, (Pos, Pos))] strongLinksInBlock sud b = do x <- [1..size sud] let ps = [p | p <- b, x `IS.member` cell sud p] case ps of [p1, p2] -> [(x, (p1, p2)), (x, (p2, p1))] _ -> [] linksInBlock :: Sudoku -> [Pos] -> [(Int, (Pos, Pos))] linksInBlock sud b = do x <- [1..size sud] let ps = [p | p <- b, x `IS.member` cell sud p] guard (length ps > 1) fmap (x,) (liftM2 (,) ps ps) strongLinks :: Sudoku -> [(Int, [(Pos, Pos)])] strongLinks sud = map (\xs -> (fst (head xs), S.toAscList $ S.fromList $ map snd xs)) $ groupBy (\a b -> fst a == fst b) $ sortOn fst ls where ls = concatMap (strongLinksInBlock sud) (blocks sud) links :: Sudoku -> [(Int, [(Pos, Pos)])] links sud = map (\xs -> (fst (head xs), S.toAscList $ S.fromList $ map snd xs)) $ groupBy (\a b -> fst a == fst b) $ sortOn fst ls where ls = concatMap (linksInBlock sud) (blocks sud) type LinkGraph = Map Pos [Pos] type Colour = Int type ColourMap = Map Pos Colour mkLinkGraph :: [(Pos, Pos)] -> LinkGraph mkLinkGraph = M.fromList . map (\xs -> (fst (head xs), map snd xs)) . groupBy (\a b -> fst a == fst b) . sortOn fst colouriseLinks :: Sudoku -> LinkGraph -> Maybe ColourMap colouriseLinks sud g = go 0 M.empty (M.keysSet g) where dfs (c1, c2) colourMap p = case M.lookup p colourMap of Just c -> if c == c1 then Just colourMap else Nothing -- link cycle of odd length Nothing -> let colourMap' = M.insert p c1 colourMap in foldM (dfs (c2, c1)) colourMap' (g M.! p) go nextColour colourMap ps = case S.minView ps of Nothing -> Just colourMap Just (p, ps') -> do colourMap' <- dfs (nextColour, nextColour + 1) colourMap p go (nextColour + 2) colourMap' (ps' S.\\ M.keysSet colourMap') colourClasses :: ColourMap -> [(Colour, Set Pos)] colourClasses = M.toAscList . M.fromListWith S.union . map (\(x,y) -> (y, S.singleton x)) . M.toList sameColourTwiceInBlock :: Sudoku -> Int -> ColourMap -> [([Pos], Int)] sameColourTwiceInBlock sud x colourMap = do (_, cls) <- colourClasses colourMap let sz = S.size cls -- colour class has two positions in same region guard (any (/= sz) [S.size (S.map fst cls), S.size (S.map snd cls), S.size (S.map (boxPosOf sud) cls)]) --trace "Same color twice in block" $ return (S.toAscList cls, x) hasComplementaryColours :: [Colour] -> Bool hasComplementaryColours cs = or (zipWith f cs (tail cs)) where f c1 c2 = even c1 && c2 == c1 + 1 differentColoursSeen :: Sudoku -> Int -> ColourMap -> [([Pos], Int)] differentColoursSeen sud x colourMap = do p <- S.toAscList sPoss guard (x `IS.member` cell sud p) -- which colours are seen from p ? let cs = S.toAscList $ S.map (colourMap M.!) $ S.intersection (seenSet sud p) (M.keysSet colourMap) guard (hasComplementaryColours cs) --trace "Different colours seen" $ return ([p], x) where sPoss = S.fromList [p | p <- positions sud, x `IS.member` cell sud p] S.\\ M.keysSet colourMap simplify4 :: Sudoku -> Maybe Sudoku simplify4 sud = do xs <- fmap concat (mapM aux (strongLinks sud)) return $ foldl (\sud (ps, x) -> sud {content = content sud // [(p, IS.delete x (cell sud p)) | p <- ps]}) sud xs where aux (x, ls) = do colourMap <- colouriseLinks sud (mkLinkGraph ls) return $ sameColourTwiceInBlock sud x colourMap ++ differentColoursSeen sud x colourMap runSimplifications [] sud = Just sud runSimplifications (s : ss) sud = case s sud of Nothing -> Nothing Just sud' -> if sud' == sud then runSimplifications ss sud else Just sud' simplifySudoku :: Sudoku -> Maybe Sudoku simplifySudoku = repeatSimplification' $ runSimplifications [simplifyHiddenSingles, simplify2, simplify3, simplify4] isValid :: Sudoku -> Bool isValid sud = not (any IS.null (elems (content sud))) && and [any (\p -> x `IS.member` cell sud p) block | block <- blocks sud, x <- [1..n]] where n = size sud isSolved :: Sudoku -> Bool isSolved sud = S.null (openPositions sud) rowPositions :: Sudoku -> [[Pos]] rowPositions sud = [[(i, j) | j <- [0..n-1]] | i <- [0..n-1]] where n = size sud colPositions :: Sudoku -> [[Pos]] colPositions sud = [[(j, i) | j <- [0..n-1]] | i <- [0..n-1]] where n = size sud squarePositions :: Sudoku -> [[Pos]] squarePositions sud = [[(i*m+k, j*m+l) | k <- [0..m-1], l <- [0..m-1]] | j <- [0..m-1], i <- [0..m-1]] where n = size sud m = blockSize sud blocks :: Sudoku -> [[Pos]] blocks sud = rowPositions sud ++ colPositions sud ++ squarePositions sud isSingleton :: [a] -> Bool isSingleton [x] = True isSingleton _ = False hiddenSinglesInBlock :: Sudoku -> [Pos] -> [(Pos, Int)] hiddenSinglesInBlock sud b = do (x, p) <- IM.toList $ IM.fromListWith (const $ const Nothing) [(x, Just p) | p <- b, x <- IS.toAscList (cell sud p)] p' <- maybeToList p return (p', x) hiddenSingles :: Sudoku -> [(Pos, Int)] hiddenSingles sud = do b <- blocks sud let b' = S.toAscList (S.intersection (S.fromList b) (openPositions sud)) hiddenSinglesInBlock sud b' nakedSingles :: Sudoku -> [(Pos, Int)] nakedSingles sud = [(p, IS.findMin s) | p <- S.toList $ openPositions sud, let s = cell sud p, IS.size s == 1] pickElementAndRemainder :: [a] -> [(a, [a])] pickElementAndRemainder [] = [] pickElementAndRemainder (x : xs) = (x, xs) : pickElementAndRemainder xs subsetsOfSize :: Int -> [a] -> [[a]] subsetsOfSize 0 _ = return [] subsetsOfSize 1 xs = map return xs subsetsOfSize n xs = do (x, xs') <- pickElementAndRemainder xs xs'' <- subsetsOfSize (n - 1) xs' return (x : xs'') forcedNakedGroupsInBlock :: Sudoku -> [Pos] -> Maybe [([Pos], [Pos], IntSet)] forcedNakedGroupsInBlock sud b = sequence $ do len <- [2..4] guard (len > 0 && len < size sud) (ps, s) <- foo IS.empty IS.union IS.size len [(p, s) | p <- b, let s = cell sud p, let k = IS.size s, k > 1 && k <= len] -- the positions "ps" can only take values from s, i.e. we have an injective map from ps to s case compare (IS.size s) len of GT -> [] -- this gives us no information LT -> return Nothing -- this is impossible EQ -> return $ Just (ps, b \\ ps, s) -- this tells us that the map is a bijection, i.e. the elements in b \\ ps cannot take values from s foo :: a -> (a -> a -> a) -> (a -> Int) -> Int -> [(b, a)] -> [([b], a)] foo emp un sz n xs = aux xs [] emp n where aux _ acc accSet 0 = if sz accSet <= n then [(acc, accSet)] else [] aux xs acc accSet k = do guard (sz accSet <= n) ((x, s), xs') <- pickElementAndRemainder xs aux xs' (x : acc) (un accSet s) (k - 1) forcedHiddenGroupsInBlock :: Sudoku -> [Pos] -> Maybe [([Pos], [Pos], IntSet)] forcedHiddenGroupsInBlock sud b = sequence $ do let allNumbers = filter ((> 0) . S.size . snd) $ IM.toList $ IM.fromListWith S.union [(x, S.singleton p) | p <- b, x <- IS.toAscList (cell sud p)] -- [(x, s) | x <- [1..size sud], let s = S.fromList [p | p <- b, x `IS.member` cell sud p]] sz <- [2..2] guard (sz > 0 && sz < size sud) (numbers, ps) <- foo S.empty S.union S.size sz [(x, s) | (x, s) <- allNumbers, S.size s <= sz] -- the numbers in "numbers" can only occur in the positions "ps", i.e. we have an injective map from "numbers" to "ps" case compare (S.size ps) sz of GT -> [] -- this gives us no information LT -> return Nothing -- this is impossible EQ -> return $ Just (S.toAscList ps, S.toAscList (S.fromList b S.\\ ps), IS.fromList numbers) -- this tells us that the map is a bijection, i.e. the numbers outside "numbers" cannot be mapped to any position in "ps" forcedGroups :: Sudoku -> Maybe [([Pos], [Pos], IntSet)] forcedGroups sud = fmap concat $ sequence [liftM2 (++) (forcedNakedGroupsInBlock sud b) (forcedHiddenGroupsInBlock sud b) | b <- blocks sud] readSudoku :: String -> IO Sudoku readSudoku = fmap mkSudoku . readRawSudoku -- HA 3.1d) solveSudoku'' :: Sudoku -> [Sudoku] solveSudoku'' sud | not (isValid sud) = [] | isSolved sud = return sud | otherwise = do pos <- sortOn (IS.size . cell sud) (S.toList (openPositions sud)) x <- IS.toAscList (cell sud pos) sud' <- maybeToList (setCell' sud pos x) solveSudoku'' sud' solveSudoku' :: Sudoku -> [Sudoku] solveSudoku' sud | not (isValid sud) = [] | isSolved sud = return sud | otherwise = do (pos, xs) <- brutePositions (x, sud') <- xs solveSudoku' sud' -- (trace "bruteforcing\n" sud') where brutePositions = map fst $ sortOn snd $ do pos <- S.toAscList (openPositions sud) let xs = [((x, sud'), difficulty sud') | x <- IS.toAscList (cell sud pos), sud' <- maybeToList $ setCell' sud pos x] guard (not (null xs)) return ((pos, map fst (sortOn snd xs)), sum (map snd xs)) {-WETT-} solveSudoku :: RawSudoku -> RawSudoku solveSudoku = destSudoku . head . solveSudoku' . mkSudoku {-TTEW-} type RawSudoku = [[Int]] type Pos = (Int, Int) rows :: RawSudoku -> [[Int]] rows = id cols :: RawSudoku -> [[Int]] cols = transpose squares :: RawSudoku -> [[Int]] squares sud = [concat colBlock | rowBlock <- chunksOf m sud, colBlock <- transpose (map (chunksOf m) rowBlock)] where n = length sud m = intRoot n --return numbers in square as a list. squares are numbered from left to right and top to bottom --e.g. : --[0,1,2] --[3,4,5] --[6,7,8] selectSquare :: RawSudoku -> Int ->[Int] selectSquare sud i = squares sud !! i distinct :: [Int] -> Bool distinct xs = and (zipWith (/=) ys (tail ys)) where ys = sort (filter (> 0) xs) -- HA 3.1b) isValidSubsection :: [Int] -> Bool isValidSubsection xs = all (\x -> x >= 0 && x <= n) xs && distinct xs where n = length xs isValidRawSudoku :: RawSudoku -> Bool isValidRawSudoku sud = and [all isValidSubsection (f sud) | f <- [rows, cols, squares]] -- HA 3.1c) setCell :: [[Int]] -> (Int,Int) -> Int -> [[Int]] setCell sud (j, k) x = case splitAt j sud of (rows1, row : rows2) -> case splitAt k row of (cols1, _ : cols2) -> rows1 ++ [cols1 ++ [x] ++ cols2] ++ rows2 pick :: [a] -> [(a, [a])] pick [] = [] pick (x : xs) = (x, xs) : map (second (x:)) (pick xs) readRawSudoku :: String -> IO RawSudoku readRawSudoku s = fmap (map (map read . words) . lines) (readFile s) solveSudokuBrute :: [[Int]] -> [[Int]] solveSudokuBrute sud = head $ go sud [(i, j) | (i, row) <- zip [0..] sud, (j, x) <- zip [0..] row, x == 0] where n = length sud go sud [] = return sud go sud openPositions | not (isValidRawSudoku sud) = [] | otherwise = do (pos, openPositions') <- pick openPositions x <- [1..n] go (setCell sud pos x) openPositions' hardSudoku :: [[Int]] hardSudoku = [[8,0,0,0,0,0,0,0,0], [0,0,3,6,0,0,0,0,0], [0,7,0,0,9,0,2,0,0], [0,5,0,0,0,7,0,0,0], [0,0,0,0,4,5,7,0,0], [0,0,0,1,0,0,0,3,0], [0,0,1,0,0,0,0,6,8], [0,0,8,5,0,0,0,1,0], [0,9,0,0,0,0,4,0,0]] pick2 :: [a] -> [(a, a)] pick2 [] = [] pick2 (x : xs) = [(x, y) | y <- xs] ++ pick2 xs toDimacs :: Sudoku -> (Int, [[Int]]) toDimacs sud = (n ^ 3, clauses) where n = size sud poss = liftM2 (,) [0..n-1] [0..n-1] mkVar (i, j) x = x + n * (i + n * j) clauses = [[mkVar pos x | x <- IS.toAscList (cell sud pos)] | pos <- poss] ++ [[-mkVar pos x, -mkVar pos y] | pos <- poss, x <- [1..n], y <- [1..x-1]] ++ [[-mkVar pos1 x, -mkVar pos2 x] | b <- blocks sud, (pos1, pos2) <- pick2 b, x <- [1..n]] printDimacs :: (Int, [[Int]]) -> String printDimacs (nVars, clauses) = unlines $ printf "p cnf %d %d" nVars (length clauses) : map (\c -> unwords $ map show $ c ++ [0]) clauses writeDimacs :: String -> Sudoku -> IO () writeDimacs s sud = writeFile s (printDimacs $ toDimacs sud) readDimacsResult :: String -> Maybe (Map Int Bool) readDimacsResult s | l == "s SATISFIABLE" = Just (M.fromList vs) | otherwise = Nothing where l : ls = filter (not . ("c" `isPrefixOf`)) (lines s) vs = map (\n -> (abs n, n > 0)) . filter (/= 0) . concatMap (map read . words) $ mapMaybe (stripPrefix "v ") ls rawSudokuFromDimacsResult :: Int -> Map Int Bool -> [[Int]] rawSudokuFromDimacsResult n v = [[lu i j | j <- [0..n-1]] | i <- [0..n-1]] where mkVar (i, j) x = (x + n * (i + n * j)) lu i j = head [x | x <- [1..n], M.lookup (mkVar (i, j) x) v /= Just False] -- Utility method to show a RawSudoku -- show RawSudoku with -- >>> putStr (showRawSudoku RawSudoku) showSudoku :: [[Int]] -> String showSudoku xss = unlines $ intercalate [showDivider] $ chunksOf squareSize $ map showRow xss where size = length xss squareSize = intRoot size numberSize = size `div` 10 + 1 showRowSection xs = unwords $ map (printf ("%0" ++ show numberSize ++ "d")) xs showRow xs = intercalate "|" $ map showRowSection $ chunksOf squareSize xs showDivider = intercalate "+" $ replicate squareSize $ replicate ((numberSize + 1) * squareSize - 1) '-' chunksOf :: Int -> [e] -> [[e]] chunksOf i [] = [] chunksOf i ls = take i ls : chunksOf i (drop i ls) assert :: String -> Bool -> IO () assert _ True = return () assert s False = error s