module BishBosh.Evaluation.PositionHashQuantifiedGameTree(
Forest,
NodeLabel(
getPositionHash,
getQuantifiedGame
),
PositionHashQuantifiedGameTree(
MkPositionHashQuantifiedGameTree,
deconstruct
),
reduce,
traceRoute,
resign,
traceMatchingMoves,
promoteMatchingMoves,
sortNonCaptureMoves,
getRootQuantifiedGame',
getRootPositionHash,
getRootQuantifiedGame,
fromBarePositionHashQuantifiedGameTree,
mkPositionHashQuantifiedGameTree
) where
import Control.Arrow((&&&))
import qualified BishBosh.Attribute.RankValues as Attribute.RankValues
import qualified BishBosh.Attribute.WeightedMeanAndCriterionValues as Attribute.WeightedMeanAndCriterionValues
import qualified BishBosh.Component.Move as Component.Move
import qualified BishBosh.Component.QualifiedMove as Component.QualifiedMove
import qualified BishBosh.Component.Turn as Component.Turn
import qualified BishBosh.Component.Zobrist as Component.Zobrist
import qualified BishBosh.Data.RoseTree as Data.RoseTree
import qualified BishBosh.Evaluation.Fitness as Evaluation.Fitness
import qualified BishBosh.Evaluation.QuantifiedGame as Evaluation.QuantifiedGame
import qualified BishBosh.Input.EvaluationOptions as Input.EvaluationOptions
import qualified BishBosh.Input.SearchOptions as Input.SearchOptions
import qualified BishBosh.Model.Game as Model.Game
import qualified BishBosh.Model.GameTree as Model.GameTree
import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation
import qualified BishBosh.Property.Null as Property.Null
import qualified BishBosh.Property.Tree as Property.Tree
import qualified BishBosh.Types as T
import qualified Control.Arrow
import qualified Control.Monad.Reader
import qualified Data.Array.IArray
import qualified Data.Bits
import qualified Data.Maybe
import qualified Data.Tree
data NodeLabel x y positionHash criterionValue weightedMean = MkNodeLabel {
getPositionHash :: positionHash,
getQuantifiedGame :: Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean
} deriving (Eq, Show)
instance (Enum x, Enum y, Real weightedMean) => Notation.MoveNotation.ShowNotationFloat (NodeLabel x y positionHash criterionValue weightedMean) where
showsNotationFloat moveNotation showsDouble MkNodeLabel { getQuantifiedGame = quantifiedGame } = Notation.MoveNotation.showsNotation moveNotation (
Evaluation.QuantifiedGame.getLastTurn quantifiedGame
) . showString "\t=> " . showsDouble (
realToFrac . Attribute.WeightedMeanAndCriterionValues.getWeightedMean $ Evaluation.QuantifiedGame.getWeightedMeanAndCriterionValues quantifiedGame
)
instance Property.Null.Null (NodeLabel x y positionHash criterionValue weightedMean) where
isNull MkNodeLabel { getQuantifiedGame = quantifiedGame } = Property.Null.isNull quantifiedGame
equalsLastMove :: (Eq x, Eq y) => Component.Move.Move x y -> Data.RoseTree.IsMatch (NodeLabel x y positionHash criterionValue weightedMean)
equalsLastMove move MkNodeLabel { getQuantifiedGame = quantifiedGame } = (== move) . Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove $ Evaluation.QuantifiedGame.getLastTurn quantifiedGame
type BarePositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean = Data.Tree.Tree (NodeLabel x y positionHash criterionValue weightedMean)
getRootQuantifiedGame' :: BarePositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean -> Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean
getRootQuantifiedGame' Data.Tree.Node {
Data.Tree.rootLabel = MkNodeLabel { getQuantifiedGame = quantifiedGame }
} = quantifiedGame
newtype PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean = MkPositionHashQuantifiedGameTree {
deconstruct :: BarePositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean
} deriving Eq
instance Property.Tree.Prunable (PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean) where
prune depth MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = MkPositionHashQuantifiedGameTree $ Property.Tree.prune depth barePositionHashQuantifiedGameTree
instance (
Enum x,
Enum y,
Real weightedMean
) => Notation.MoveNotation.ShowNotationFloat (PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean) where
showsNotationFloat moveNotation showsDouble MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = showString $ (
if Property.Null.isNull . Data.Tree.rootLabel $ barePositionHashQuantifiedGameTree
then Data.RoseTree.drawForest toString . Data.Tree.subForest
else Data.RoseTree.drawTree toString
) barePositionHashQuantifiedGameTree where
toString nodeLabel = Notation.MoveNotation.showsNotationFloat moveNotation showsDouble nodeLabel ""
fromBarePositionHashQuantifiedGameTree :: BarePositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean -> PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean
fromBarePositionHashQuantifiedGameTree = MkPositionHashQuantifiedGameTree
mkPositionHashQuantifiedGameTree :: (
Data.Array.IArray.Ix x,
Data.Bits.Bits positionHash,
Fractional criterionValue,
Fractional pieceSquareValue,
Fractional rankValue,
Fractional weightedMean,
Integral x,
Integral y,
Real criterionValue,
Real criterionWeight,
Real pieceSquareValue,
Real rankValue,
Show x,
Show y
)
=> Input.EvaluationOptions.EvaluationOptions criterionWeight pieceSquareValue rankValue x y
-> Input.SearchOptions.SearchOptions
-> Component.Zobrist.Zobrist x y positionHash
-> Model.GameTree.MoveFrequency x y
-> Model.Game.Game x y
-> PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean
{-# SPECIALISE mkPositionHashQuantifiedGameTree
:: Input.EvaluationOptions.EvaluationOptions T.CriterionWeight T.PieceSquareValue T.RankValue T.X T.Y
-> Input.SearchOptions.SearchOptions
-> Component.Zobrist.Zobrist T.X T.Y T.PositionHash
-> Model.GameTree.MoveFrequency T.X T.Y
-> Model.Game.Game T.X T.Y
-> PositionHashQuantifiedGameTree T.X T.Y T.PositionHash T.CriterionValue T.WeightedMean
#-}
mkPositionHashQuantifiedGameTree evaluationOptions searchOptions zobrist moveFrequency seedGame = MkPositionHashQuantifiedGameTree (
if Input.EvaluationOptions.getIncrementalEvaluation evaluationOptions
then let
apexPositionHash = Component.Zobrist.hash2D seedGame zobrist
in Data.Tree.Node {
Data.Tree.rootLabel = MkNodeLabel apexPositionHash $ Control.Monad.Reader.runReader (
Evaluation.QuantifiedGame.fromGame Nothing seedGame
) evaluationOptions,
Data.Tree.subForest = map (
Data.Maybe.maybe (
let
slave positionHash game Data.Tree.Node {
Data.Tree.rootLabel = game',
Data.Tree.subForest = gameForest'
} = Data.Tree.Node {
Data.Tree.rootLabel = MkNodeLabel positionHash' $ Control.Monad.Reader.runReader (
Evaluation.QuantifiedGame.fromGame Nothing game'
) evaluationOptions,
Data.Tree.subForest = map (slave positionHash' game') gameForest'
} where
positionHash' = Model.Game.incrementalHash game positionHash game' zobrist
in slave
) (
\pieceSquareArray -> let
slave pieceSquareValue positionHash game Data.Tree.Node {
Data.Tree.rootLabel = game',
Data.Tree.subForest = gameForest'
} = Data.Tree.Node {
Data.Tree.rootLabel = MkNodeLabel positionHash' $ Control.Monad.Reader.runReader (
Evaluation.QuantifiedGame.fromGame (Just pieceSquareValue') game'
) evaluationOptions,
Data.Tree.subForest = map (slave pieceSquareValue' positionHash' game') gameForest'
} where
pieceSquareValue' = Evaluation.Fitness.measurePieceSquareValueIncrementally pieceSquareValue pieceSquareArray game'
positionHash' = Model.Game.incrementalHash game positionHash game' zobrist
in slave $ Evaluation.Fitness.measurePieceSquareValue pieceSquareArray seedGame
) (
Input.EvaluationOptions.getMaybePieceSquareArray evaluationOptions
) apexPositionHash seedGame
) $ Data.Tree.subForest bareGameTree
}
else fmap (
uncurry MkNodeLabel . (
(`Component.Zobrist.hash2D` zobrist) &&& (`Control.Monad.Reader.runReader` evaluationOptions) . Evaluation.QuantifiedGame.fromGame Nothing
)
) bareGameTree
) where
bareGameTree = Model.GameTree.deconstruct . uncurry Model.GameTree.sortGameTree (
Input.SearchOptions.getPreferMovesTowardsCentre &&& Input.SearchOptions.getMaybeCaptureMoveSortAlgorithm $ searchOptions
) (
`Attribute.RankValues.findRankValue` Input.EvaluationOptions.getRankValues evaluationOptions
) moveFrequency $ Model.GameTree.fromGame seedGame
getRootPositionHash :: PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean -> positionHash
getRootPositionHash MkPositionHashQuantifiedGameTree {
deconstruct = Data.Tree.Node {
Data.Tree.rootLabel = MkNodeLabel { getPositionHash = positionHash }
}
} = positionHash
getRootQuantifiedGame :: PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean -> Evaluation.QuantifiedGame.QuantifiedGame x y criterionValue weightedMean
getRootQuantifiedGame MkPositionHashQuantifiedGameTree {
deconstruct = Data.Tree.Node {
Data.Tree.rootLabel = MkNodeLabel { getQuantifiedGame = quantifiedGame }
}
} = quantifiedGame
reduce
:: Data.RoseTree.IsMatch (NodeLabel x y positionHash criterionValue weightedMean)
-> PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean
-> Maybe (PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean)
reduce isMatch MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = MkPositionHashQuantifiedGameTree `fmap` Data.RoseTree.reduce isMatch barePositionHashQuantifiedGameTree
traceRoute
:: (Component.Turn.Turn x y -> Data.RoseTree.IsMatch (NodeLabel x y positionHash criterionValue weightedMean))
-> PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean
-> [Component.Turn.Turn x y]
-> Maybe [NodeLabel x y positionHash criterionValue weightedMean]
traceRoute isMatch MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = Data.RoseTree.traceRoute isMatch barePositionHashQuantifiedGameTree
traceMatchingMoves
:: (Eq x, Eq y)
=> PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean
-> [Component.Move.Move x y]
-> Maybe [NodeLabel x y positionHash criterionValue weightedMean]
traceMatchingMoves MkPositionHashQuantifiedGameTree { deconstruct = barePositionHashQuantifiedGameTree } = Data.RoseTree.traceRoute equalsLastMove barePositionHashQuantifiedGameTree
resign :: PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean -> PositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean
resign MkPositionHashQuantifiedGameTree {
deconstruct = barePositionHashQuantifiedGameTree@Data.Tree.Node {
Data.Tree.rootLabel = nodeLabel@MkNodeLabel { getQuantifiedGame = quantifiedGame }
}
} = MkPositionHashQuantifiedGameTree $ barePositionHashQuantifiedGameTree {
Data.Tree.rootLabel = nodeLabel {
getQuantifiedGame = quantifiedGame { Evaluation.QuantifiedGame.getGame = Model.Game.resign $ Evaluation.QuantifiedGame.getGame quantifiedGame }
}
}
type Forest x y positionHash criterionValue weightedMean = [BarePositionHashQuantifiedGameTree x y positionHash criterionValue weightedMean]
promoteMatchingMoves
:: (Eq x, Eq y)
=> [Component.Move.Move x y]
-> Forest x y positionHash criterionValue weightedMean
-> Maybe (Forest x y positionHash criterionValue weightedMean)
promoteMatchingMoves = Data.RoseTree.promote equalsLastMove
sortNonCaptureMoves
:: (Forest x y positionHash criterionValue weightedMean -> Forest x y positionHash criterionValue weightedMean)
-> Forest x y positionHash criterionValue weightedMean
-> Forest x y positionHash criterionValue weightedMean
sortNonCaptureMoves sortForest = uncurry (++) . Control.Arrow.second sortForest . span (
Component.Turn.isCapture . Evaluation.QuantifiedGame.getLastTurn . getRootQuantifiedGame'
)