solves easy sudokus

src/sudoku-hs/src/Main.hs

@@ -3,16 +3,18 @@
 module Main where
 
 import Data.Char (isSpace)
-import Data.List (transpose, dropWhileEnd)
-import Data.Maybe (isNothing, listToMaybe)
+import Data.List (transpose, minimumBy, delete, dropWhileEnd)
+import Data.Maybe (isNothing, listToMaybe, catMaybes)
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.Vector as V
 import qualified Data.Csv as CSV
 import System.Environment (getArgs)
 import Text.Read (readMaybe)
+import Data.Ord (comparing)
 
 type Cell = Maybe Int
 type Grid = [[Cell]]
+type Pos = (Int, Int)
 
 parseCell :: String -> Cell
 parseCell s = readMaybe (trim s)
@@ -31,30 +33,30 @@ printGrid = putStrLn . unlines . map (unwords . map showCell)
   where showCell = maybe "." show
 
 solve :: Grid -> Maybe Grid
-solve grid = solve' grid
-
-solve' :: Grid -> Maybe Grid
-solve' g = case findEmpty g of
+solve g = case nextCell g of
   Nothing -> Just g
-  Just (r, c) ->
-    listToMaybe [ g'
-                | n <- [1..9]
-                , isSafe g r c n
+  Just (r, c, opts) ->
+    listToMaybe
+      [ result
+      | n <- opts
       , let g' = updateGrid g r c (Just n)
-                , Just _ <- [solve' g'] ]
+      , Just result <- [solve g'] ]
 
-findEmpty :: Grid -> Maybe (Int, Int)
-findEmpty g = listToMaybe
-  [ (r, c)
+nextCell :: Grid -> Maybe (Int, Int, [Int])
+nextCell g =
+  case filter (not . null . (\(_, _, opts) -> opts)) candidates of
+    [] -> Nothing
+    cs -> Just $ minimumBy (comparing (\(_, _, opts) -> length opts)) cs
+  where
+    candidates =
+      [ (r, c, validOptions g r c)
       | (r, row) <- zip [0..] g
       , (c, cell) <- zip [0..] row
       , isNothing cell ]
 
-isSafe :: Grid -> Int -> Int -> Int -> Bool
-isSafe g r c n =
-  notElem (Just n) (getRow r g) &&
-  notElem (Just n) (getCol c g) &&
-  notElem (Just n) (getBox r c g)
+validOptions :: Grid -> Int -> Int -> [Int]
+validOptions g r c =
+  foldr delete [1..9] (catMaybes (getRow r g ++ getCol c g ++ getBox r c g))
 
 getRow :: Int -> Grid -> [Cell]
 getRow r g = g !! r
@@ -65,10 +67,10 @@ getCol c g = map (!! c) g
 getBox :: Int -> Int -> Grid -> [Cell]
 getBox r c g =
   [ g !! r' !! c'
-  | r' <- brange, c' <- crange ]
+  | r' <- [br..br+2], c' <- [bc..bc+2] ]
   where
-    brange = let b = r - r `mod` 3 in [b..b+2]
-    crange = let b = c - c `mod` 3 in [b..b+2]
+    br = r - r `mod` 3
+    bc = c - c `mod` 3
 
 updateGrid :: Grid -> Int -> Int -> Cell -> Grid
 updateGrid g r c val =