# Chess

We use a spurious traceShow to work around a Haste bug.

{-# LANGUAGE CPP #-}
import Data.Array
import Data.IORef
import Data.List
import Data.Maybe
import Data.Tree
#ifdef __HASTE__
import Haste
import Haste.DOM
import Haste.Events
import Haste.Graphics.Canvas
import System.Random
import Debug.Trace
#endif

bnds = ((0,0), (7,7)); sz = 40

onBoard = inRange bnds

data Piece = Pawn | Knight | Bishop | Rook | Queen | King deriving (Eq, Show)
data Side = White | Black deriving (Eq, Show)
data Square = Square Side Piece deriving (Eq, Show)
data Event = EKeyDown Int | EClick Int Int
data State = Draw | Won | Play deriving Eq
data Game = Game { board :: Array (Int, Int) (Maybe Square)
, state :: State
, player :: Side
, selection :: Maybe (Int, Int)
, anim :: Maybe (Int, ((Int, Int), (Int, Int)))
, canCastle :: [(Int, Int)]
, enPassant :: Maybe (Side, (Int, Int))
, lastMove :: ((Int, Int), (Int, Int))
, promoChoice :: Piece -- TODO: Should be part of move.
}

side (Just (Square s _)) = s

piece (Just (Square _ p)) = p

initBoard = let
order = [Rook, Knight, Bishop, Queen, King, Bishop, Knight, Rook]
f (_, 1) = Just $Square Black Pawn f (x, 0) = Just$ Square Black $order!!x f (_, 6) = Just$ Square White Pawn
f (x, 7) = Just $Square White$ order!!x
f _ = Nothing
in array bnds [(i, f i) | i <- range bnds]

initGame = Game initBoard Play White Nothing Nothing [(x,y) | x <- [0,4,7], y <- [0,7]] Nothing undefined Queen

worth Pawn   = 100
worth Knight = 300
worth Bishop = 350
worth Rook   = 500
worth Queen  = 900
worth King   = 0

toPiece "Knight" = Knight
toPiece "Bishop" = Bishop
toPiece "Rook"   = Rook
toPiece _        = Queen

score game
| state game == Won  = if player game == Black then 2^16 else -2^16
| state game == Draw = 0
| otherwise          = let b = board game in sum [(if side (b!i) == White then -1 else 1) * worth (piece (b!i)) | i <- range bnds, b!i /= Nothing]

omitWith op ((g, ns):nss) = let
omit pot [] = []
omit pot ((g, ns):nss) | or $map (op pot) ns = omit pot nss | otherwise = (g, last ns) : omit (last ns) nss in (g, last ns) : omit (last ns) nss maximize' :: Tree Game -> [(Game, Int)] maximize' (Node leaf []) = [(undefined, score leaf)] maximize' (Node g kids) = omitWith (<=)$
[(rootLabel k, map snd $minimize' k) | k <- kids] maximize = last . maximize' minimize' :: Tree Game -> [(Game, Int)] minimize' (Node leaf []) = [(undefined, score leaf)] minimize' (Node g kids) = omitWith (>=)$
[(rootLabel k, map snd $maximize' k) | k <- kids] best game ms = lastMove$ fst $maximize$ prune 3 $Node game (map (gameTree . move game) ms) gameTree = unfoldTree (\x -> (x, nextNodes x)) nextNodes game = if state game == Play then [move game m | m <- legalMoves game] else [] prune 0 (Node a _) = Node a [] prune n (Node a kids) = Node a$ map (prune (n - 1)) kids

nextPlayer White = Black
nextPlayer Black = White

dirPlayer White = -1
dirPlayer Black = 1

-- All moves except castling.
#ifdef __HASTE__
movesFrom i@(x, y) game = traceShow 0 $case piece (b!i) of #else movesFrom i@(x, y) game = case piece (b!i) of #endif Pawn -> let i1 = (x, y + dirPlayer p) in (if blank i1 then i1 : (let i2 = (x, y + 2 * dirPlayer p) in if pawnStart && blank i2 then [i2] else []) else []) ++ [j | dx <- [-1, 1], let j = (x + dx, y + dirPlayer p), cap j || (ep /= Nothing && let Just (es, ej) = ep in j == ej && es /= p)] Knight -> [i1 | a <- [-1, 1], b <- [-1, 1], (dx, dy) <- [(2*a, b), (a, 2*b)], let i1 = (x+dx, y+dy), blankCap i1] Bishop -> concat [scan dx dy | dx <- [-1, 1], dy <- [-1, 1]] Rook -> concat [scan dx dy | a <- [-1, 1], (dx, dy) <- [(a, 0), (0, a)]] Queen -> concat [scan dx dy | dx <- [-1..1], dy <- [-1..1]] King -> [i1 | dx <- [-1..1], dy <- [-1..1], let i1 = (x+dx, y+dy), blankCap i1] where b = board game ep = enPassant game p = side (b!i) cap j = onBoard j && b!j /= Nothing && side (b!j) /= p blank j = onBoard j && b!j == Nothing blankCap j = onBoard j && (b!j == Nothing || side (b!j) /= p) pawnStart = (p == White && y == 6) || (p == Black && y == 1) scan dx dy = unfoldr (\(x', y', cont) -> if cont && blankCap (x + x', y + y') then Just ((x + x', y + y'), (x' + dx, y' + dy, blank (x + x', y + y'))) else Nothing) (dx, dy, True) isCheck p game = let b = board game k = head [i | i <- range bnds, (b!i) == Just (Square p King)] in or [k elem movesFrom i game | i <- range bnds, (b!i) /= Nothing, side (b!i) /= p] legalMovesFrom i@(x, y) game = let b = board game cc = canCastle game p = player game in (filter (\m -> not . isCheck p$ movePrecheck game (i, m)) $movesFrom i game) ++ if i elem cc && x == 4 then (if (0, y) elem cc && and [b!(x1, y) == Nothing | x1 <- [1..3]] && and [not$ isCheck p $movePrecheck game (i, (x1, y)) | x1 <- [2, 3]] then [(2, y)] else []) ++ (if (7, y) elem cc && and [b!(x1, y) == Nothing | x1 <- [5, 6]] && and [not$ isCheck p $movePrecheck game (i, (x1, y)) | x1 <- [5, 6]] then [(6, y)] else []) else [] legalMoves game = let b = board game in [(i, m) | i <- range bnds, b!i /= Nothing, side (b!i) == (player game), m <- legalMovesFrom i game] movePrecheck game m@(i0@(x0, y0), i1@(x1, y1)) = let b = board game p = player game ep = enPassant game promoCheck a@((x, y), Just (Square s Pawn)) = if (s == Black && y == 7) || (s == White && y == 0) then ((x, y), Just (Square s (if s == Black then Queen else promoChoice game))) else a promoCheck a = a castleCheck xs = if piece (b!i0) == King then if x0 - x1 == 2 then ((0, y0), Nothing) : ((3, y0), b!(0, y0)) : xs else if x0 - x1 == -2 then ((7, y0), Nothing) : ((5, y0), b!(7, y0)) : xs else xs else if piece (b!i0) == Pawn && ep /= Nothing && i1 == snd (fromJust$ enPassant game) then
((x1, y1 - dirPlayer p), Nothing) : xs
else xs
in game { board = b // castleCheck [(i0, Nothing), promoCheck (i1, b!i0)]
, state = Play
, player = nextPlayer p
, canCastle = delete i0 (canCastle game)
, enPassant = if piece (b!i0) == Pawn && y0 + dirPlayer p /= y1 then
Just (p, (x0, y0 + dirPlayer p))
else Nothing
, lastMove = m
}

move game m = let game1 = movePrecheck game m in
if legalMoves game1 == [] then
game1 { state = if isCheck (player game1) game1 then Won else Draw
, player = player game }
else
game1

#ifdef __HASTE__
box :: Int -> Int -> Int -> Int -> Picture ()
box x y dx dy = fill $rect (fromIntegral x, fromIntegral y) (fromIntegral (x+dx), fromIntegral (y+dy)) sqColor False = RGB 191 191 191 sqColor True = RGB 255 255 255 drawB pic x y = draw pic (fromIntegral x, fromIntegral y) sym White King = "\x2654" sym White Queen = "\x2655" sym White Rook = "\x2656" sym White Bishop = "\x2657" sym White Knight = "\x2658" sym White Pawn = "\x2659" sym Black King = "\x265a" sym Black Queen = "\x265b" sym Black Rook = "\x265c" sym Black Bishop = "\x265d" sym Black Knight = "\x265e" sym Black Pawn = "\x265f" main = withElems ["canvas", "message", "promo"]$ \[canvasE, msg, promoSel] -> do
Just canvas <- fromElem canvasE
whitePiece <- createCanvas sz sz
renderOnTop whitePiece $color (RGB 255 255 255)$ fill $circle (20, 20) 10 renderOnTop whitePiece$ color (RGB 0 0 0) $stroke$ circle (20, 20) 11
blackPiece <- createCanvas sz sz
renderOnTop blackPiece $color (RGB 0 0 0)$ fill $circle (20, 20) 11 fromCan <- createCanvas sz sz render fromCan$ color (RGB 127 15 15) $sequence_ [ box 0 0 5 40, box 0 0 40 5, box 35 0 40 40, box 0 35 40 40 ] toCan <- createCanvas sz sz render toCan$ color (RGBA 0 191 0 0.3) $box 0 0 sz sz boardCan <- createCanvas 320 320 sequence_$ [renderOnTop boardCan $color (sqColor (mod (x + y) 2 == 0))$ box (x*sz) (y*sz) sz sz | (x, y) <- range bnds]
buf <- createCanvas 320 320

ref <- newIORef undefined

let
shuffleIO [] = return []
shuffleIO xs = getStdRandom (randomR (0, length xs - 1)) >>= \n ->
let (a, b:bs) = splitAt n xs in (b:) <$> shuffleIO (a ++ bs) renderPiece c sq (x,y) = renderOnTop c$ font "40px sans-serif" $text (fromIntegral x + 2, fromIntegral y + 35) (sym (side sq) (piece sq)) drawGame game = let b = board game in do sequence_$ (render buf $draw boardCan (0, 0)) : [renderPiece buf sq (x*sz, y*sz) | i@(x, y) <- range bnds, let sq = b!i, sq /= Nothing] render canvas$ draw buf (0, 0)
setProp msg "innerHTML" $show (player game) ++ case state game of Play -> " to move" Won -> " wins" Draw -> " draws" let loop g = drawGame g >> writeIORef ref g newGame = loop initGame newGame let animate game = let b = board game in case anim game of Just (frame, m@(from@(x0, y0), (x1, y1))) -> if frame == 8 then let game1 = move game m in do drawGame game1 -- Delay so canvas has a chance to update. if state game1 == Play && player game1 == Black then void$ setTimer (Once 20) $do ms <- shuffleIO$ legalMoves game1
animate game1 { anim = Just (0, best game1 ms) }
else
loop game1 { anim = Nothing }

else do
let f x0 x1 frame = x0 * sz + (x1 - x0) * sz * frame div 8
drawGame game { board = b // [(from, Nothing)] }
renderPiece canvas (b!from) (f x0 x1 frame, f y0 y1 frame)
void $setTimer (Once 20)$ animate game { anim = Just (frame + 1, m) }

canvasE  onEvent MouseDown $\(MouseData (bx, by) _ _) -> do game <- readIORef ref when (state game == Play && player game == White && anim game == Nothing)$ do
let
b = board game
i@(x, y) = (div bx sz, div by sz)
sel = if b!i /= Nothing && side (b!i) == player game then Just i else Nothing
when (inRange bnds i) $do render canvas$ draw buf (0, 0)
case selection game of
Nothing -> do
unless (sel == Nothing) $do renderOnTop canvas$ drawB fromCan (x*sz) (y*sz)
sequence_ [renderOnTop canvas $drawB toCan (x1*sz) (y1*sz) | (x1, y1) <- legalMovesFrom i game] writeIORef ref game { selection = sel } Just sel0 | i elem legalMovesFrom sel0 game -> do s <- getProp promoSel "value" animate game { selection = Nothing, anim = Just (0, (sel0, i)), promoChoice = toPiece s } _ -> loop game { selection = Nothing } documentBody onEvent KeyDown$ \k -> when (k == 113) newGame
#endif

Ben Lynn blynn@cs.stanford.edu 💡