{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLists #-}
module Chess.Rulebook.Standard.Threat
( threats
, threatCommands
) where
import Prelude hiding (lookup)
import Chess.Board (Board, lookup)
import Chess.Board.Direction (Direction(..), diagonals, jumps, orthogonals, principals)
import Chess.Board.PlacedPiece (PlacedPiece(..))
import Chess.Board.Position (Position, offset)
import Chess.Color (Color(White))
import Chess.Game.Command (Command, move, destroy)
import Chess.Piece (PieceType(..))
import Chess.Some (Some(Some))
threats :: PlacedPiece t -> Board -> [Position]
threats :: forall (t :: PieceType'). PlacedPiece t -> Board -> [Position]
threats PlacedPiece t
piece Board
board =
case PlacedPiece t
piece.type' of
PieceType t
Pawn -> [Direction] -> Int -> [Position]
threat [Direction]
pawnDirections Int
1
PieceType t
Knight -> [Direction] -> Int -> [Position]
threat [Direction]
jumps Int
1
PieceType t
Bishop -> [Direction] -> Int -> [Position]
threat [Direction]
diagonals forall a. Bounded a => a
maxBound
PieceType t
Rook -> [Direction] -> Int -> [Position]
threat [Direction]
orthogonals forall a. Bounded a => a
maxBound
PieceType t
Queen -> [Direction] -> Int -> [Position]
threat [Direction]
principals forall a. Bounded a => a
maxBound
PieceType t
King -> [Direction] -> Int -> [Position]
threat [Direction]
principals Int
1
where
threat :: [Direction] -> Int -> [Position]
threat = forall (t :: PieceType').
PlacedPiece t -> Board -> [Direction] -> Int -> [Position]
reach PlacedPiece t
piece Board
board
pawnDelta :: Int
pawnDelta = if PlacedPiece t
piece.color forall a. Eq a => a -> a -> Bool
== Color
White then Int
1 else (-Int
1)
pawnDirections :: [Direction]
pawnDirections = forall a. (a -> Bool) -> [a] -> [a]
filter (\Direction
d -> Direction
d.rowDelta forall a. Eq a => a -> a -> Bool
== Int
pawnDelta) [Direction]
diagonals
threatCommands :: PlacedPiece t -> Board -> [Command]
threatCommands :: forall (t :: PieceType'). PlacedPiece t -> Board -> [Command]
threatCommands PlacedPiece t
piece Board
board = do
Position
target <- forall (t :: PieceType'). PlacedPiece t -> Board -> [Position]
threats PlacedPiece t
piece Board
board
case forall (f :: * -> *).
Alternative f =>
Position -> Board -> f (Some PlacedPiece)
lookup Position
target Board
board of
Maybe (Some PlacedPiece)
Nothing ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (t :: PieceType'). Position -> PlacedPiece t -> Command
move Position
target PlacedPiece t
piece)
Just (Some PlacedPiece t
enemy) ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall (t :: PieceType'). PlacedPiece t -> Command
destroy PlacedPiece t
enemy, forall (t :: PieceType'). Position -> PlacedPiece t -> Command
move Position
target PlacedPiece t
piece]
reach
:: PlacedPiece t
-> Board
-> [Direction]
-> Int
-> [Position]
reach :: forall (t :: PieceType').
PlacedPiece t -> Board -> [Direction] -> Int -> [Position]
reach PlacedPiece t
piece Board
board [Direction]
directions Int
maxSteps = do
Direction
direction <- [Direction]
directions
[Position] -> [Position]
takeUntilPiece
forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
maxSteps
forall a b. (a -> b) -> a -> b
$ forall {t}. (t -> Maybe t) -> t -> [t]
collect (forall (f :: * -> *).
Alternative f =>
Direction -> Position -> f Position
offset Direction
direction) PlacedPiece t
piece.position
where
takeUntilPiece :: [Position] -> [Position]
takeUntilPiece [] = []
takeUntilPiece (Position
p:[Position]
ps) =
case forall (f :: * -> *).
Alternative f =>
Position -> Board -> f (Some PlacedPiece)
lookup Position
p Board
board of
Maybe (Some PlacedPiece)
Nothing -> Position
p forall a. a -> [a] -> [a]
: [Position] -> [Position]
takeUntilPiece [Position]
ps
Just (Some PlacedPiece t
other)
| PlacedPiece t
piece.color forall a. Eq a => a -> a -> Bool
== PlacedPiece t
other.color -> []
| Bool
otherwise -> [Position
p]
collect :: (t -> Maybe t) -> t -> [t]
collect t -> Maybe t
f t
start = Maybe t -> [t]
go (t -> Maybe t
f t
start)
where
go :: Maybe t -> [t]
go (Just t
p) = t
p forall a. a -> [a] -> [a]
: Maybe t -> [t]
go (t -> Maybe t
f t
p)
go Maybe t
Nothing = []