import List
import Monad

-- The game monad
newtype Game s a = Game (s -> Maybe (s, a))

instance Monad (Game a) where
       return a        = Game (\s -> Just (s, a))
       (Game g) >>= f  = Game (\s0 -> case (g s0) of
                                       Nothing -> Nothing
                                       Just (s1, a) -> let (Game h) = f a in h s1)

failGame = Game (\_ -> Nothing)

instance MonadPlus (Game a) where
       mzero = failGame
       (Game p) `mplus` (Game q)  =  Game( \s0 -> case p s0 of
                                               Just (s1, a) -> Just (s1, a)
                                               Nothing -> q s0 )

playGame :: Game a b -> a -> Maybe (a, b)
playGame (Game g) = g

-- Basic types
type SudokuState = [[Int]]
type SudokuGame a = Game SudokuState a
type Position = (Int, Int)
type CellPosition = (Int, Int)
type CandidateList = [Int]
type EmptySquare = (Position, CandidateList)
type Move = (Position, Int)

-- Ranges
allRows :: [Int]
allRows = [0..8]

allCols :: [Int]
allCols = [0..8]

allCells :: [Int]

allCells = [0..2]

allPositions :: [Position]
allPositions = [(x, y) | x <- allCols, y <- allRows]

allCellPositions :: [CellPosition]
allCellPositions = [(x, y) | x <- allCells, y <- allCells]

allPositionsInCell :: CellPosition -> [Position]
allPositionsInCell (cx, cy) =
       let     xi = cx * 3
               yi = cy * 3 in
       [(x, y) | x <- [xi..xi+2], y <- [yi..yi+2]]

-- Accessors
getRows :: SudokuGame [[Int]]
getRows = Game (\state -> Just (state, state))

getRow :: Int -> SudokuGame [Int]
getRow x = do
	rows <- getRows
	return (rows !! x)

getCols :: SudokuGame [[Int]]
getCols = mapM getCol allCols

getCol :: Int -> SudokuGame [Int]
getCol y = do
	rows <- getRows
	return [row !! y | row <- rows]

getCells :: SudokuGame [[Int]]
getCells = mapM getCell allCellPositions

getCell :: CellPosition -> SudokuGame [Int]
getCell cpos = mapM getValueAt (allPositionsInCell cpos)

getValueAt :: Position -> SudokuGame Int
getValueAt (x, y) = do
	rows <- getRows
	return ((rows !! y) !! x)

-- Constructors
startGame :: [[Int]]
startGame = [[0 | x <- [0..8]] | y <-[0..8]]

-- Mutators
putRows :: [[Int]] -> SudokuGame ()
putRows rows = Game (\_ -> Just (rows, ()))

move :: Move -> SudokuGame ()
move m = do
	rows <- getRows
	putRows (updateRows rows m 0) where
		updateRows [] m y = []
		updateRows (r:rs) m y = (updateCols r m 0 y) : (updateRows rs m (y + 1))
		updateCols [] m x y = []
		updateCols (c:cs) m x y = (updateCol c m x y) : (updateCols cs m (x+1) y)
		updateCol v2 m@((x1, y1), v1) x2 y2 = if (x1, y1)==(x2, y2) then v1 else v2

update :: [Move] -> SudokuGame ()
update = mapM_ move

-- Analysis
valuesNotIn :: [Int] -> [Int]
valuesNotIn vs = [1..9] \\ vs

containingCell :: Position -> CellPosition
containingCell (x, y) = (x `div` 3, y `div` 3)

isEmpty :: Position -> SudokuGame Bool
isEmpty p = (==0) `liftM` (getValueAt p)

getEmptyPositions :: SudokuGame [Position]
getEmptyPositions = filterM isEmpty allPositions

getEmptySquares :: SudokuGame [EmptySquare]
getEmptySquares = do
	emptyPositions <- getEmptyPositions
	mapM (\pos -> do cs <- getCandidatesFor pos; return (pos, cs)) emptyPositions

getCandidatesFor :: Position -> SudokuGame [Int]
getCandidatesFor pos@(x, y) = do
	row <- getRow y
	col <- getCol x
	cell <- getCell (containingCell pos)
	return ((valuesNotIn row) `intersect` (valuesNotIn col) `intersect` (valuesNotIn cell))

atom [] = False
atom (c:cs) = null cs

getForcedMoves :: SudokuGame [Move]
getForcedMoves = do
	emptySquares <- getEmptySquares
	let forcedSquares = filter (\(pos, cs) -> atom cs) emptySquares
	return [(pos, v) | (pos, (v:_)) <- forcedSquares]

doForcedMoves :: SudokuGame ()
doForcedMoves = do
	forcedMoves <- getForcedMoves
	if null forcedMoves
		then return ()
		else update forcedMoves >> doForcedMoves

isValid :: SudokuGame Bool
isValid = do
	rows <- getRows
	cols <- getCols
	cells <- getCells
	return ((allValid rows) && (allValid cols) && (allValid cells))

allValid = foldr (\x b -> b && (valuesValid x)) True

valuesValid [] = True
valuesValid (v:vs) = (if v/=0 then (not (v `elem` vs)) else True) && (valuesValid vs)

getAnalysis :: SudokuGame [Move]
getAnalysis = do
	emptySquares <- getEmptySquares
	let blocked = filter (\(_, cs) -> null cs) emptySquares
	if null emptySquares
		then return []
		else if not (null blocked)
			then failGame
			else return (tryNext emptySquares)

tryNext :: [EmptySquare] -> [Move]
tryNext es =
       let	(e:_) = sortBy (\(_, cs1) (_, cs2) -> compare (length cs1) (length cs2)) es
		(pos, cs) = e in
		[(pos, c) | c <- cs]

solve :: SudokuGame ()
solve = do
	doForcedMoves
	valid <- isValid
	if valid
		then do	moves <- getAnalysis
			if not (null moves)
				then tryAllMoves moves
				else return ()
		else failGame

tryAllMoves :: [Move] -> SudokuGame ()
tryAllMoves moves = msum [move m >> solve | m <- moves]

-- Test data (a real Su Doku puzzle, rated Fiendish)
testGame :: [Move]
testGame =
       [((0, 0), 7), ((3, 0), 1), ((8, 0), 2),
       ((5, 1), 6), ((7, 1), 8),
       ((3, 2), 8), ((6, 2), 1), ((8, 2), 9),
       ((2, 3), 7), ((5, 3), 9), ((7, 3), 1),
       ((1, 4), 9), ((2, 4), 3), ((6, 4), 5), ((7, 4), 4),
       ((1, 5), 6), ((3, 5), 4), ((6, 5), 9),
       ((0, 6), 3), ((2, 6), 8), ((5, 6), 4),
       ((1, 7), 4), ((3, 7), 3),
       ((0, 8), 1), ((5, 8), 5), ((8, 8), 3)]

-- Instrumentation
play :: [Move] -> SudokuGame ()
play ms = update ms >> solve

prettyPrint :: [[Int]] -> IO ()
prettyPrint rows = mapM_ prettyPrintRow rows >> putStr "\n"

prettyPrintRow r = mapM_ prettyPrintPos r >> putStr "\n"

prettyPrintPos 0 = putStr "."
prettyPrintPos p = putStr (show p)

main =
	case (playGame (play testGame) startGame) of
		Nothing -> putStrLn "Failed"
		Just (rows, _) -> prettyPrint rows