Chess

import Data.List
import Control.Monad
import Data.Char

data Side = Black | White
        deriving (Show,Eq)

data Figure = Pawn | King | Queen | Rook | Knight | Bishop
        deriving (Eq,Ord)

data Fig = Fig {
        figure::Figure,
        pos::(Int,Int),
        side::Side
        }
        deriving Eq

instance Show Figure where
        show Pawn = "p"
        show Rook = "r"
        show King = "k"
        show Knight = "n"
        show Queen = "q"
        show Bishop = "b"

showFigLetter (Fig{figure=f, side=s}) =
        toL s (show f)
                where
                        toL White = map toUpper
                        toL Black = id

instance Show Fig where
        show o@(Fig{pos=(x,y)}) = showFigLetter o ++ show x ++ show y

data Cond = Capture | Free | Stay
        deriving (Show,Eq,Ord)

data Step = Step {
        spos :: (Int,Int),
        cond :: Cond,
        trans:: Figure
        }
        deriving (Show,Eq,Ord)

type Move = [Step]
data Board = Board [Fig] Side

instance Show Board where
        show (Board l s) = show s ++ "\n" ++ unlines (reverse table)
                where
                        table = do
                                i <- [1..8]
                                return $ do
                                        j <- [1..8]
                                        let l' = filter ((==(j,i)) . pos) l
                                        if null l'
                                                then "."
                                                else concatMap showFigLetter l'

chessPos (x,y) = toCh x : show y
        where
                toCh i = chr (i-1+(ord 'a'))

switchSide White = Black
switchSide Black = White

moveAndCapture (x,y) (dx,dy) n c tr =
        map f . map (reverse . map (\p -> Step{spos=p,cond=Free,trans=tr})) . filter (not . null) . inits $ l
                where
                        onTheBoard (x,y) = x `elem` [1..8] && y `elem` [1..8]
                        l = filter onTheBoard [(x+i*dx,y+i*dy) | i <- [1..n]]
                        f (o:os) = o{cond=c}:os

movesGen fig pred len = do
        dx <- [-2..2]
        dy <- [-2..2]
        guard . pred . sort . map abs $ [dx,dy]
        cond <- [Stay, Capture]
        tr <- [figure fig]
        moveAndCapture (pos fig) (dx,dy) len cond tr

moves fig@(Fig {figure=f, pos=p, side=s}) =
        case f of
                Rook    -> movesGen fig (==[0,1]) 8
                Bishop  -> movesGen fig (==[1,1]) 8
                Knight  -> movesGen fig (==[1,2]) 1
                Queen   -> movesGen fig (`elem` [[1,1],[0,1]]) 8
                King    -> movesGen fig (`elem` [[1,1],[0,1]]) 1
                Pawn    -> concatMap transCheck $
                        concat [moveAndCapture p (dx,dy) 1 Capture f | dx <- [-1,1]] ++
                        moveAndCapture p (0,dy) len Stay f
                                where
                                        transCheck l
                                                | any (mod . snd . spos) l = [ map (\st -> st{trans=fig}) l | fig <- [Queen, Knight]]
                                                | otherwise = [l]
                                        mod y
                                                | y==8 && s==White      = True
                                                | y==1 && s==Black      = True
                                                | otherwise                     = False
                                        y = snd p
                                        dy      | s==White                      = 1
                                                | otherwise                     = -1
                                        len     | s==White && y==2      = 2
                                                | s==Black && y==7      = 2
                                                | otherwise                     = 1

amIaLoser :: Side -> Board -> Bool
amIaLoser s (Board b _) =
        null . filter ((==s) . side) . filter ((==King) . figure) $ b

correctMove :: Board -> Fig -> Move -> Bool
correctMove (Board b _) f@Fig{side=s} m = all correct m
        where
                correct (Step p cond _)
                        | cond `elem` [Free,Stay]       = all ((/=p) . pos) b
                        | cond == Capture                       = any ((/=s) . side) . filter ((==p) . pos) $ b

makeMove :: Board -> Fig -> Move -> Board
makeMove (Board b s) f m = Board (f':b'') (switchSide s)
        where
                to = head . filter ((/=Free) . cond) $ m
                b' = delete f b
                b'' = filter ((/= spos to) . pos) b'
                f' = f{pos=spos to, figure=trans to}

dfs b 0 = []
dfs b@(Board figl s) d = do
        guard (not $ amIaLoser s b)
        fig <- figl
        guard (side fig == s)
        move <- moves fig
        guard (correctMove b fig move)
        let b' = makeMove b fig move
        let l = dfs b' (d-1)
        guard (null l)
        let move' = head . filter ((/=Free) . cond) $ move
        return (fig, move')

solve :: Board -> [String]
solve b@(Board _ s) = fu sol
        where
                sol = dfs b 4
                fu [] = ["I can't help you"]
                fu l = map (\(f,mv) -> showFigLetter f ++ chessPos (pos f) ++ "--" ++ showFigLetter f{figure=trans mv} ++ chessPos (spos mv)) l

readBoard :: String -> Board
readBoard s = Board (parse s 1 8) (brSide $ last s)
        where
                brSide 'w' = White
                brSide 'b' = Black
                fig 'p' = Pawn
                fig 'r' = Rook
                fig 'k' = King
                fig 'q' = Queen
                fig 'n' = Knight
                fig 'b' = Bishop
                sd c = if c == toUpper c then White else Black
                parse [] _ _ = []
                parse (c:cs) x y
                        | c == '/'              = parse cs 1 (y-1)
                        | x > 8                 = []
                        | isLetter c    = Fig{figure=fig (toLower c), pos=(x,y), side=sd c} : parse cs (x+1) y
                        | otherwise             = parse cs (x + read [c]) y

board1 = "4k3/8/4K3/8/8/8/R7/8 w"
board2 = "4k3/R7/8/8/8/3K4/8/7R w"
board3 = "6k1/5ppp/8/8/8/6P1/5PK1/R7 w"
board4 = "2rqk2N/1p3n2/4b2p/p5pQ/P2B4/8/1P3PPP/4R1K1 w"
board5 = "r3r1k1/pq3p2/R2Bp1p1/1pp1P111/6P1/1PP1b2b/1P3Q1N/R5K1 b" --140
board6 = "7k/pp4b1/3p3p/8/2PPP3/5bB1/5pBP/7K b" --148
board7 = "N1n5/1kPP4/8/8/4K3/8/Q7/8 w" -- 132

main' b = do
        let b' = readBoard b
        putStrLn $ show b'
        sequence_ . fmap putStrLn $ solve b'

main = do
        putStrLn $ "Set the board in the same manner " ++ show board1
        s <- getLine
        let b = readBoard s
        putStrLn $ show b
        sequence_ . fmap putStrLn $ solve b