Just for fun I tried to write a chess game in Haskell, in the hope that it would eventually be good enough to beat me. It's not perfect at the rules (it doesn't know about promotion, castling or en-passant yet) but it does manage to make legal moves, and they're not always totally stupid. I've tried to make the code neat and short, but I think it could probably be a lot nicer, and I have the feeling that there are lots of nice patterns I haven't recognised.

I'd love any feedback on style or any nicer ways to write what I've written, along with any suggestions on how to elegantly implement special rules.

Finally I realise the recursive search strategy is dog-slow and should have some more sensible method of pruning. I'd also like to hear thoughts on this.

import Data.Char
import Data.Array
import Data.Maybe
import Data.List
import Data.Ord

type Pos = (Int, Int)
data PieceType = P | N | B | R | Q | K deriving (Show, Read, Eq, Ord)
data Side = Black | White deriving (Eq, Show)
data Piece = Piece {side :: Side, ptype :: PieceType, pos :: Pos} deriving Show
type Board = Array Pos (Maybe Piece)
type Move = (Piece, Pos)

main = do
putStrLn "Let's play a game"
humanMove White startBoard

humanMove s b = do
printBoard b
putStrLn $show s ++ " to move." let moves = getMoves b s mapM_ putStrLn [show n++". "++ agnMove (moves !! n) |n<-[0..length moves-1]] moveNumber <- getLine let newBoard = (uncurry$ move b) (moves !! read moveNumber)
aiMove (other s) newBoard

aiMove s b = do
putStrLn $"\n Computer plays " ++ agnMove bestMove ++ ".\n" humanMove (other s)$ uncurry (move b) bestMove
where
bestMove = bestMoveBy evaluateBoard s b

setup :: [Piece]
setup =
[Piece Black P (x,2)|x<-[1..8]] ++
[Piece White P (x,7)|x<-[1..8]] ++
zipWith (Piece Black) (map (\l->read[l]) "RNBKQBNR") [(i,1)|i<-[1..8]] ++
zipWith (Piece White) (map (\l->read[l]) "RNBQKBNR") [(i,8)|i<-[1..8]]

startBoard = boardUpdate blankBoard setup

readPos [file,rank] = (ord file - 96, digitToInt rank)

--instance Show Pos where
showPos ((x,y)) = [chr (x+96), intToDigit y]

agnMove (Piece _ t _, pos) = (if t==P then "" else show t) ++ showPos pos

-- need to add special moves
legal :: Board -> Piece -> Pos -> Bool
legal board piece@(Piece s t (oldX,oldY)) newPos@(newX,newY)
=
inBounds newX && inBounds newY -- don't go out of bounds
&&
dX+dY/=0 -- no non-moves!
&&
case t of -- gotta move according to the rules
P -> dX==0 && oldYpm1==newY
N -> (dX, dY) elem[(1,2),(2,1)]
B -> dX==dY
R -> dX==0 || dY==0
Q -> any (\t'-> legal board (swap piece t') newPos) [B,R]
K -> not (dX>1 || dY>1)
&&
(null inbetweens -- can't pass through other pieces
|| (((pos firstHit == newPos) --unless killing
|| t == N) && -- or a knight
hitEnemy)) --and you have to kill the other team
where
pm = case s of Black->(+); White->(-)
inBounds x =  x>0 && x<9
dX = abs $oldX-newX dY = abs$ oldY-newY
inbetweens = catMaybes $tail [board!(x,y) |x<-between oldX newX,y<-between oldY newY] between a b = case compare a b of LT -> [a..b] GT -> reverse [b..a] EQ -> [a] firstHit = head inbetweens hitEnemy = case board!newPos of Nothing -> otherwise Just victim -> side victim /= s move :: Board -> Piece -> Pos -> Board move board piece to = if legal board piece to then board//[ (pos piece,Nothing), (to, Just$ piece {pos=to})]
else error "Illegal Move Bro!"

getPieces :: Board -> [Piece]
getPieces = catMaybes.elems

swap :: Piece->PieceType->Piece
swap (Piece s t p) t' = Piece s t' p

wholeBoard = [(x,y) | x<-[1..8], y<-[1..8]]

possibleMoves board piece = filter (legal board piece) wholeBoard

blankBoard :: Board
blankBoard = listArray ((1,1),(8,8)) $repeat Nothing boardUpdate :: Board -> [Piece] -> Board boardUpdate board update = board//[(pos piece, Just piece) | piece<-update] -- instance Show Board where showBoard :: Board -> [String] showBoard ps = [[case ps!(y,x) of Just p -> icon p Nothing -> '.' | y<-[1..8]]| x<-[1..8]] printBoard b = do putStrLn$ ' ':['a'..'h']
mapM_ putStrLn $zipWith (:) ['8','7'..]$showBoard b

icon (Piece s t _) =
case s of
Black -> fst
White -> snd
$case t of P -> ('♙','♟') N -> ('♘','♞') B -> ('♗','♝') R -> ('♖','♜') Q -> ('♕','♛') K -> ('♔','♚') justMove b = map (\p ->move b p (head$ possibleMoves b p))
$getPieces b getMoves b s = concatMap (\x-> zip (repeat x)$ possibleMoves b x) $getSide b s getSide b s = filter (\x-> side x == s)$ getPieces b

nextBoards b s = map (uncurry $move b)$ getMoves b s

-- the hard part

type Evaluator = Side -> Board -> Int

bestMoveBy :: Evaluator -> Side -> Board -> Move
bestMoveBy eval s b = maximumBy (comparing $eval s . uncurry (move b))$ getMoves b s

evaluateBoard :: Evaluator
evaluateBoard = evalRecursive 2 -- any more than three takes forever

evalSimple s b = fromIntegral . length $getSide b s evalMaterial s b = sum . map (\(Piece s1 t _)->sign s s1 * value t)$
getPieces b
where
sign me it = if it==me then 1 else (-1)

evalRecursive 0 s b = evalMaterial s b
evalRecursive n s b =
evalRecursive (n-1) s $uncurry (move b)$
bestMoveBy (evalRecursive $n-1) s b -- Misc other White = Black other Black = White value :: PieceType -> Int value t = case t of P -> 1 N -> 3 B -> 3 R -> 5 Q -> 9 K -> 1000  ## 1 Answer Here's a GitHub repo where I made commits with incremental changes to your code so you can better view it via .diffs. (Editwar: I'll leave that comment about the rule about me having to copy these explanations into here being stupid in here, thank you.) ## Tighten recursion Recursion is hard to understand. Let's concentrate it into as little space as possible so we can use our high-power brain on few lines of code, and our low-power brain on the rest. - humanMove White startBoard + iterateM_ (humanMove White >=> aiMove Black) startBoard  ## Banishing the possibility of Show Pos You are right, that instance does not belong there. Show and Read are for converting to and from strings that you can paste into code to recover the same value. Pretty-printing is to be done in other ways. (I realize you probably only didnt do it via Show and Read because (Int, Int) already has an instance for that). - --instance Read Pos where - --instance Show Pos where  ## One-line refactor (!!) is usually a code smell, as seen here. - mapM_ putStrLn [show n++". "++ agnMove (moves !! n) |n<-[0..length moves-1]] + mapM_ putStrLn [show n++". "++ agnMove move | move <- moves]  ## Tighten another recursion, notice fail evalPredictive takes an evaluator and lifts it by a one-turn prediction. This is semantically identical to what you did. + evaluateBoard = iterate evalPredictive evalMaterial !! 2 -- any more than three takes forever + evalPredictive e s b = e s$ uncurry (move b) \$ bestMoveBy e s b


Now for the fail: You presumably are trying to implement Minmax. If you've never heard that word, and are inventing a way to automate chessplaying from scratch, and want to think of the interesting parts yourself, don't read on.

You predict the game as if both players are playing maximally in your favor, cooperating to get the board as good in the eyes of the AI side's evaluator as possible. Minmax says that the other player is trying to maximize his own score, and so you should run the evaluator as if the AI was playing the other side, meaning that you should replace the first 's' in evalPredictive's definition by (other 's').

• You'll need to summarize your suggestions and the reasons for them in your answer. – 200_success Apr 5 '16 at 7:03
• Thanks for all your helpful comments. I'm still trying to wrap my head around the first and last ones. It does seem like "One-line refactor" doesn't work, as you need n, so that the player can choose the move. Do you see a way around this? – Sean D Apr 5 '16 at 10:52
• Oops, missed that n. zipWithM_ (\n move -> show n ++ ". " ++ agnMove move) [0..] moves – Gurkenglas Apr 5 '16 at 11:02