{-# LANGUAGE MultiParamTypeClasses #-}
module BishBosh.StateProperty.Seeker(
NPiecesByFileByLogicalColour,
Seeker(..),
accumulatePawnsByFile,
findAllPieces,
summariseNPawnsByLogicalColour,
findInvalidity
) where
import Control.Arrow((&&&), (***))
import Data.Array.IArray((!))
import qualified BishBosh.Attribute.Rank as Attribute.Rank
import qualified BishBosh.Cartesian.Coordinates as Cartesian.Coordinates
import qualified BishBosh.Cartesian.Ordinate as Cartesian.Ordinate
import qualified BishBosh.Colour.LogicalColour as Colour.LogicalColour
import qualified BishBosh.Component.Piece as Component.Piece
import qualified BishBosh.Property.Empty as Property.Empty
import qualified BishBosh.Property.SelfValidating as Property.SelfValidating
import qualified BishBosh.Type.Count as Type.Count
import qualified BishBosh.Type.Length as Type.Length
import qualified Control.Arrow
import qualified Data.Array.IArray
import qualified Data.Foldable
import qualified Data.List
import qualified Data.Map.Strict as Map
type NPiecesByFile = Map.Map Type.Length.X Type.Count.NPieces
accumulatePawnsByFile :: Type.Length.X -> NPiecesByFile -> NPiecesByFile
{-# INLINE accumulatePawnsByFile #-}
accumulatePawnsByFile :: X -> NPiecesByFile -> NPiecesByFile
accumulatePawnsByFile = (X -> X -> NPiecesByFile -> NPiecesByFile)
-> X -> X -> NPiecesByFile -> NPiecesByFile
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((X -> X -> X) -> X -> X -> NPiecesByFile -> NPiecesByFile
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith ((X -> X -> X) -> X -> X -> NPiecesByFile -> NPiecesByFile)
-> (X -> X -> X) -> X -> X -> NPiecesByFile -> NPiecesByFile
forall a b. (a -> b) -> a -> b
$ (X -> X) -> X -> X -> X
forall a b. a -> b -> a
const X -> X
forall a. Enum a => a -> a
succ) X
1
type NPiecesByFileByLogicalColour = Colour.LogicalColour.ArrayByLogicalColour NPiecesByFile
class Seeker seeker where
findProximateKnights
:: seeker
-> Colour.LogicalColour.LogicalColour
-> Cartesian.Coordinates.Coordinates
-> [Cartesian.Coordinates.Coordinates]
findPieces
:: (Component.Piece.Piece -> Bool)
-> seeker
-> [Component.Piece.LocatedPiece]
countPawnsByFileByLogicalColour :: seeker -> NPiecesByFileByLogicalColour
countPawnsByFileByLogicalColour = (
\(NPiecesByFile
mB, NPiecesByFile
mW) -> [NPiecesByFile] -> NPiecesByFileByLogicalColour
forall (a :: * -> * -> *) e. IArray a e => [e] -> a LogicalColour e
Colour.LogicalColour.listArrayByLogicalColour [NPiecesByFile
mB, NPiecesByFile
mW]
) ((NPiecesByFile, NPiecesByFile) -> NPiecesByFileByLogicalColour)
-> (seeker -> (NPiecesByFile, NPiecesByFile))
-> seeker
-> NPiecesByFileByLogicalColour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocatedPiece
-> (NPiecesByFile, NPiecesByFile)
-> (NPiecesByFile, NPiecesByFile))
-> (NPiecesByFile, NPiecesByFile)
-> [LocatedPiece]
-> (NPiecesByFile, NPiecesByFile)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (
(
\(X
x, Bool
isBlack) -> (
if Bool
isBlack then (NPiecesByFile -> NPiecesByFile)
-> (NPiecesByFile, NPiecesByFile) -> (NPiecesByFile, NPiecesByFile)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Control.Arrow.first else (NPiecesByFile -> NPiecesByFile)
-> (NPiecesByFile, NPiecesByFile) -> (NPiecesByFile, NPiecesByFile)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
Control.Arrow.second
) ((NPiecesByFile -> NPiecesByFile)
-> (NPiecesByFile, NPiecesByFile)
-> (NPiecesByFile, NPiecesByFile))
-> (NPiecesByFile -> NPiecesByFile)
-> (NPiecesByFile, NPiecesByFile)
-> (NPiecesByFile, NPiecesByFile)
forall a b. (a -> b) -> a -> b
$ X -> NPiecesByFile -> NPiecesByFile
accumulatePawnsByFile X
x
) ((X, Bool)
-> (NPiecesByFile, NPiecesByFile)
-> (NPiecesByFile, NPiecesByFile))
-> (LocatedPiece -> (X, Bool))
-> LocatedPiece
-> (NPiecesByFile, NPiecesByFile)
-> (NPiecesByFile, NPiecesByFile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (
Coordinates -> X
Cartesian.Coordinates.getX (Coordinates -> X) -> (Piece -> Bool) -> LocatedPiece -> (X, Bool)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** LogicalColour -> Bool
Colour.LogicalColour.isBlack (LogicalColour -> Bool)
-> (Piece -> LogicalColour) -> Piece -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> LogicalColour
Component.Piece.getLogicalColour
)
) (NPiecesByFile, NPiecesByFile)
forall a. Empty a => a
Property.Empty.empty ([LocatedPiece] -> (NPiecesByFile, NPiecesByFile))
-> (seeker -> [LocatedPiece])
-> seeker
-> (NPiecesByFile, NPiecesByFile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Piece -> Bool) -> seeker -> [LocatedPiece]
forall seeker.
Seeker seeker =>
(Piece -> Bool) -> seeker -> [LocatedPiece]
findPieces Piece -> Bool
Component.Piece.isPawn
findAllPieces :: Seeker seeker => seeker -> [Component.Piece.LocatedPiece]
findAllPieces :: seeker -> [LocatedPiece]
findAllPieces = (Piece -> Bool) -> seeker -> [LocatedPiece]
forall seeker.
Seeker seeker =>
(Piece -> Bool) -> seeker -> [LocatedPiece]
findPieces ((Piece -> Bool) -> seeker -> [LocatedPiece])
-> (Piece -> Bool) -> seeker -> [LocatedPiece]
forall a b. (a -> b) -> a -> b
$ Bool -> Piece -> Bool
forall a b. a -> b -> a
const Bool
True
summariseNPawnsByLogicalColour :: Seeker seeker => seeker -> Colour.LogicalColour.ArrayByLogicalColour Type.Count.NPieces
summariseNPawnsByLogicalColour :: seeker -> ArrayByLogicalColour X
summariseNPawnsByLogicalColour = (NPiecesByFile -> X)
-> NPiecesByFileByLogicalColour -> ArrayByLogicalColour X
forall (a :: * -> * -> *) e' e i.
(IArray a e', IArray a e, Ix i) =>
(e' -> e) -> a i e' -> a i e
Data.Array.IArray.amap (
(X -> X -> X) -> X -> NPiecesByFile -> X
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Data.Foldable.foldl' X -> X -> X
forall a. Num a => a -> a -> a
(+) X
0
) (NPiecesByFileByLogicalColour -> ArrayByLogicalColour X)
-> (seeker -> NPiecesByFileByLogicalColour)
-> seeker
-> ArrayByLogicalColour X
forall b c a. (b -> c) -> (a -> b) -> a -> c
. seeker -> NPiecesByFileByLogicalColour
forall seeker.
Seeker seeker =>
seeker -> NPiecesByFileByLogicalColour
countPawnsByFileByLogicalColour
findInvalidity :: Seeker seeker => seeker -> [String]
findInvalidity :: seeker -> [String]
findInvalidity = [(seeker -> Bool, String)] -> seeker -> [String]
forall selfValidator.
[(selfValidator -> Bool, String)] -> selfValidator -> [String]
Property.SelfValidating.findErrors [
(
(Bool -> Bool -> Bool) -> (Bool, Bool) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> Bool -> Bool
(||) ((Bool, Bool) -> Bool)
-> (seeker -> (Bool, Bool)) -> seeker -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Piece] -> Bool)
-> ([Piece] -> Bool) -> ([Piece], [Piece]) -> (Bool, Bool))
-> ([Piece] -> Bool, [Piece] -> Bool)
-> ([Piece], [Piece])
-> (Bool, Bool)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ([Piece] -> Bool)
-> ([Piece] -> Bool) -> ([Piece], [Piece]) -> (Bool, Bool)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
(***) (
([Piece] -> Bool) -> [Piece] -> Bool
forall a. a -> a
id (([Piece] -> Bool) -> [Piece] -> Bool)
-> (([Piece] -> Bool) -> [Piece] -> Bool)
-> ([Piece] -> Bool)
-> ([Piece] -> Bool, [Piece] -> Bool)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ([Piece] -> Bool) -> [Piece] -> Bool
forall a. a -> a
id (([Piece] -> Bool) -> ([Piece] -> Bool, [Piece] -> Bool))
-> ([Piece] -> Bool) -> ([Piece] -> Bool, [Piece] -> Bool)
forall a b. (a -> b) -> a -> b
$ (X -> X -> Bool
forall a. Ord a => a -> a -> Bool
> ArrayByRank X
Attribute.Rank.initialAllocationByRankPerSide ArrayByRank X -> Rank -> X
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
! Rank
Attribute.Rank.Pawn) (X -> Bool) -> ([Piece] -> X) -> [Piece] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. X -> X
forall a b. (Integral a, Num b) => a -> b
fromIntegral (X -> X) -> ([Piece] -> X) -> [Piece] -> X
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Piece] -> X
forall (t :: * -> *) a. Foldable t => t a -> X
length
) (([Piece], [Piece]) -> (Bool, Bool))
-> (seeker -> ([Piece], [Piece])) -> seeker -> (Bool, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Piece -> Bool) -> [Piece] -> ([Piece], [Piece])
forall a. (a -> Bool) -> [a] -> ([a], [a])
Data.List.partition (
LogicalColour -> Bool
Colour.LogicalColour.isBlack (LogicalColour -> Bool)
-> (Piece -> LogicalColour) -> Piece -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Piece -> LogicalColour
Component.Piece.getLogicalColour
) ([Piece] -> ([Piece], [Piece]))
-> (seeker -> [Piece]) -> seeker -> ([Piece], [Piece])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LocatedPiece -> Piece) -> [LocatedPiece] -> [Piece]
forall a b. (a -> b) -> [a] -> [b]
map LocatedPiece -> Piece
forall a b. (a, b) -> b
snd ([LocatedPiece] -> [Piece])
-> (seeker -> [LocatedPiece]) -> seeker -> [Piece]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Piece -> Bool) -> seeker -> [LocatedPiece]
forall seeker.
Seeker seeker =>
(Piece -> Bool) -> seeker -> [LocatedPiece]
findPieces Piece -> Bool
Component.Piece.isPawn,
String
"there are too many Pawns of at least one logical colour."
), (
(LocatedPiece -> Bool) -> [LocatedPiece] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (
(Bool -> Bool -> Bool) -> (Bool, Bool) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Bool -> Bool -> Bool
(||) ((Bool, Bool) -> Bool)
-> (LocatedPiece -> (Bool, Bool)) -> LocatedPiece -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((X -> Bool) -> (X -> Bool) -> X -> (Bool, Bool))
-> (X -> Bool, X -> Bool) -> X -> (Bool, Bool)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (X -> Bool) -> (X -> Bool) -> X -> (Bool, Bool)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
(&&&) (
X -> X -> Bool
forall a. Eq a => a -> a -> Bool
(==) (X -> X -> Bool)
-> (X -> X -> Bool) -> (X, X) -> (X -> Bool, X -> Bool)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** X -> X -> Bool
forall a. Eq a => a -> a -> Bool
(==) ((X, X) -> (X -> Bool, X -> Bool))
-> (X, X) -> (X -> Bool, X -> Bool)
forall a b. (a -> b) -> a -> b
$ (X, X)
Cartesian.Ordinate.yBounds
) (X -> (Bool, Bool))
-> (LocatedPiece -> X) -> LocatedPiece -> (Bool, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates -> X
Cartesian.Coordinates.getY (Coordinates -> X)
-> (LocatedPiece -> Coordinates) -> LocatedPiece -> X
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocatedPiece -> Coordinates
forall a b. (a, b) -> a
fst
) ([LocatedPiece] -> Bool)
-> (seeker -> [LocatedPiece]) -> seeker -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Piece -> Bool) -> seeker -> [LocatedPiece]
forall seeker.
Seeker seeker =>
(Piece -> Bool) -> seeker -> [LocatedPiece]
findPieces Piece -> Bool
Component.Piece.isPawn,
String
"no Pawn can exist on either of the terminal ranks."
)
]