{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}
module Chess.Rulebook.Standard.Movement.King where
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))
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
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
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
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
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
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)
Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem PlacedPiece 'King'
king.position [Position]
enemyThreats)
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)
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]