{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE OverloadedLists #-}
-----------------------------------------------------------------------------
-- |
-- Module      : Chess.Rulebook.Standard.Movement.King
-- Copyright   : (c) Michael Szvetits, 2023
-- License     : BSD-3-Clause (see the file LICENSE)
-- Maintainer  : typedbyte@qualified.name
-- Stability   : stable
-- Portability : portable
--
-- Implementation of the movement rule for kings, according to the standard
-- rulebook.
-----------------------------------------------------------------------------
module Chess.Rulebook.Standard.Movement.King where

-- base
import Control.Applicative ((<|>))
import Control.Monad       (guard)
import Prelude hiding      (lookup)

import Chess.Board                    (isOccupied, lookup, piecesOf)
import Chess.Board.Direction          (left, right)
import Chess.Board.PlacedPiece        (PlacedPiece(..), assumeType)
import Chess.Board.Position           (Position(..), boundedOffset, boundedPosition)
import Chess.Color                    (Color(..), oppositeOf)
import Chess.Game                     (Game(Game, board), Update(command), history)
import Chess.Game.Command             (Command(..), move)
import Chess.Piece                    (PieceType(Rook), PieceType'(King'))
import Chess.Rulebook.Standard.Threat (threats, threatCommands)
import Chess.Some                     (Some(Some))

-- | Determines all possible movements (including captures and castlings) for a given king.
movements :: PlacedPiece King' -> Game -> [Command]
movements :: PlacedPiece 'King' -> Game -> [Command]
movements PlacedPiece 'King'
king game :: Game
game@Game{Board
board :: Board
$sel:board:Game :: Game -> Board
board}
    = forall (t :: PieceType'). PlacedPiece t -> Board -> [Command]
threatCommands PlacedPiece 'King'
king Board
board
  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> PlacedPiece 'King' -> Game -> [Command]
castlings PlacedPiece 'King'
king Game
game

-- | Determines all possible castlings for a given king.
castlings :: PlacedPiece King' -> Game -> [Command]
castlings :: PlacedPiece 'King' -> Game -> [Command]
castlings PlacedPiece 'King'
king game :: Game
game@Game{Board
board :: Board
$sel:board:Game :: Game -> Board
board} =
  let
    expectedPosition :: Position
expectedPosition =
      case PlacedPiece 'King'
king.color of
        Color
White -> Int -> Int -> Position
boundedPosition Int
0 Int
4
        Color
Black -> Int -> Int -> Position
boundedPosition Int
7 Int
4
    enemyThreats :: [Position]
enemyThreats =
      forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        ( \(Some PlacedPiece t
enemy) -> forall (t :: PieceType'). PlacedPiece t -> Board -> [Position]
threats PlacedPiece t
enemy Board
board )
        ( Color -> Board -> [Some PlacedPiece]
piecesOf (Color -> Color
oppositeOf PlacedPiece 'King'
king.color) Board
board )
    hasMoved :: Position -> Command -> Bool
hasMoved Position
rookPosition = \case
      Move Position
_ (Some (PlacedPiece Position
src Piece t
_)) ->
        Position
src forall a. Eq a => a -> a -> Bool
== PlacedPiece 'King'
king.position Bool -> Bool -> Bool
|| Position
src forall a. Eq a => a -> a -> Bool
== Position
rookPosition
      Sequence Command
cmd1 Command
cmd2 ->
        Position -> Command -> Bool
hasMoved Position
rookPosition Command
cmd1 Bool -> Bool -> Bool
|| Position -> Command -> Bool
hasMoved Position
rookPosition Command
cmd2
      Atomic Command
cmd ->
        Position -> Command -> Bool
hasMoved Position
rookPosition Command
cmd
      Command
_ ->
        Bool
False
  in do
    -- the king must be in the right position
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ PlacedPiece 'King'
king.position forall a. Eq a => a -> a -> Bool
== Position
expectedPosition
    -- the same-colored rook must be in the right position
    let leftCorner :: Position
leftCorner  = Int -> Int -> Position
boundedPosition PlacedPiece 'King'
king.position.row Int
0
    let rightCorner :: Position
rightCorner = Int -> Int -> Position
boundedPosition PlacedPiece 'King'
king.position.row Int
7
    Some PlacedPiece t
piece <- forall (f :: * -> *).
Alternative f =>
Position -> Board -> f (Some PlacedPiece)
lookup Position
leftCorner Board
board forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *).
Alternative f =>
Position -> Board -> f (Some PlacedPiece)
lookup Position
rightCorner Board
board
    PlacedPiece 'Rook'
rook       <- forall (f :: * -> *) (t :: PieceType') (a :: PieceType').
Alternative f =>
PieceType t -> PlacedPiece a -> f (PlacedPiece t)
assumeType PieceType 'Rook'
Rook PlacedPiece t
piece
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ PlacedPiece 'Rook'
rook.color forall a. Eq a => a -> a -> Bool
== PlacedPiece 'King'
king.color
    -- get the fields between king and rook
    let direction :: Direction
direction = if PlacedPiece 'King'
king.position.column forall a. Ord a => a -> a -> Bool
> PlacedPiece 'Rook'
rook.position.column then Direction
left else Direction
right
    let oneNext :: Position
oneNext   = Direction -> Position -> Position
boundedOffset Direction
direction PlacedPiece 'King'
king.position
    let twoNext :: Position
twoNext   = Direction -> Position -> Position
boundedOffset Direction
direction Position
oneNext
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard
      -- the fields between king and rook must be empty
       forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Position -> Board -> Bool
isOccupied Position
oneNext Board
board)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (Position -> Board -> Bool
isOccupied Position
twoNext Board
board)
      -- the king must not be threatened
      Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem PlacedPiece 'King'
king.position [Position]
enemyThreats)
      -- the fields between king and rook must not be threatened
      Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Position
oneNext [Position]
enemyThreats)
      Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Position
twoNext [Position]
enemyThreats)
      -- king and rook must not have moved during the game
      Bool -> Bool -> Bool
&& Bool -> Bool
not
           ( forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
             ( Position -> Command -> Bool
hasMoved PlacedPiece 'Rook'
rook.position forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.command) )
             ( Game -> [Update]
history Game
game )
           )
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall (t :: PieceType'). Position -> PlacedPiece t -> Command
move Position
twoNext PlacedPiece 'King'
king, forall (t :: PieceType'). Position -> PlacedPiece t -> Command
move Position
oneNext PlacedPiece 'Rook'
rook]