{-
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 .
-}
{- |
[@AUTHOR@] Dr. Alistair Ward
[@DESCRIPTION@] Defines the weight associated with each criterion.
-}
module BishBosh.Input.CriteriaWeights(
-- * Types
-- ** Type-synonyms
-- Transformation,
-- ** Data-types
CriteriaWeights(
-- MkCriteriaWeights,
getWeightOfMaterial,
getWeightOfMobility,
getWeightOfPieceSquareValue,
getWeightOfCastlingPotential,
getWeightOfDefence,
getWeightOfDoubledPawns,
getWeightOfIsolatedPawns,
getWeightOfPassedPawns
),
-- * Constants
tag,
weightOfMaterialTag,
-- weightOfMobilityTag,
weightOfPieceSquareValueTag,
-- weightOfCastlingPotentialTag,
-- weightOfDefenceTag,
-- weightOfDoubledPawnsTag,
-- weightOfIsolatedPawnsTag,
-- weightOfPassedPawnsTag,
onymousOperators,
-- * Functions
calculateWeightedMean,
normalise,
perturbWeights,
-- ** Constructor
mkCriteriaWeights
) where
import qualified BishBosh.Attribute.CriterionValue as Attribute.CriterionValue
import qualified BishBosh.Attribute.CriterionWeight as Attribute.CriterionWeight
import qualified BishBosh.Attribute.WeightedMeanAndCriterionValues as Attribute.WeightedMeanAndCriterionValues
import qualified BishBosh.Data.Exception as Data.Exception
import qualified BishBosh.Property.ShowFloat as Property.ShowFloat
import qualified BishBosh.Text.ShowList as Text.ShowList
import qualified BishBosh.Types as T
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Control.Exception
import qualified Data.Default
import qualified System.Random
import qualified Text.XML.HXT.Arrow.Pickle as HXT
-- | Used to qualify the XML.
tag :: String
tag = "criteriaWeights"
-- | Used to qualify the XML.
weightOfMaterialTag :: String
weightOfMaterialTag = "material"
-- | Used to qualify the XML.
weightOfMobilityTag :: String
weightOfMobilityTag = "mobility"
-- | Used to qualify the XML.
weightOfPieceSquareValueTag :: String
weightOfPieceSquareValueTag = "pieceSquareValue"
-- | Used to qualify the XML.
weightOfCastlingPotentialTag :: String
weightOfCastlingPotentialTag = "castlingPotential"
-- | Used to qualify the XML.
weightOfDefenceTag :: String
weightOfDefenceTag = "defence"
-- | Used to qualify the XML.
weightOfDoubledPawnsTag :: String
weightOfDoubledPawnsTag = "doubledPawns"
-- | Used to qualify the XML.
weightOfIsolatedPawnsTag :: String
weightOfIsolatedPawnsTag = "isolatedPawns"
-- | Used to qualify the XML.
weightOfPassedPawnsTag :: String
weightOfPassedPawnsTag = "passedPawns"
{- |
* The weight of various criteria used to select a move from alternatives, at specific point in the game.
* CAVEAT: these weights determine the effective value of /isolated/ or /doubled/ @Pawn@s,
& this value shouldn't be less than their weighted normalised /rank-value/, otherwise sacrifice would be beneficial.
-}
data CriteriaWeights criterionWeight = MkCriteriaWeights {
getWeightOfMaterial :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ The arithmetic difference between the total /rank-value/ of the /piece/s currently in play on either side; .
getWeightOfMobility :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ The arithmetic difference between the reciprocal of the number of destinations available to the /piece/s of either side. N.B. this weight can be derived from 'getWeightOfMaterial' since losing a @Queen@ is less significant than reducing mobility to zero; .
getWeightOfPieceSquareValue :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ The arithmetic difference in the values of the squares occupied by the pieces of either side.
getWeightOfCastlingPotential :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ Whether each player has been permanently prevented from /Castling/.
getWeightOfDefence :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ The arithmetic difference between the number of /piece/s defending each of one's own, compared with the opponent.
getWeightOfDoubledPawns :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ The arithmetic difference between the total number of /doubled/ @Pawn@s on either side; .
getWeightOfIsolatedPawns :: Attribute.CriterionWeight.CriterionWeight criterionWeight, -- ^ The arithmetic difference between the total number of /isolated/ @Pawn@s on either side; .
getWeightOfPassedPawns :: Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ The arithmetic difference between the total number of /passed/ @Pawn@s on either side; .
} deriving (Eq, Show)
-- | Smart-constructor.
mkCriteriaWeights
:: (Eq criterionWeight, Num criterionWeight)
=> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /material/.
-> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /mobility/.
-> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /pieceSquareValue/.
-> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /castlingPotential/.
-> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /defence/.
-> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /doubledPawns/.
-> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /isolatedPawns/.
-> Attribute.CriterionWeight.CriterionWeight criterionWeight -- ^ /passedPawns/.
-> CriteriaWeights criterionWeight
mkCriteriaWeights a b c d e f g h
| criteriaWeights == minBound = Control.Exception.throw $ Data.Exception.mkInvalidDatum "BishBosh.Input.CriteriaWeights.mkCriteriaWeights:\tall weights are zero."
| otherwise = criteriaWeights
where
criteriaWeights = MkCriteriaWeights a b c d e f g h
instance Real criterionWeight => Property.ShowFloat.ShowFloat (CriteriaWeights criterionWeight) where
showsFloat fromDouble MkCriteriaWeights {
getWeightOfMaterial = weightOfMaterial,
getWeightOfMobility = weightOfMobility,
getWeightOfPieceSquareValue = weightOfPieceSquareValue,
getWeightOfCastlingPotential = weightOfCastlingPotential,
getWeightOfDefence = weightOfDefence,
getWeightOfDoubledPawns = weightOfDoubledPawns,
getWeightOfIsolatedPawns = weightOfIsolatedPawns,
getWeightOfPassedPawns = weightOfPassedPawns
} = Text.ShowList.showsAssociationList' $ map (
Control.Arrow.second $ fromDouble . realToFrac . Attribute.CriterionWeight.deconstruct
) [
(
weightOfMaterialTag, weightOfMaterial
), (
weightOfMobilityTag, weightOfMobility
), (
weightOfPieceSquareValueTag, weightOfPieceSquareValue
), (
weightOfCastlingPotentialTag, weightOfCastlingPotential
), (
weightOfDefenceTag, weightOfDefence
), (
weightOfDoubledPawnsTag, weightOfDoubledPawns
), (
weightOfIsolatedPawnsTag, weightOfIsolatedPawns
), (
weightOfPassedPawnsTag, weightOfPassedPawns
)
]
instance Num criterionWeight => Data.Default.Default (CriteriaWeights criterionWeight) where
def = MkCriteriaWeights {
getWeightOfMaterial = maxBound,
getWeightOfMobility = Data.Default.def,
getWeightOfPieceSquareValue = Data.Default.def,
getWeightOfCastlingPotential = Data.Default.def,
getWeightOfDefence = Data.Default.def,
getWeightOfDoubledPawns = Data.Default.def,
getWeightOfIsolatedPawns = Data.Default.def,
getWeightOfPassedPawns = Data.Default.def
}
instance Control.DeepSeq.NFData criterionWeight => Control.DeepSeq.NFData (CriteriaWeights criterionWeight) where
rnf (MkCriteriaWeights a b c d e f g h) = Control.DeepSeq.rnf [a, b, c, d, e, f, g, h]
instance Num criterionWeight => Bounded (CriteriaWeights criterionWeight) where
maxBound = MkCriteriaWeights maxBound maxBound maxBound maxBound maxBound maxBound maxBound maxBound
minBound = MkCriteriaWeights minBound minBound minBound minBound minBound minBound minBound minBound
instance (
HXT.XmlPickler criterionWeight,
Num criterionWeight,
Ord criterionWeight,
Show criterionWeight
) => HXT.XmlPickler (CriteriaWeights criterionWeight) where
xpickle = HXT.xpDefault Data.Default.def . HXT.xpElem tag $ HXT.xpWrap (
\(a, b, c, d, e, f, g, h) -> mkCriteriaWeights a b c d e f g h, -- Construct.
\MkCriteriaWeights {
getWeightOfMaterial = weightOfMaterial,
getWeightOfMobility = weightOfMobility,
getWeightOfPieceSquareValue = weightOfPieceSquareValue,
getWeightOfCastlingPotential = weightOfCastlingPotential,
getWeightOfDefence = weightOfDefence,
getWeightOfDoubledPawns = weightOfDoubledPawns,
getWeightOfIsolatedPawns = weightOfIsolatedPawns,
getWeightOfPassedPawns = weightOfPassedPawns
} -> (
weightOfMaterial,
weightOfMobility,
weightOfPieceSquareValue,
weightOfCastlingPotential,
weightOfDefence,
weightOfDoubledPawns,
weightOfIsolatedPawns,
weightOfPassedPawns
) -- Deconstruct.
) $ HXT.xp8Tuple (
xpickle' weightOfMaterialTag
) (
xpickle' weightOfMobilityTag
) (
xpickle' weightOfPieceSquareValueTag
) (
xpickle' weightOfCastlingPotentialTag
) (
xpickle' weightOfDefenceTag
) (
xpickle' weightOfDoubledPawnsTag
) (
xpickle' weightOfIsolatedPawnsTag
) (
xpickle' weightOfPassedPawnsTag
) where
xpickle' = HXT.xpDefault Data.Default.def . (`HXT.xpAttr` HXT.xpickle)
{- |
* Returns the weighted sum of the specified criteria, divided by the sum of the weights;
* Each criterion increases in proportion to some desirable attribute of the proposed /game/.
* Each criterion should be in the same range of magnitudes, so that none dominates the total, thus making the total a clear measure of the value attributed to each.
* Also writes individual unweighted /criterion-value/s, to facilitate post-analysis; if the corresponding weight is zero, for efficiency evaluation of the criterion is avoided.
-}
calculateWeightedMean :: (
Fractional weightedMean,
Real criterionValue,
Real criterionWeight
)
=> CriteriaWeights criterionWeight
-> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /material/: maximum if a player's /move/ equals the maximum total piece value (including /queened/ @Pawn@s), while their opponent has just a @King@.
-> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /mobility/: maximum when the opponent is check-mated.
-> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /pieceSquareValue/: maximum when this player occupies all the strategically important squares & the opponent none.
-> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /castlingPotential/: maximum when this player either has /castled/ or can, but the opponent has been permanently prevented.
-> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /defence/: maximum when this player's /piece/s are fully utilised in defence, but none of the opponent's are.
-> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /doubledPawns/: maximum when this player hasn't any /doubled/ @Pawn@s & the opponent has two files of four @Pawn@s.
-> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /isolatedPawns/: maximum when this player hasn't any /isolated/ @Pawn@s & all the opponent's @Pawn@s are /isolated/.
-> Attribute.CriterionValue.CriterionValue criterionValue -- ^ /passedPawns/: maximum when this player has 8 /passed/ @Pawn@s & the opponent has none.
-> Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues weightedMean criterionValue -- ^ The individual /criteria/ values, & their /weighted mean/.
{-# SPECIALISE calculateWeightedMean
:: CriteriaWeights T.CriterionWeight
-> Attribute.CriterionValue.CriterionValue T.CriterionValue
-> Attribute.CriterionValue.CriterionValue T.CriterionValue
-> Attribute.CriterionValue.CriterionValue T.CriterionValue
-> Attribute.CriterionValue.CriterionValue T.CriterionValue
-> Attribute.CriterionValue.CriterionValue T.CriterionValue
-> Attribute.CriterionValue.CriterionValue T.CriterionValue
-> Attribute.CriterionValue.CriterionValue T.CriterionValue
-> Attribute.CriterionValue.CriterionValue T.CriterionValue
-> Attribute.WeightedMeanAndCriterionValues.WeightedMeanAndCriterionValues T.WeightedMean T.CriterionValue
#-}
calculateWeightedMean MkCriteriaWeights {
getWeightOfMaterial = weightOfMaterial,
getWeightOfMobility = weightOfMobility,
getWeightOfPieceSquareValue = weightOfPieceSquareValue,
getWeightOfCastlingPotential = weightOfCastlingPotential,
getWeightOfDefence = weightOfDefence,
getWeightOfDoubledPawns = weightOfDoubledPawns,
getWeightOfIsolatedPawns = weightOfIsolatedPawns,
getWeightOfPassedPawns = weightOfPassedPawns
} material mobility pieceSquareValue castlingPotential defence doubledPawns isolatedPawns passedPawns = Attribute.CriterionValue.calculateWeightedMean [
(
material, weightOfMaterial
), (
mobility, weightOfMobility
), (
pieceSquareValue, weightOfPieceSquareValue
), (
castlingPotential, weightOfCastlingPotential
), (
defence, weightOfDefence
), (
doubledPawns, weightOfDoubledPawns
), (
isolatedPawns, weightOfIsolatedPawns
), (
passedPawns, weightOfPassedPawns
)
]
-- | The type of a function which mutates 'CriteriaWeights'.
type Transformation criterionWeight = CriteriaWeights criterionWeight -> CriteriaWeights criterionWeight
-- | Adjust the mean weight, so that the maximum weight is @1@.
normalise :: (
Fractional criterionWeight,
Ord criterionWeight,
Show criterionWeight
) => Transformation criterionWeight
normalise criteriaWeights@MkCriteriaWeights {
getWeightOfMaterial = weightOfMaterial,
getWeightOfMobility = weightOfMobility,
getWeightOfPieceSquareValue = weightOfPieceSquareValue,
getWeightOfCastlingPotential = weightOfCastlingPotential,
getWeightOfDefence = weightOfDefence,
getWeightOfDoubledPawns = weightOfDoubledPawns,
getWeightOfIsolatedPawns = weightOfIsolatedPawns,
getWeightOfPassedPawns = weightOfPassedPawns
} = Control.Exception.assert (
criteriaWeights /= minBound -- Guard against divide-by-zero.
) MkCriteriaWeights {
getWeightOfMaterial = normaliseCriterionWeight weightOfMaterial,
getWeightOfMobility = normaliseCriterionWeight weightOfMobility,
getWeightOfPieceSquareValue = normaliseCriterionWeight weightOfPieceSquareValue,
getWeightOfCastlingPotential = normaliseCriterionWeight weightOfCastlingPotential,
getWeightOfDefence = normaliseCriterionWeight weightOfDefence,
getWeightOfDoubledPawns = normaliseCriterionWeight weightOfDoubledPawns,
getWeightOfIsolatedPawns = normaliseCriterionWeight weightOfIsolatedPawns,
getWeightOfPassedPawns = normaliseCriterionWeight weightOfPassedPawns
} where
normaliseCriterionWeight = Attribute.CriterionWeight.mkCriterionWeight . (
/ Attribute.CriterionWeight.deconstruct (
maximum [
weightOfMaterial,
weightOfMobility,
weightOfPieceSquareValue,
weightOfCastlingPotential,
weightOfDefence,
weightOfDoubledPawns,
weightOfIsolatedPawns,
weightOfPassedPawns
]
)
) . Attribute.CriterionWeight.deconstruct
{- |
* Independently perturbs each /criterion-weight/ by a random value, of configurable magnitude.
* Under this transformation, /criterion-weight/s of @0@, will remain unchanged, thus irrelevant criteria remain irrelevant.
-}
perturbWeights :: (
Fractional criterionWeight,
Real criterionWeight,
Show criterionWeight,
System.Random.RandomGen randomGen
)
=> randomGen
-> criterionWeight -- ^ Change-magnitude.
-> Transformation criterionWeight
perturbWeights _ 0 criteriaWeights = criteriaWeights
perturbWeights randomGen changeMagnitude MkCriteriaWeights {
getWeightOfMaterial = weightOfMaterial,
getWeightOfMobility = weightOfMobility,
getWeightOfPieceSquareValue = weightOfPieceSquareValue,
getWeightOfCastlingPotential = weightOfCastlingPotential,
getWeightOfDefence = weightOfDefence,
getWeightOfDoubledPawns = weightOfDoubledPawns,
getWeightOfIsolatedPawns = weightOfIsolatedPawns,
getWeightOfPassedPawns = weightOfPassedPawns
} = Control.Exception.assert (changeMagnitude > 0) $ normalise MkCriteriaWeights {
getWeightOfMaterial = reduceBy a weightOfMaterial,
getWeightOfMobility = reduceBy b weightOfMobility,
getWeightOfPieceSquareValue = reduceBy c weightOfPieceSquareValue,
getWeightOfCastlingPotential = reduceBy d weightOfCastlingPotential,
getWeightOfDefence = reduceBy e weightOfDefence,
getWeightOfDoubledPawns = reduceBy f weightOfDoubledPawns,
getWeightOfIsolatedPawns = reduceBy g weightOfIsolatedPawns,
getWeightOfPassedPawns = reduceBy h weightOfPassedPawns
} where
(a : b : c : d : e : f : g : h : _) = System.Random.randomRs (1 :: Double, succ $ realToFrac changeMagnitude) randomGen
reduceBy randomValue = Attribute.CriterionWeight.mkCriterionWeight . (/ realToFrac randomValue) . Attribute.CriterionWeight.deconstruct -- N.B. this always reduces the weight, leaving 'normalise' to correct this.
-- | A list of named accessors & mutators.
onymousOperators :: [
(
String, -- Tag.
CriteriaWeights criterionWeight -> Attribute.CriterionWeight.CriterionWeight criterionWeight, -- Accessor.
Attribute.CriterionWeight.CriterionWeight criterionWeight -> Transformation criterionWeight -- Mutator.
) -- Triple.
]
onymousOperators = [
(
weightOfMaterialTag,
getWeightOfMaterial,
\w criteriaWeights -> criteriaWeights { getWeightOfMaterial = w }
), (
weightOfMobilityTag,
getWeightOfMobility,
\w criteriaWeights -> criteriaWeights { getWeightOfMobility = w }
), (
weightOfPieceSquareValueTag,
getWeightOfPieceSquareValue,
\w criteriaWeights -> criteriaWeights { getWeightOfPieceSquareValue = w }
), (
weightOfCastlingPotentialTag,
getWeightOfCastlingPotential,
\w criteriaWeights -> criteriaWeights { getWeightOfCastlingPotential = w }
), (
weightOfDefenceTag,
getWeightOfDefence,
\w criteriaWeights -> criteriaWeights { getWeightOfDefence = w }
), (
weightOfDoubledPawnsTag,
getWeightOfDoubledPawns,
\w criteriaWeights -> criteriaWeights { getWeightOfDoubledPawns = w }
), (
weightOfIsolatedPawnsTag,
getWeightOfIsolatedPawns,
\w criteriaWeights -> criteriaWeights { getWeightOfIsolatedPawns = w }
), (
weightOfPassedPawnsTag,
getWeightOfPassedPawns,
\w criteriaWeights -> criteriaWeights { getWeightOfPassedPawns = w }
)
]