{-# LANGUAGE ScopedTypeVariables #-}
module BishBosh.Evaluation.Fitness(
maximumDefended,
measurePieceSquareValue,
measurePieceSquareValueIncrementally,
measureValueOfMaterial,
measureValueOfCastlingPotential,
measureValueOfDefence,
measureValueOfDoubledPawns,
measureValueOfIsolatedPawns,
measureValueOfPassedPawns,
evaluateFitness
) where
import Control.Applicative((<|>))
import Control.Arrow((&&&))
import Data.Array.IArray((!))
import qualified BishBosh.Attribute.CriterionValue as Attribute.CriterionValue
import qualified BishBosh.Attribute.Direction as Attribute.Direction
import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour
import qualified BishBosh.Attribute.MoveType as Attribute.MoveType
import qualified BishBosh.Attribute.RankValues as Attribute.RankValues
import qualified BishBosh.Attribute.WeightedMeanAndCriterionValues as Attribute.WeightedMeanAndCriterionValues
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.Component.Move as Component.Move
import qualified BishBosh.Component.Piece as Component.Piece
import qualified BishBosh.Component.PieceSquareArray as Component.PieceSquareArray
import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove
import qualified BishBosh.Component.Turn as Component.Turn
import qualified BishBosh.Input.CriteriaWeights as Input.CriteriaWeights
import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions
import qualified BishBosh.Model.Game as Model.Game
import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason
import qualified BishBosh.Property.Opposable as Property.Opposable
import qualified BishBosh.State.Board as State.Board
import qualified BishBosh.State.CastleableRooksByLogicalColour as State.CastleableRooksByLogicalColour
import qualified BishBosh.Types as T
import qualified Control.Monad.Reader
import qualified Data.Array.IArray
import qualified Data.List
import qualified Data.Map
import qualified Data.Maybe
mkPieceSquareCriterionValue :: (
Fractional criterionValue,
Ord criterionValue,
Real pieceSquareValue
) => pieceSquareValue -> Attribute.CriterionValue.CriterionValue criterionValue
mkPieceSquareCriterionValue = Attribute.CriterionValue.mkCriterionValue . (
/ fromIntegral Component.Piece.nPiecesPerSide
) . realToFrac
measurePieceSquareValue :: (
Enum x,
Enum y,
Num pieceSquareValue,
Ord x,
Ord y
)
=> Component.PieceSquareArray.PieceSquareArray x y pieceSquareValue
-> Model.Game.Game x y
-> pieceSquareValue
{-# SPECIALISE measurePieceSquareValue :: Component.PieceSquareArray.PieceSquareArray T.X T.Y T.PieceSquareValue -> Model.Game.Game T.X T.Y -> T.PieceSquareValue #-}
measurePieceSquareValue pieceSquareArray game
| Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game = difference
| otherwise = negate difference
where
[blacksPieceSquareValue, whitesPieceSquareValue] = Data.Array.IArray.elems . State.Board.sumPieceSquareValueByLogicalColour pieceSquareArray $ Model.Game.getBoard game
difference = whitesPieceSquareValue - blacksPieceSquareValue
measurePieceSquareValueIncrementally :: (
Enum x,
Enum y,
Num pieceSquareValue,
Ord x,
Ord y
)
=> pieceSquareValue
-> Component.PieceSquareArray.PieceSquareArray x y pieceSquareValue
-> Model.Game.Game x y
-> pieceSquareValue
{-# SPECIALISE measurePieceSquareValueIncrementally :: T.PieceSquareValue -> Component.PieceSquareArray.PieceSquareArray T.X T.Y T.PieceSquareValue -> Model.Game.Game T.X T.Y -> T.PieceSquareValue #-}
measurePieceSquareValueIncrementally previousPieceSquareValue pieceSquareArray game
| Attribute.MoveType.isQuiet $ Component.QualifiedMove.getMoveType qualifiedMove = let
findPieceSquareValue coordinates = Component.PieceSquareArray.findPieceSquareValue (
State.Board.getNPieces $ Model.Game.getBoard game
) (
Property.Opposable.getOpposite $ Model.Game.getNextLogicalColour game
) (
Component.Turn.getRank turn
) coordinates pieceSquareArray
in uncurry (-) (
findPieceSquareValue . Component.Move.getDestination &&& findPieceSquareValue . Component.Move.getSource $ Component.QualifiedMove.getMove qualifiedMove
) - previousPieceSquareValue
| otherwise = measurePieceSquareValue pieceSquareArray game
where
Just turn = Model.Game.maybeLastTurn game
qualifiedMove = Component.Turn.getQualifiedMove turn
measureValueOfMaterial :: (
Fractional criterionValue,
Fractional rankValue,
Ord criterionValue,
Real rankValue
)
=> Attribute.RankValues.RankValues rankValue
-> Model.Game.Game x y
-> Attribute.CriterionValue.CriterionValue criterionValue
measureValueOfMaterial rankValues game = Attribute.CriterionValue.mkCriterionValue . (
/ fromIntegral Component.Piece.nPiecesPerSide
) . realToFrac . (
if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game
then id
else negate
) . Data.List.foldl' (
\acc (rank, nPieces) -> if nPieces == 0
then acc
else acc + Attribute.RankValues.findRankValue rank rankValues * fromIntegral nPieces
) 0 . Data.Array.IArray.assocs . State.Board.getNPiecesDifferenceByRank $ Model.Game.getBoard game
measureValueOfMobility :: (
Enum x,
Enum y,
Fractional criterionValue,
Ord criterionValue,
Ord x,
Ord y,
Show x,
Show y
) => Model.Game.Game x y -> Attribute.CriterionValue.CriterionValue criterionValue
{-# SPECIALISE measureValueOfMobility :: Model.Game.Game T.X T.Y -> Attribute.CriterionValue.CriterionValue T.CriterionValue #-}
measureValueOfMobility game = Attribute.CriterionValue.mkCriterionValue . uncurry (-) . (
measureConstriction &&& measureConstriction . Property.Opposable.getOpposite
) $ Model.Game.getNextLogicalColour game where
measureConstriction logicalColour = recip . fromIntegral . succ $ Model.Game.countMovesAvailableTo logicalColour game
measureValueOfCastlingPotential :: (
Fractional criterionValue,
Ord criterionValue
) => Model.Game.Game x y -> Attribute.CriterionValue.CriterionValue criterionValue
measureValueOfCastlingPotential game = Attribute.CriterionValue.mkCriterionValue . uncurry (-) . (
castlingPotential . Property.Opposable.getOpposite &&& castlingPotential
) $ Model.Game.getNextLogicalColour game where
castlingPotential = Data.Maybe.maybe 1 (
(/ 2) . fromIntegral . length
) . (
`State.CastleableRooksByLogicalColour.locateForLogicalColour` Model.Game.getCastleableRooksByLogicalColour game
)
measureValueOfDoubledPawns :: (
Fractional criterionValue,
Ord criterionValue
) => Model.Game.Game x y -> Attribute.CriterionValue.CriterionValue criterionValue
measureValueOfDoubledPawns game = Attribute.CriterionValue.mkCriterionValue . (
/ 6
) . fromIntegral . uncurry (-) . (
countDoubledPawns &&& countDoubledPawns . Property.Opposable.getOpposite
) $ Model.Game.getNextLogicalColour game where
countDoubledPawns logicalColour = uncurry (-) . (
Data.Map.foldl' (+) 0 &&& Data.Map.size
) $ State.Board.getNPawnsByFileByLogicalColour (Model.Game.getBoard game) ! logicalColour
measureValueOfIsolatedPawns :: (
Enum x,
Fractional criterionValue,
Ord criterionValue,
Ord x
) => Model.Game.Game x y -> Attribute.CriterionValue.CriterionValue criterionValue
{-# SPECIALISE measureValueOfIsolatedPawns :: Model.Game.Game T.X T.Y -> Attribute.CriterionValue.CriterionValue T.CriterionValue #-}
measureValueOfIsolatedPawns game = Attribute.CriterionValue.mkCriterionValue . (
/ fromIntegral Cartesian.Abscissa.xLength
) . fromIntegral . uncurry (-) . (
countIsolatedPawns &&& countIsolatedPawns . Property.Opposable.getOpposite
) $ Model.Game.getNextLogicalColour game where
countIsolatedPawns :: Attribute.LogicalColour.LogicalColour -> Component.Piece.NPieces
countIsolatedPawns logicalColour = Data.Map.foldlWithKey' (
\acc x nPawns -> (
if (`Data.Map.notMember` nPawnsByFile) `all` Cartesian.Abscissa.getAdjacents x
then (+ nPawns)
else id
) acc
) 0 nPawnsByFile where
nPawnsByFile = State.Board.getNPawnsByFileByLogicalColour (Model.Game.getBoard game) ! logicalColour
measureValueOfPassedPawns :: forall x y criterionValue. (
Enum y,
Fractional criterionValue,
Ord criterionValue
) => Model.Game.Game x y -> Attribute.CriterionValue.CriterionValue criterionValue
{-# SPECIALISE measureValueOfPassedPawns :: Model.Game.Game T.X T.Y -> Attribute.CriterionValue.CriterionValue T.CriterionValue #-}
measureValueOfPassedPawns game = Attribute.CriterionValue.mkCriterionValue . (
/ fromIntegral Cartesian.Abscissa.xLength
) . uncurry (-) . (
valuePassedPawns . Property.Opposable.getOpposite &&& valuePassedPawns
) $ Model.Game.getNextLogicalColour game where
valuePassedPawns :: Attribute.LogicalColour.LogicalColour -> criterionValue
valuePassedPawns logicalColour = Data.List.foldl' (
\acc -> (acc +) . recip . fromIntegral . abs . (
+ fromEnum (
Cartesian.Ordinate.lastRank logicalColour :: y
)
) . negate . fromEnum . Cartesian.Coordinates.getY
) 0 $ State.Board.getPassedPawnCoordinatesByLogicalColour (Model.Game.getBoard game) ! logicalColour
maximumDefended :: Component.Piece.NPieces
maximumDefended = (9 + 1 + 2 + 2 ) * Attribute.Direction.nDistinctDirections
measureValueOfDefence :: (
Fractional criterionValue,
Ord criterionValue
) => Model.Game.Game x y -> Attribute.CriterionValue.CriterionValue criterionValue
measureValueOfDefence game = Attribute.CriterionValue.mkCriterionValue . (
/ fromIntegral maximumDefended
) . fromIntegral . uncurry (-) . (
(! Property.Opposable.getOpposite nextLogicalColour) &&& (! nextLogicalColour)
) . State.Board.summariseNDefendersByLogicalColour $ Model.Game.getBoard game where
nextLogicalColour = Model.Game.getNextLogicalColour game
evaluateFitness :: (
Enum x,
Enum y,
Fractional criterionValue,
Fractional pieceSquareValue,
Fractional rankValue,
Fractional weightedMean,
Ord x,
Ord y,
Real criterionValue,
Real criterionWeight,
Real pieceSquareValue,
Real rankValue,
Show x,
Show y
)
=> Maybe pieceSquareValue
-> Model.Game.Game x y
-> Input.EvaluationOptions.Reader criterionWeight pieceSquareValue rankValue x y (
Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues weightedMean criterionValue
)
{-# SPECIALISE evaluateFitness :: Maybe T.PieceSquareValue -> Model.Game.Game T.X T.Y -> Input.EvaluationOptions.Reader T.CriterionWeight T.PieceSquareValue T.RankValue T.X T.Y (Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues T.WeightedMean T.CriterionValue) #-}
evaluateFitness maybePieceSquareValue game
| Just gameTerminationReason <- Model.Game.getMaybeTerminationReason game = return $ Attribute.WeightedMeanAndCriterionValues.mkWeightedMeanAndCriterionValues (
if Model.GameTerminationReason.isCheckMate gameTerminationReason
then 1
else 0
) []
| otherwise = do
criteriaWeights <- Control.Monad.Reader.asks Input.EvaluationOptions.getCriteriaWeights
rankValues <- Control.Monad.Reader.asks Input.EvaluationOptions.getRankValues
maybePieceSquareArray <- Control.Monad.Reader.asks Input.EvaluationOptions.getMaybePieceSquareArray
return $ Input.CriteriaWeights.calculateWeightedMean criteriaWeights (
measureValueOfMaterial rankValues game
) (
measureValueOfMobility game
) (
Data.Maybe.maybe Attribute.CriterionValue.zero mkPieceSquareCriterionValue $ maybePieceSquareValue <|> fmap (
`measurePieceSquareValue` game
) maybePieceSquareArray
) (
measureValueOfCastlingPotential game
) (
measureValueOfDefence game
) (
measureValueOfDoubledPawns game
) (
measureValueOfIsolatedPawns game
) (
measureValueOfPassedPawns game
)