{-# LANGUAGE OverloadedLists #-}
-----------------------------------------------------------------------------
-- |
-- Module      : Chess.Rulebook.Standard
-- Copyright   : (c) Michael Szvetits, 2023
-- License     : BSD-3-Clause (see the file LICENSE)
-- Maintainer  : typedbyte@qualified.name
-- Stability   : stable
-- Portability : portable
--
-- Types and functions to represent the standard rulebook for chess games.
-----------------------------------------------------------------------------
module Chess.Rulebook.Standard (standardRulebook) where

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

-- | The standard rulebook for chess games.
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 )