kamisado.hs

import qualified Data.Sequence as Sequence

fromList = Sequence.fromList
index = Sequence.index
update = Sequence.update

data Color = Red |
             Green |
             Blue |
             Yellow
             deriving (Eq, Show)

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

data Piece = Piece {
    getPlayer :: Player,
    getColor :: Color
  } deriving (Eq, Show)

gridSize = 4

initBoard = fromList [
  fromList [(Red, Just $ Piece Black Red), (Green, Just $ Piece Black Green),
            (Blue, Just $ Piece Black Blue), (Yellow, Just $ Piece Black Yellow)],
  fromList [(Yellow, Nothing), (Red, Nothing), (Green, Nothing), (Blue, Nothing)],
  fromList [(Blue, Nothing), (Yellow, Nothing), (Red, Nothing), (Green, Nothing)],
  fromList [(Green, Just $ Piece White Green), (Blue, Just $ Piece White Blue),
            (Yellow, Just $ Piece White Yellow), (Red, Just $ Piece White Red)]]

type Board = Sequence.Seq (Sequence.Seq (Color, Maybe Piece))

cellAt board (i, j) = index (index board i) j
colorAt board (i, j) = fst (cellAt board (i, j))
pieceAt board (i, j) = snd (cellAt board (i, j))
cellEmpty board (i, j) = pieceAt board (i, j) == Nothing

getPlayerPieceCoords board player =
  filter (\(i, j) -> fmap getPlayer (pieceAt board (i, j)) == Just player) coords
  where coords = [(i, j) | i <- [0..3], j <- [0..3]]

upward :: (Int, Int) -> [(Int, Int)]
upward (i, j) = [(a, b) | a <- [i - 1, i - 2..0], b <- [j]]
downward :: (Int, Int) -> [(Int, Int)]
downward (i, j) = [(a, b) | a <- [i + 1..gridSize-1], b <- [j]]
upleftward :: (Int, Int) -> [(Int, Int)]
upleftward (i, j) = [(i - k, j - k) | k <- [1..gridSize], i - k >= 0, j - k >= 0]
uprightward :: (Int, Int) -> [(Int, Int)]
uprightward (i, j) = [(i - k, j + k) | k <- [1..gridSize], i - k >= 0, j + k < gridSize]
downleftward :: (Int, Int) -> [(Int, Int)]
downleftward (i, j) = [(i + k, j - k) | k <- [1..gridSize], i + k < gridSize, j - k >= 0]
downrightward :: (Int, Int) -> [(Int, Int)]
downrightward (i, j) = [(i + k, j + k) | k <- [1..gridSize], i + k < gridSize, j + k < gridSize]

movePiece board (i0, j0) (i1, j1) =
  update i0 srcRow $ dstBoard
  where srcCell = (colorAt board (i0, j0), Nothing)
        srcRow = update j0 srcCell $ index board i0
        dstCell = (colorAt board (i1, j1), pieceAt board (i0, j0))
        dstRow = update j1 dstCell $ index board i1
        dstBoard = update i1 dstRow $ board

getBoardsForPotentialPlayerMoves board (i0, j0) =
  length $ map (\(i1, j1) -> movePiece board (i0, j0) (i1, j1)) moves
  where player = fmap getPlayer $ pieceAt board (i0, j0)
        constrainMoves = takeWhile $ cellEmpty board
        moves = case player of
          Just White -> concat $ map constrainMoves
                        [upleftward (i0, j0), upward (i0, j0), uprightward (i0, j0)]
          Just Black -> concat $ map constrainMoves
                        [downleftward (i0, j0), downward (i0, j0), downrightward (i0, j0)]
          Nothing -> error "not a valid move!"

inf = (read "Infinity")::Double

isWinning board player =
  any (player==) playersInWinningRow
  where playersInWinningRow = fmap (fmap getPlayer) (fmap snd $ index board playerWinningRow)
        playerWinningRow = case player of
          Just White -> 0
          Just Black -> gridSize - 1

boardValue :: Board -> Maybe Player -> Double
boardValue board player =
  winning + playing
  where winning = if isWinning board player
                  then inf else 0
        playing = 0