Chess

Promote your next pawn to:

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

{-# LANGUAGE CPP #-}
import Control.Monad
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 💡