{-# LANGUAGE OverloadedLists #-}
module Chess.Rulebook.Standard (standardRulebook) where
import Control.Monad (guard)
import Prelude hiding (lookup)
import Chess.Board (Board, empty, lookup, replace)
import Chess.Board.PlacedPiece (PlacedPiece(PlacedPiece), placedPiece)
import Chess.Board.Position (boundedPosition)
import Chess.Color (Color(..))
import Chess.Exception (assumeRight)
import Chess.Game (Game(..), Update(..), execute)
import Chess.Game.Command (atomic, endTurn)
import Chess.Piece (Piece(Piece), PieceType(..))
import Chess.Player (Player(Player))
import Chess.Rulebook (Rulebook(..))
import Chess.Rulebook.Standard.Check (checked)
import Chess.Rulebook.Standard.Movement (movements)
import Chess.Rulebook.Standard.Status (status)
import Chess.Some (Some(Some))
standardRulebook :: Rulebook
standardRulebook :: Rulebook
standardRulebook =
Rulebook
{ $sel:newGame:Rulebook :: Game
newGame =
Game
{ $sel:board:Game :: Board
board = Board
newBoard
, $sel:activePlayer:Game :: Player
activePlayer = Color -> Player
Player Color
White
, $sel:passivePlayer:Game :: Player
passivePlayer = Color -> Player
Player Color
Black
, $sel:lastUpdate:Game :: Maybe Update
lastUpdate = forall a. Maybe a
Nothing
}
, $sel:status:Rulebook :: Game -> Status
status = Game -> Status
status
, $sel:updates:Rulebook :: Position -> Game -> [Update]
updates =
\Position
position Game
game -> do
Some PlacedPiece t
piece <- forall (f :: * -> *).
Alternative f =>
Position -> Board -> f (Some PlacedPiece)
lookup Position
position Game
game.board
Command
move <- forall (t :: PieceType'). PlacedPiece t -> Game -> [Command]
movements PlacedPiece t
piece Game
game
let turn :: Command
turn = Command -> Command
atomic [Command
move, Command
endTurn]
Game
newGame <- forall (f :: * -> *) e a. Alternative f => Either e a -> f a
assumeRight forall a b. (a -> b) -> a -> b
$ Command -> Game -> Either ChessException Game
execute Command
turn Game
game
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Player -> Board -> Bool
checked Game
newGame.passivePlayer Game
newGame.board)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Game -> Command -> Update
Update Game
newGame Command
turn)
}
baseLine :: Color -> [Some PlacedPiece]
baseLine :: Color -> [Some PlacedPiece]
baseLine Color
color =
let
rook :: Piece 'Rook'
rook = forall (t :: PieceType'). PieceType t -> Color -> Piece t
Piece PieceType 'Rook'
Rook Color
color
knight :: Piece 'Knight'
knight = forall (t :: PieceType'). PieceType t -> Color -> Piece t
Piece PieceType 'Knight'
Knight Color
color
bishop :: Piece 'Bishop'
bishop = forall (t :: PieceType'). PieceType t -> Color -> Piece t
Piece PieceType 'Bishop'
Bishop Color
color
queen :: Piece 'Queen'
queen = forall (t :: PieceType'). PieceType t -> Color -> Piece t
Piece PieceType 'Queen'
Queen Color
color
king :: Piece 'King'
king = forall (t :: PieceType'). PieceType t -> Color -> Piece t
Piece PieceType 'King'
King Color
color
row :: Int
row = if Color
color forall a. Eq a => a -> a -> Bool
== Color
White then Int
0 else Int
7
in
[ forall (t :: PieceType'). Position -> Piece t -> Some PlacedPiece
placedPiece (Int -> Int -> Position
boundedPosition Int
row Int
0) Piece 'Rook'
rook
, forall (t :: PieceType'). Position -> Piece t -> Some PlacedPiece
placedPiece (Int -> Int -> Position
boundedPosition Int
row Int
1) Piece 'Knight'
knight
, forall (t :: PieceType'). Position -> Piece t -> Some PlacedPiece
placedPiece (Int -> Int -> Position
boundedPosition Int
row Int
2) Piece 'Bishop'
bishop
, forall (t :: PieceType'). Position -> Piece t -> Some PlacedPiece
placedPiece (Int -> Int -> Position
boundedPosition Int
row Int
3) Piece 'Queen'
queen
, forall (t :: PieceType'). Position -> Piece t -> Some PlacedPiece
placedPiece (Int -> Int -> Position
boundedPosition Int
row Int
4) Piece 'King'
king
, forall (t :: PieceType'). Position -> Piece t -> Some PlacedPiece
placedPiece (Int -> Int -> Position
boundedPosition Int
row Int
5) Piece 'Bishop'
bishop
, forall (t :: PieceType'). Position -> Piece t -> Some PlacedPiece
placedPiece (Int -> Int -> Position
boundedPosition Int
row Int
6) Piece 'Knight'
knight
, forall (t :: PieceType'). Position -> Piece t -> Some PlacedPiece
placedPiece (Int -> Int -> Position
boundedPosition Int
row Int
7) Piece 'Rook'
rook
]
pawnLine :: Color -> [Some PlacedPiece]
pawnLine :: Color -> [Some PlacedPiece]
pawnLine Color
color =
let
pawn :: Piece 'Pawn'
pawn = forall (t :: PieceType'). PieceType t -> Color -> Piece t
Piece PieceType 'Pawn'
Pawn Color
color
row :: Int
row = if Color
color forall a. Eq a => a -> a -> Bool
== Color
White then Int
1 else Int
6
in
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
( \Int
column -> forall (t :: PieceType'). Position -> Piece t -> Some PlacedPiece
placedPiece (Int -> Int -> Position
boundedPosition Int
row Int
column) Piece 'Pawn'
pawn )
[ Int
0..Int
7 ]
newBoard :: Board
newBoard :: Board
newBoard =
let
whiteBaseLine :: [Some PlacedPiece]
whiteBaseLine = Color -> [Some PlacedPiece]
baseLine Color
White
whitePawnLine :: [Some PlacedPiece]
whitePawnLine = Color -> [Some PlacedPiece]
pawnLine Color
White
blackBaseLine :: [Some PlacedPiece]
blackBaseLine = Color -> [Some PlacedPiece]
baseLine Color
Black
blackPawnLine :: [Some PlacedPiece]
blackPawnLine = Color -> [Some PlacedPiece]
pawnLine Color
Black
in
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
( \(Some (PlacedPiece Position
position Piece t
piece)) -> forall (t :: PieceType'). Position -> Piece t -> Board -> Board
replace Position
position Piece t
piece )
( Board
empty )
( [Some PlacedPiece]
whiteBaseLine forall a. [a] -> [a] -> [a]
++ [Some PlacedPiece]
whitePawnLine forall a. [a] -> [a] -> [a]
++ [Some PlacedPiece]
blackBaseLine forall a. [a] -> [a] -> [a]
++ [Some PlacedPiece]
blackPawnLine )