diff --git a/src/Sudoku.hs b/src/Sudoku.hs index 9bd4620..6c2934b 100644 --- a/src/Sudoku.hs +++ b/src/Sudoku.hs @@ -1,6 +1,6 @@ module Main where -import qualified Control.Applicative +import Control.Applicative ((<|>)) import qualified Control.Monad import qualified Data.Char import qualified Data.Function @@ -64,54 +64,60 @@ pruneGrid = fixM pruneGrid' where fixM f x = f x >>= \x' -> if x' == x then return x else fixM f x' +isFinishedGrid :: Grid -> Bool +isFinishedGrid grid = null [ () | Possible _ <- concat grid ] + isInvalidGrid :: Grid -> Bool isInvalidGrid grid = any isInvalidRow grid || any isInvalidRow (Data.List.transpose grid) || any isInvalidRow (subGridsToRows grid) where - isInvalidRow = not . isValidRow - isValidRow row = + isInvalidRow row = let fixeds = [x | Fixed x <- row] emptyPossibles = [x | Possible x <- row, null x] - in length fixeds == length (Data.List.nub fixeds) && null emptyPossibles + in hasDups fixeds || not (null emptyPossibles) -isFinishedGrid :: Grid -> Bool -isFinishedGrid grid = null [ () | Possible _ <- concat grid ] + hasDups l = hasDups' l [] + + hasDups' [] _ = False + hasDups' (y:ys) xs + | y `elem` xs = True + | otherwise = hasDups' ys (y:xs) solve :: Grid -> Maybe Grid -solve grid - | isInvalidGrid grid = Nothing - | isFinishedGrid grid = Just grid - | otherwise = - let (grid1, grid2) = splitGrid - in case pruneGrid grid1 of - Nothing -> pruneGrid grid2 >>= solve - Just grid' -> solve grid' Control.Applicative.<|> (pruneGrid grid2 >>= solve) - where - possibleVals (Fixed x) = [x] - possibleVals (Possible xs) = xs +solve grid = pruneGrid grid >>= solve' + where + solve' grid + | isInvalidGrid grid = Nothing + | isFinishedGrid grid = Just grid + | otherwise = + let (grid1, grid2) = nextGrids grid + in solve grid1 <|> solve grid2 - smallestPossible = - Data.List.minimumBy (compare `Data.Function.on` (length . possibleVals . snd)) - [(i, c) | (i, c@(Possible _)) <- zip [0..] $ concat grid] + nextGrids grid = + let (i, first@(Fixed _), rest) = splitPossible . smallestPossible $ grid + in (replace2D i first grid, replace2D i rest grid) - splitPossible (i, Possible (x:[y])) = (i, Fixed x, Fixed y) - splitPossible (i, Possible (x:xs)) = (i, Fixed x, Possible xs) - splitPossible _ = error "Impossible case" + smallestPossible grid = + Data.List.minimumBy (compare `Data.Function.on` (length . possibleVals . snd)) + [(i, c) | (i, c@(Possible _)) <- zip [0..] $ concat grid] - splitGrid = - let (i, first@(Fixed _), rest) = splitPossible smallestPossible - in (replace2D i first grid, replace2D i rest grid) + possibleVals (Fixed x) = [x] + possibleVals (Possible xs) = xs - replace2D i v = let (x, y) = (i `quot` 9, i `mod` 9) in replace x (replace y (const v)) - replace p f xs = [if i == p then f x else x | (x, i) <- zip xs [0..]] + splitPossible (i, Possible (x:[y])) = (i, Fixed x, Fixed y) + splitPossible (i, Possible (x:xs)) = (i, Fixed x, Possible xs) + splitPossible _ = error "Impossible case" + + replace2D i v = let (x, y) = (i `quot` 9, i `mod` 9) in replace x (replace y (const v)) + replace p f xs = [if i == p then f x else x | (x, i) <- zip xs [0..]] main = do grids <- lines <$> getContents Control.Monad.forM_ grids $ \grid -> case readGrid grid of Nothing -> putStrLn "Invalid grid" - Just grid -> case pruneGrid grid >>= solve of + Just grid -> case solve grid of Nothing -> putStrLn "No solution found" Just grid' -> putStrLn $ showGrid grid'