{-
	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@]	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; <https://chessprogramming.wikispaces.com/Material>.
	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; <https://chessprogramming.wikispaces.com/Mobility>.
	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; <https://chessprogramming.wikispaces.com/Doubled+Pawn>.
	getWeightOfIsolatedPawns	:: Attribute.CriterionWeight.CriterionWeight criterionWeight,	-- ^ The arithmetic difference between the total number of /isolated/ @Pawn@s on either side; <https://chessprogramming.wikispaces.com/Isolated+Pawn>.
	getWeightOfPassedPawns		:: Attribute.CriterionWeight.CriterionWeight criterionWeight	-- ^ The arithmetic difference between the total number of /passed/ @Pawn@s on either side; <https://chessprogramming.wikispaces.com/Passed+Pawn>.
} 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; <https://chessprogramming.wikispaces.com/evaluation>

	* 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 }
	)
 ]