Implements grid pruning and solve

src/Sudoku.hs

@@ -1,6 +1,9 @@
 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
 
@@ -8,10 +11,6 @@ data Cell = Fixed Int | Possible [Int] deriving (Show, Eq)
 type Row  = [Cell]
 type Grid = [Row]
 
-possibleVals :: Cell -> [Int]
-possibleVals (Fixed x)     = [x]
-possibleVals (Possible xs) = xs
-
 readGrid :: String -> Maybe Grid
 readGrid s
   | length s == 81 =
@@ -38,5 +37,81 @@ showGridWithPossibilities = unlines . map (unwords . map showCell)
       . Data.List.foldl' (\acc x -> acc ++ if x `elem` xs then show x else " ") "["
       $ [1..9]
 
+pruneCells :: [Cell] -> Maybe [Cell]
+pruneCells cells = sequence . map 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
 
-main = undefined
+blocksToRows :: Grid -> Grid
+blocksToRows =
+  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 = fixM pruneGrid'
+
+pruneGrid' grid =
+  sequence (map pruneCells grid)
+  >>= fmap Data.List.transpose . sequence . map pruneCells . Data.List.transpose
+  >>= fmap blocksToRows . sequence . map pruneCells . blocksToRows
+
+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 (blocksToRows 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 =
+          head
+          . Data.List.sortBy (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'