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
        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

--instance Read Pos where
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 && oldY`pm`1==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
        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
        (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
        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

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').

  • \$\begingroup\$ You'll need to summarize your suggestions and the reasons for them in your answer. \$\endgroup\$ – 200_success Apr 5 '16 at 7:03
  • \$\begingroup\$ 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? \$\endgroup\$ – Sean D Apr 5 '16 at 10:52
  • 2
    \$\begingroup\$ Oops, missed that n. zipWithM_ (\n move -> show n ++ ". " ++ agnMove move) [0..] moves \$\endgroup\$ – Gurkenglas Apr 5 '16 at 11:02

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.