{-

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"