diff --git a/package.yaml b/package.yaml index 852595f..5cc9757 100644 --- a/package.yaml +++ b/package.yaml @@ -15,13 +15,14 @@ dependencies: - base >= 4.7 && < 5 executables: - hasdoku: + sudoku: main: Sudoku.hs source-dirs: src ghc-options: - -threaded - -rtsopts - -with-rtsopts=-N + - -O2 dependencies: - split diff --git a/src/Sudoku.hs b/src/Sudoku.hs index 6c2934b..9bcd3ef 100644 --- a/src/Sudoku.hs +++ b/src/Sudoku.hs @@ -64,11 +64,11 @@ 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 ] +isGridFilled :: Grid -> Bool +isGridFilled grid = null [ () | Possible _ <- concat grid ] -isInvalidGrid :: Grid -> Bool -isInvalidGrid grid = +isGridInvalid :: Grid -> Bool +isGridInvalid grid = any isInvalidRow grid || any isInvalidRow (Data.List.transpose grid) || any isInvalidRow (subGridsToRows grid) @@ -85,39 +85,47 @@ isInvalidGrid grid = | y `elem` xs = True | otherwise = hasDups' ys (y:xs) -solve :: Grid -> Maybe Grid -solve grid = pruneGrid grid >>= solve' +nextGrids :: Grid -> (Grid, Grid) +nextGrids grid = + let (i, first@(Fixed _), rest) = + fixCell + . Data.List.minimumBy (compare `Data.Function.on` (possibilityCount . snd)) + . filter (isPossible . snd) + . zip [0..] + . concat + $ grid + in (replace2D i first grid, replace2D i rest grid) where - solve' grid - | isInvalidGrid grid = Nothing - | isFinishedGrid grid = Just grid - | otherwise = - let (grid1, grid2) = nextGrids grid - in solve grid1 <|> solve grid2 + isPossible (Possible _) = True + isPossible _ = False - nextGrids grid = - let (i, first@(Fixed _), rest) = splitPossible . smallestPossible $ grid - in (replace2D i first grid, replace2D i rest grid) + possibilityCount (Possible xs) = length xs + possibilityCount (Fixed _) = 1 - smallestPossible grid = - Data.List.minimumBy (compare `Data.Function.on` (length . possibleVals . snd)) - [(i, c) | (i, c@(Possible _)) <- zip [0..] $ concat grid] - - possibleVals (Fixed x) = [x] - possibleVals (Possible xs) = xs - - splitPossible (i, Possible (x:[y])) = (i, Fixed x, Fixed y) - splitPossible (i, Possible (x:xs)) = (i, Fixed x, Possible xs) - splitPossible _ = error "Impossible case" + fixCell (i, Possible [x, y]) = (i, Fixed x, Fixed y) + fixCell (i, Possible (x:xs)) = (i, Fixed x, Possible xs) + fixCell _ = error "Impossible case" + replace2D :: Int -> a -> [[a]] -> [[a]] 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..]] +solve :: Grid -> Maybe Grid +solve grid = pruneGrid grid >>= solve' + where + solve' grid' + | isGridInvalid grid = Nothing + | isGridFilled grid' = Just grid' + | otherwise = + let (grid1, grid2) = nextGrids grid' + in solve grid1 <|> solve grid2 + +main :: IO () main = do - grids <- lines <$> getContents - Control.Monad.forM_ grids $ \grid -> - case readGrid grid of - Nothing -> putStrLn "Invalid grid" + inputs <- lines <$> getContents + Control.Monad.forM_ inputs $ \input -> + case readGrid input of + Nothing -> putStrLn "Invalid input" Just grid -> case solve grid of - Nothing -> putStrLn "No solution found" + Nothing -> putStrLn "No solution found" Just grid' -> putStrLn $ showGrid grid'