{- Example: *Main> main 8_______1 _3_876_9_ _9_____6_ __31_82__ _6_____5_ __85_94__ _4_____8_ _8_953_4_ 9_______3 Solutions: 876495321 132876594 594231867 453168279 269347158 718529436 347612985 681953742 925784613 -} import Data.Char import Control.Monad.State import qualified Data.IntSet as S import Data.Array.Diff import Data.List import Data.Maybe type Move = ((Int, Int), Int) type Box = (S.IntSet, Maybe Int) type Game = DiffArray (Int, Int) Box type GameState = StateT Game Maybe -- Initial game state initial :: Game initial = listArray ((0, 0), (8, 8)) \$ repeat (S.fromList [1 .. 9], Nothing) -- Apply move to game state doMove :: Move -> GameState () doMove (at@(x, y), z) = do game <- get let block z (s, b) = (S.delete z s, b) let updates = [ (i, block z (game ! i)) | a <- [0 .. 8], a /= x, let i = (a, y) ] ++ [ (i, block z (game ! i)) | a <- [0 .. 8], a /= y, let i = (x, a) ] ++ [ (i, block z (game ! i)) | a <- [3 * (x `div` 3) .. 2 + 3 * (x `div` 3)], b <- [3 * (y `div` 3) .. 2 + 3 * (y `div` 3)], (a, b) /= at, let i = (a, b) ] ++ [ (at, (S.empty, Just z)) ] if any ((==) (S.empty, Nothing)) \$ map snd updates then lift Nothing else do let game' = game // updates if S.member z (fst \$ game ! at) then put game' else lift Nothing -- invalid move -- Apply sequence of moves to game state doMoves :: [Move] -> GameState () doMoves = mapM_ doMove -- Determine all available moves, grouped by position availableMoves :: GameState [[Move]] availableMoves = do state <- gets assocs return \$ filter (not . null) \$ map availableMoves' state where availableMoves' (at, (s, _)) = [ (at, z) | z <- S.elems s ] -- Partition available move list into forced and unforced partitionMoves :: [[Move]] -> ([Move], [Move]) partitionMoves moves = (concat singles, unforced) where (singles, rest) = span (\l -> length l <= 1) moves unforced = if null rest then [] else head \$ sortBy lengths rest where lengths a b = compare (length a) (length b) -- Attempt to apply move, and return all possible solutions try :: Move -> GameState [Game] try move = do game <- get case (evalStateT (do { doMove move; runGame }) game) of Nothing -> return [] Just sol -> return sol -- Attempt to apply each move in turn, and return all possible solutions tryAll :: [Move] -> GameState [Game] tryAll moves = liftM concat \$ mapM try moves -- Solve game, by recursively: -- - doing all forced moves -- - choosing the least contended box -- - trying each move in that box runGame :: GameState [Game] runGame = do game <- get available <- availableMoves let (forced, unforced) = partitionMoves available if null forced then if null unforced then return [game] else tryAll unforced else doMoves forced >> runGame -- Print a game out output :: Game -> IO () output game = do putStrLn "" sequence_ [ putStrLn [ toChar \$ snd \$ game ! (x, y) | x <- [0 .. 8] ] | y <- [0 .. 8] ] where toChar Nothing = '?' toChar (Just x) = intToDigit x -- Parse an input specification into a list of moves parseMoves :: [String] -> [Move] parseMoves spec = concat \$ map mapRows (zip [0..] spec) where mapRows (y, row) = catMaybes \$ map (mapCols y) (zip [0..] row) mapCols y (x, z) | isDigit z = Just ((x, y), digitToInt z) | otherwise = Nothing -- Given an input specification, solve the game solve :: [String] -> IO () solve spec = do let result = evalStateT (do { doMoves \$ parseMoves spec; runGame; }) initial case result of Nothing -> putStrLn "Inconsistent input" Just [] -> putStrLn "No solutions" Just a -> do putStrLn "Solutions:" sequence_ \$ map output a -- Given 9 lines of input, solve the game main :: IO () main = do lines <- sequence \$ replicate 9 getLine putStrLn "" if all (\l -> length l == 9) lines then solve lines else putStrLn "Invalid input"