Incomplete Sudoku Solver

Lib.hs

{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}

module Lib
  ( solve
  ) where

import           Control.Arrow                  ( (&&&) )
import           Data.Char                      ( isNumber )
import           Data.Foldable                  ( for_ )
import           Data.List                      ( intercalate )
import qualified Data.List.NonEmpty            as NE
import           Data.List.Split                ( chunksOf )
import qualified Data.Map.Strict               as M
import           Data.Maybe                     ( mapMaybe )
import qualified Data.Set                      as S

-- | Parse lines into a (sparse) point-indexed 'Map'
--
-- Examples:
--
-- >>> parseSparse2dGrid (\v -> if v == 'x' then Just () else Nothing) "x.\n.x"
-- fromList [((0,0),()),((1,1),())]
--
parseSparse2dGrid
  :: (Char -> Maybe a) -- ^ How to parse a cell
  -> String -- ^ Lines of text to parse
  -> M.Map (Int, Int) a
parseSparse2dGrid parseCell text = M.fromList $ do
  (y, line) <- zip [0 ..] $ lines text
  (x, cell) <- zip [0 ..] line
  maybe [] (pure . ((x, y), )) $ parseCell cell

-- | Parse lines into a point-indexed 'Map'
--
-- Examples:
--
-- >>> parse2dGrid (== 'x') "x.\n.x"
-- fromList [((0,0),True),((0,1),False),((1,0),False),((1,1),True)]
--
parse2dGrid
  :: (Char -> a) -- ^ How to parse a cell
  -> String -- ^ Lines of text to parse
  -> M.Map (Int, Int) a
parse2dGrid = parseSparse2dGrid . (.) Just

-- $setup
-- >>> import Data.Char (isAlpha, toUpper)
-- >>> import qualified Adlude.Grid as G

-- | Format (in terminal friendly-way) a grid of cells
--
-- Examples:
--
-- >>> putStrLn $ showGrid toUpper $ G.parseSparse2dGrid (\v -> if isAlpha v then Just v else Nothing) "a.b\nc.d\ne.."
-- A B
-- C D
-- E
--
showGrid :: (Enum a1, Ord a1) => (a2 -> Char) -> M.Map (a1, a1) a2 -> [Char]
showGrid showCell grid =
  let
    ks = M.keysSet grid
    xs = S.map fst ks
    ys = S.map snd ks
  in
    case
      sequence [S.lookupMin xs, S.lookupMax xs, S.lookupMin ys, S.lookupMax ys]
    of
      Just [x0, x1, y0, y1] ->
        intercalate "\n"
          $   (\y ->
                (\x -> maybe ' ' showCell $ M.lookup (x, y) grid) <$> [x0 .. x1]
              )
          <$> [y0 .. y1]
      _ -> ""

frequencies :: Ord a => [a] -> [(a, Int)]
frequencies = fmap (NE.head &&& length) . NE.groupAllWith id

data CellState
 = Resolved Int
 | Possible (S.Set Int)
 deriving (Show, Eq)

resolved = \case
  Resolved v -> Just v
  Possible _ -> Nothing

unsolvedPossibilities = \case
  Resolved _ -> Nothing
  Possible v -> Just $ S.toList v

containsUnsolvedPossibility cell v = case cell of
  Resolved _   -> False
  Possible pos -> v `S.member` pos

showCellState = \case
  Resolved v -> head $ show v
  Possible _ -> '_'

removePossible value = \case
  Resolved v   -> Resolved v
  Possible pos -> resolveSingleton $ Possible $ S.delete value pos

resolveSingleton = \case
  Resolved v                     -> Resolved v
  Possible pos | S.size pos == 1 -> Resolved $ S.findMin pos
  Possible pos                   -> Possible pos

allPossible = Possible $ S.fromList [1 .. 9]

parseGame =
  parse2dGrid (\c -> if isNumber c then Resolved (read [c]) else allPossible)

subgridLookup = M.fromList $ do
  subgrid <- subgrids
  cell    <- subgrid
  pure (cell, subgrid)

columns = column . (, 0) <$> [0 .. 8]
rows = row . (0, ) <$> [0 .. 8]
subgrids =
  fmap NE.toList $ NE.groupAllWith (\(x, y) -> (x `div` 3, y `div` 3)) $ do
    x <- [0 .. 8]
    y <- [0 .. 8]
    pure (x, y)

column (x, _) = (x, ) <$> [0 .. 8]
row (_, y) = (, y) <$> [0 .. 8]
subgrid = (subgridLookup M.!)

affectedBy pt = column pt <> row pt <> subgrid pt

removeByResolved game = foldr remove game toRemove
 where
  toRemove = concatMap (uncurry resolvedWithAffected) $ M.toList game

  resolvedWithAffected pt cell = case resolved cell of
    Nothing -> []
    Just v  -> (, v) <$> affectedBy pt

resolveByPossible game = foldr resolve game toResolve
 where
  toResolve :: [((Int, Int), Int)]
  toResolve = do
    span      <- subgrids <> columns <> rows
    singleton <-
      fmap fst $ filter ((== 1) . snd) $ frequencies $ concat $ mapMaybe
        (unsolvedPossibilities . (game M.!))
        span
    point <- filter ((`containsUnsolvedPossibility` singleton) . (game M.!))
                    span
    pure (point, singleton)

remove (pt, v) = M.adjust (removePossible v) pt

resolve (pt, v) = M.insert pt (Resolved v)

lineEliminate game = foldr remove game toRemove
 where
  toRemove :: [((Int, Int), Int)]
  toRemove = do
    subgrid            <- subgrids
    possibleValueSpots <-
      NE.groupAllWith fst
      $ concatMap (\(pt, unsolved) -> (, pt) <$> unsolved)
      $ mapMaybe (\pt -> (pt, ) <$> unsolvedPossibilities (game M.! pt)) subgrid
    (, fst $ NE.head possibleValueSpots) <$> if allSame fst possibleValueSpots
      then spanButPoints column possibleValueSpots
      else if allSame snd possibleValueSpots
        then spanButPoints row possibleValueSpots
        else []

  allSame dim vs@((_, pt) NE.:| _) = all (== dim pt) $ dim . snd <$> vs

  spanButPoints span points@((_, pt) NE.:| _) =
    filter (`notElem` fmap snd points) $ span pt

step =
  lineEliminate
    . untilSame removeByResolved
    . resolveByPossible
    . untilSame removeByResolved

untilSame f game | next == game = game
                 | otherwise    = untilSame f next
  where next = f game

{-
......1.2
.612...57
8......6.
7...8..3.
.9..4..7.
.3..6...4
.4......6
68...749.
3.2......
-}

solveAndPrint rawGame = do
  let unsolved = parseGame rawGame
  let end = untilSame step unsolved
      failedToSolve =
        filter (/= S.fromList (fmap Just [1 .. 9]))
          $  fmap (S.fromList . fmap (resolved . (end M.!)))
          $  rows
          <> columns
          <> subgrids

  putStrLn $ showGrid showCellState end

  for_ (NE.nonEmpty failedToSolve) $ \spans -> do
    putStrLn "Failed to solve:"
    for_ spans print

solve :: IO ()
solve = do
  unsolvedEulers <- fmap (\c -> if c == '0' then '.' else c)
    <$> readFile "./src/euler-puzzles.txt"

  let eulerRawGames =
        fmap unlines $ chunksOf 9 $ filter (\(v : _) -> v /= 'G') $ lines
          unsolvedEulers

  for_ eulerRawGames $ \v -> do
    solveAndPrint v
    putStrLn ""

  -- solveAndPrint =<< readFile "./src/game.txt"