bishbosh-0.1.1.0: src-test/BishBosh/Test/HUnit/State/Board.hs
{-
Copyright (C) 2018 Dr. Alistair Ward
This file is part of BishBosh.
BishBosh is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
BishBosh is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with BishBosh. If not, see <http://www.gnu.org/licenses/>.
-}
{- |
[@AUTHOR@] Dr. Alistair Ward
[@DESCRIPTION@] Static tests.
-}
module BishBosh.Test.HUnit.State.Board(
-- * Types
-- ** Type-synonyms
Board,
-- * Constants
testCases
) where
import Control.Arrow((***))
import Data.Array.IArray((!))
import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour
import qualified BishBosh.Attribute.Rank as Attribute.Rank
import qualified BishBosh.Cartesian.Abscissa as Cartesian.Abscissa
import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates
import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate
import qualified BishBosh.Cartesian.Vector as Cartesian.Vector
import qualified BishBosh.Component.Move as Component.Move
import qualified BishBosh.Component.Piece as Component.Piece
import qualified BishBosh.Property.FixedMembership as Property.FixedMembership
import qualified BishBosh.Property.Opposable as Property.Opposable
import qualified BishBosh.State.Board as State.Board
import qualified BishBosh.State.CoordinatesByRankByLogicalColour as State.CoordinatesByRankByLogicalColour
import qualified BishBosh.State.MaybePieceByCoordinates as State.MaybePieceByCoordinates
import qualified BishBosh.StateProperty.Mutator as StateProperty.Mutator
import qualified BishBosh.Test.HUnit.Cartesian.Coordinates as Test.HUnit.Cartesian.Coordinates
import qualified BishBosh.Type.Length as Type.Length
import qualified Control.Arrow
import qualified Data.Array.IArray
import qualified Data.Default
import qualified Data.Foldable
import qualified Data.Map
import qualified Data.Maybe
import qualified Test.HUnit
import qualified ToolShed.Data.Foldable
import Test.HUnit((~:), (~?=), (~?))
-- | Defines a concrete type for testing.
type Board = State.Board.Board Type.Length.X Type.Length.Y
-- | Check the sanity of the implementation, by validating a list of static test-cases.
testCases :: Test.HUnit.Test
testCases = Test.HUnit.test [
"'BishBosh.Cartesian.Coordinates' failed to locate the expected pieces on a default board." ~: (
map length . ToolShed.Data.Foldable.gather $ map (
`State.MaybePieceByCoordinates.dereference` Data.Default.def
) (Property.FixedMembership.members :: [Test.HUnit.Cartesian.Coordinates.Coordinates])
) ~?= [32, 8, 2, 2, 2, 1, 1, 8, 2, 2, 2, 1, 1],
let
kingsColour = Attribute.LogicalColour.Black
destination = Cartesian.Coordinates.mkRelativeCoordinates ((+ 3) *** (+ 3))
directionToCoordinates = last . (`Cartesian.Coordinates.extrapolate` destination)
mkPiece = Component.Piece.mkPiece $ Property.Opposable.getOpposite kingsColour
maybeShift :: Cartesian.Vector.VectorInt -> Maybe Test.HUnit.Cartesian.Coordinates.Coordinates
maybeShift = Cartesian.Vector.maybeTranslate destination
in all (
State.Board.isKingChecked kingsColour . placePieces . (:) (Component.Piece.mkKing kingsColour, destination) . return {-to List-monad-}
) (
concat [
Data.Maybe.mapMaybe (
fmap ((,) (mkPiece Attribute.Rank.Pawn)) . maybeShift . Property.Opposable.getOpposite
) . Cartesian.Vector.attackVectorsForPawn $ Property.Opposable.getOpposite kingsColour,
let
attacker = mkPiece Attribute.Rank.Rook
in map ((,) attacker . directionToCoordinates) $ Component.Piece.getAttackDirections attacker,
let
attacker = mkPiece Attribute.Rank.Bishop
in map ((,) attacker . directionToCoordinates) $ Component.Piece.getAttackDirections attacker,
Data.Maybe.mapMaybe (fmap ((,) (mkPiece Attribute.Rank.Knight)) . maybeShift) Cartesian.Vector.attackVectorsForKnight,
let
attacker = mkPiece Attribute.Rank.Queen
in map ((,) attacker . directionToCoordinates) $ Component.Piece.getAttackDirections attacker
]
) ~? "'BishBosh.State.Board.isKingChecked' failed.",
"'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed, for passed Pawn adjacent to opposing Pawn of equal rank." ~: Data.Array.IArray.elems (
Data.Array.IArray.amap length . State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map (
Component.Piece.mkPawn *** Cartesian.Coordinates.mkRelativeCoordinates
) [
(
Attribute.LogicalColour.Black,
id
), (
Attribute.LogicalColour.White,
Control.Arrow.first succ
)
]
) ~?= [1, 1],
"'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for passed Pawns isolated from opposing Pawn." ~: Data.Array.IArray.elems (
Data.Array.IArray.amap length . State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map (
Component.Piece.mkPawn *** Cartesian.Coordinates.mkRelativeCoordinates
) [
(
Attribute.LogicalColour.Black,
Control.Arrow.second succ
), (
Attribute.LogicalColour.White,
Control.Arrow.first (+ 2)
)
]
) ~?= [1, 1],
"'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for un-passed Pawn approaching opposing Pawn." ~: Data.Array.IArray.elems (
Data.Array.IArray.amap length . State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map (
Component.Piece.mkPawn *** Cartesian.Coordinates.mkRelativeCoordinates
) [
(
Attribute.LogicalColour.White,
id
), (
Attribute.LogicalColour.Black,
succ *** succ
)
]
) ~?= [0, 0],
"'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for un-passed Pawn sandwiched by opposing Pawns." ~: Data.Array.IArray.elems (
Data.Array.IArray.amap length . State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map (
Component.Piece.mkPawn *** Cartesian.Coordinates.mkRelativeCoordinates
) [
(
Attribute.LogicalColour.Black,
id
), (
Attribute.LogicalColour.White,
succ *** succ
), (
Attribute.LogicalColour.Black,
(+ 2) *** (+ 2)
)
]
) ~?= [1, 0],
"'BishBosh.State.CoordinatesByRankByLogicalColour.countPassedPawns' failed for un-passed Pawn between doubled opposing Pawns." ~: Data.Array.IArray.elems (
Data.Array.IArray.amap length . State.CoordinatesByRankByLogicalColour.findPassedPawnCoordinatesByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map (
Component.Piece.mkPawn *** Cartesian.Coordinates.mkRelativeCoordinates
) [
(
Attribute.LogicalColour.Black,
id
), (
Attribute.LogicalColour.Black,
Control.Arrow.second (+ 2)
), (
Attribute.LogicalColour.White,
succ *** succ
)
]
) ~?= [1, 0],
let
whitePawnsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ
in not (
State.Board.exposesKing Attribute.LogicalColour.White (
Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance Attribute.LogicalColour.White whitePawnsCoordinates
) $ placePieces [
(
Component.Piece.mkKing Attribute.LogicalColour.White,
minBound
), (
Component.Piece.mkPawn Attribute.LogicalColour.White,
whitePawnsCoordinates
), (
Component.Piece.mkPawn Attribute.LogicalColour.Black,
Cartesian.Coordinates.mkRelativeCoordinates $ (+ 2) *** (+ 2)
)
]
) ~? "'BishBosh.State.Board.exposesKing false positive attack by black Pawn, after moving White Pawn.",
let
whitePawnsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ
in not (
State.Board.exposesKing Attribute.LogicalColour.White (
Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance Attribute.LogicalColour.White whitePawnsCoordinates
) $ placePieces [
(
Component.Piece.mkKing Attribute.LogicalColour.White,
minBound
), (
Component.Piece.mkPawn Attribute.LogicalColour.White,
whitePawnsCoordinates
), (
Component.Piece.mkKing Attribute.LogicalColour.Black,
Cartesian.Coordinates.mkRelativeCoordinates $ (+ 2) *** (+ 2)
)
]
) ~? "'BishBosh.State.Board.exposesKing false positive attack by black King, after moving White Pawn.",
let
whiteBishopsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ
in not (
State.Board.exposesKing Attribute.LogicalColour.White (
Component.Move.mkMove whiteBishopsCoordinates $ Cartesian.Coordinates.translate (succ *** succ) whiteBishopsCoordinates -- Move towards Black Queen.
) $ placePieces [
(
Component.Piece.mkKing Attribute.LogicalColour.White,
minBound
), (
Component.Piece.mkBishop Attribute.LogicalColour.White,
whiteBishopsCoordinates
), (
Component.Piece.mkQueen Attribute.LogicalColour.Black,
maxBound
)
]
) ~? "'BishBosh.State.Board.exposesKing false positive attack by black Queen, after moving White Bishop.",
let
whitePawnsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ
in State.Board.exposesKing Attribute.LogicalColour.White (
Component.Move.mkMove whitePawnsCoordinates $ Cartesian.Coordinates.advance Attribute.LogicalColour.White whitePawnsCoordinates -- Expose attack from Black Queen.
) (
placePieces [
(
Component.Piece.mkKing Attribute.LogicalColour.White,
minBound
), (
Component.Piece.mkPawn Attribute.LogicalColour.White,
whitePawnsCoordinates
), (
Component.Piece.mkQueen Attribute.LogicalColour.Black,
maxBound
)
]
) ~? "'BishBosh.State.Board.exposesKing failed after advancing White Pawn.",
let
whiteKnightsCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ
in State.Board.exposesKing Attribute.LogicalColour.White (
Component.Move.mkMove whiteKnightsCoordinates . Cartesian.Coordinates.mkRelativeCoordinates $ (+ 3) *** (+ 2) -- Expose attack from Black Queen.
) (
placePieces [
(
Component.Piece.mkKing Attribute.LogicalColour.White,
minBound
), (
Component.Piece.mkKnight Attribute.LogicalColour.White,
whiteKnightsCoordinates
), (
Component.Piece.mkQueen Attribute.LogicalColour.Black,
maxBound
)
]
) ~? "'BishBosh.State.Board.exposesKing failed after moving White Knight.",
let
whiteRooksCoordinates = Cartesian.Coordinates.mkRelativeCoordinates $ (+ 2) *** (+ 2)
in not (
State.Board.exposesKing Attribute.LogicalColour.White (
Component.Move.mkMove whiteRooksCoordinates $ Cartesian.Coordinates.advance Attribute.LogicalColour.White whiteRooksCoordinates -- Shift blocking-role to Pawn.
) $ placePieces [
(
Component.Piece.mkKing Attribute.LogicalColour.White,
minBound
), (
Component.Piece.mkPawn Attribute.LogicalColour.White,
Cartesian.Coordinates.mkRelativeCoordinates $ succ *** succ
), (
Component.Piece.mkRook Attribute.LogicalColour.White,
whiteRooksCoordinates
), (
Component.Piece.mkQueen Attribute.LogicalColour.Black,
maxBound
)
]
) ~? "'BishBosh.State.Board.exposesKing failed after moving White Rook.",
Data.Foldable.all (
Data.Foldable.all (== 1)
) (
State.CoordinatesByRankByLogicalColour.countPawnsByFileByLogicalColour $ State.Board.getCoordinatesByRankByLogicalColour (Data.Default.def :: Board)
) ~? "'BishBosh.State.Board.countPawnsByFileByLogicalColour': failed for default board",
(
(== [(0, 3), (2, 2), (4, 1)]) . Data.Map.assocs . (! Attribute.LogicalColour.White) . State.CoordinatesByRankByLogicalColour.countPawnsByFileByLogicalColour . State.Board.getCoordinatesByRankByLogicalColour . placePieces $ map (
(,) (Component.Piece.mkPawn Attribute.LogicalColour.White) . Cartesian.Coordinates.mkRelativeCoordinates
) [
Control.Arrow.second succ,
Control.Arrow.second (+ 3),
Control.Arrow.second (+ 5),
(+ 2) *** (+ 2),
(+ 2) *** (+ 4),
(+ 4) *** succ
]
) ~? "'BishBosh.State.Board.countPawnsByFileByLogicalColour': failed",
(
Data.Map.unions (
Data.Array.IArray.elems $ State.Board.countDefendersByCoordinatesByLogicalColour (Data.Default.def :: Board)
) == foldr (
Data.Map.delete . Cartesian.Coordinates.kingsStartingCoordinates
) (
Data.Map.fromList $ zip [
Cartesian.Coordinates.mkCoordinates x y |
y <- [
Cartesian.Ordinate.yMax,
Cartesian.Ordinate.pawnsFirstRank Attribute.LogicalColour.Black,
Cartesian.Ordinate.pawnsFirstRank Attribute.LogicalColour.White,
Cartesian.Ordinate.yMin
],
x <- Cartesian.Abscissa.xRange
] [
0, 1, 1, 1, 1, 1, 1, 0, -- Black Pieces.
1, 1, 1, 4, 4, 1, 1, 1, -- Black Pawns.
1, 1, 1, 4, 4, 1, 1, 1, -- White Pawns.
0, 1, 1, 1, 1, 1, 1, 0 -- White Pieces.
]
) Property.FixedMembership.members
) ~? "'BoshBosh.State.Board.countDefendersByCoordinatesByLogicalColour': failed"
] where
placePieces :: [(Component.Piece.Piece, Test.HUnit.Cartesian.Coordinates.Coordinates)] -> Board
placePieces = StateProperty.Mutator.placeAllPieces