118 lines
3.8 KiB
Haskell
118 lines
3.8 KiB
Haskell
module Main where
|
|
|
|
import qualified Control.Applicative
|
|
import qualified Control.Monad
|
|
import qualified Data.Char
|
|
import qualified Data.Function
|
|
import qualified Data.List.Split
|
|
import qualified Data.List
|
|
|
|
data Cell = Fixed Int | Possible [Int] deriving (Show, Eq)
|
|
type Row = [Cell]
|
|
type Grid = [Row]
|
|
|
|
readGrid :: String -> Maybe Grid
|
|
readGrid s
|
|
| length s == 81 = traverse (traverse readCell) . Data.List.Split.chunksOf 9 $ s
|
|
| otherwise = Nothing
|
|
where
|
|
readCell '.' = Just $ Possible [1..9]
|
|
readCell c
|
|
| Data.Char.isDigit c && c > '0' = Just . Fixed . Data.Char.digitToInt $ c
|
|
| otherwise = Nothing
|
|
|
|
showGrid :: Grid -> String
|
|
showGrid = unlines . map (unwords . map showCell)
|
|
where
|
|
showCell (Fixed x) = show x
|
|
showCell _ = "."
|
|
|
|
showGridWithPossibilities :: Grid -> String
|
|
showGridWithPossibilities = unlines . map (unwords . map showCell)
|
|
where
|
|
showCell (Fixed x) = show x ++ " "
|
|
showCell (Possible xs) =
|
|
(++ "]")
|
|
. Data.List.foldl' (\acc x -> acc ++ if x `elem` xs then show x else " ") "["
|
|
$ [1..9]
|
|
|
|
pruneCells :: [Cell] -> Maybe [Cell]
|
|
pruneCells cells = traverse pruneCell cells
|
|
where
|
|
fixeds = [x | Fixed x <- cells]
|
|
|
|
pruneCell (Possible xs) = case xs Data.List.\\ fixeds of
|
|
[] -> Nothing
|
|
[y] -> Just $ Fixed y
|
|
ys -> Just $ Possible ys
|
|
pruneCell x = Just x
|
|
|
|
subGridsToRows :: Grid -> Grid
|
|
subGridsToRows =
|
|
concatMap (\rows -> let [r1, r2, r3] = map (Data.List.Split.chunksOf 3) rows
|
|
in zipWith3 (\a b c -> a ++ b ++ c) r1 r2 r3)
|
|
. Data.List.Split.chunksOf 3
|
|
|
|
pruneGrid' :: Grid -> Maybe Grid
|
|
pruneGrid' grid =
|
|
traverse pruneCells grid
|
|
>>= fmap Data.List.transpose . traverse pruneCells . Data.List.transpose
|
|
>>= fmap subGridsToRows . traverse pruneCells . subGridsToRows
|
|
|
|
pruneGrid :: Grid -> Maybe Grid
|
|
pruneGrid = fixM pruneGrid'
|
|
where
|
|
fixM f x = f x >>= \x' -> if x' == x then return x else fixM f x'
|
|
|
|
isInvalidGrid :: Grid -> Bool
|
|
isInvalidGrid grid =
|
|
any isInvalidRow grid
|
|
|| any isInvalidRow (Data.List.transpose grid)
|
|
|| any isInvalidRow (subGridsToRows grid)
|
|
where
|
|
isInvalidRow = not . isValidRow
|
|
isValidRow row =
|
|
let fixeds = [x | Fixed x <- row]
|
|
emptyPossibles = [x | Possible x <- row, null x]
|
|
in length fixeds == length (Data.List.nub fixeds) && null emptyPossibles
|
|
|
|
isFinishedGrid :: Grid -> Bool
|
|
isFinishedGrid grid = null [ () | Possible _ <- concat grid ]
|
|
|
|
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
|
|
|
|
smallestPossible =
|
|
Data.List.minimumBy (compare `Data.Function.on` (length . possibleVals . snd))
|
|
[(i, c) | (i, c@(Possible _)) <- zip [0..] $ concat 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"
|
|
|
|
splitGrid =
|
|
let (i, first@(Fixed _), rest) = splitPossible smallestPossible
|
|
in (replace2D i first grid, replace2D i rest grid)
|
|
|
|
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
|
|
Nothing -> putStrLn "No solution found"
|
|
Just grid' -> putStrLn $ showGrid grid'
|