module BishBosh.Model.GameTree(
MoveFrequency,
GameTree(
deconstruct
),
countGames,
countMoves,
traceRoute,
sortGameTree,
toMoveFrequency,
fromBareGameTree,
fromGame
) where
import Control.Arrow((&&&))
import qualified BishBosh.Attribute.CaptureMoveSortAlgorithm as Attribute.CaptureMoveSortAlgorithm
import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour
import qualified BishBosh.Attribute.MoveType as Attribute.MoveType
import qualified BishBosh.Attribute.Rank as Attribute.Rank
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.Data.Exception as Data.Exception
import qualified BishBosh.Data.RoseTree as Data.RoseTree
import qualified BishBosh.Model.Game as Model.Game
import qualified BishBosh.Model.MoveFrequency as Model.MoveFrequency
import qualified BishBosh.Notation.MoveNotation as Notation.MoveNotation
import qualified BishBosh.Property.Empty as Property.Empty
import qualified BishBosh.Property.Null as Property.Null
import qualified BishBosh.Property.Tree as Property.Tree
import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour
import qualified BishBosh.Types as T
import qualified Control.Exception
import qualified Data.Default
import qualified Data.Foldable
import qualified Data.List
import qualified Data.Maybe
import qualified Data.Tree
type BareGameTree x y = Data.Tree.Tree (Model.Game.Game x y)
compareByMVVLVA
:: Ord rankValue
=> Attribute.Rank.EvaluateRank rankValue
-> BareGameTree x y
-> BareGameTree x y
-> Ordering
compareByMVVLVA evaluateRank Data.Tree.Node { Data.Tree.rootLabel = gameL } Data.Tree.Node { Data.Tree.rootLabel = gameR } = uncurry (
Component.Turn.compareByMVVLVA evaluateRank
) . (
($ gameL) &&& ($ gameR)
) $ Data.Maybe.fromJust . Model.Game.maybeLastTurn
getLastMove :: BareGameTree x y -> Component.Move.Move x y
{-# INLINE getLastMove #-}
getLastMove Data.Tree.Node { Data.Tree.rootLabel = game } = Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove . Data.Maybe.fromJust $ Model.Game.maybeLastTurn game
staticExchangeEvaluation :: (
Eq x,
Eq y,
Num rankValue,
Ord rankValue
)
=> Attribute.Rank.EvaluateRank rankValue
-> BareGameTree x y
-> rankValue
staticExchangeEvaluation evaluateRank node@Data.Tree.Node { Data.Tree.rootLabel = game } = Data.Maybe.maybe 0 (slave node) $ getMaybeImplicitlyTakenRank game where
getMaybeImplicitlyTakenRank game' = Attribute.MoveType.getMaybeImplicitlyTakenRank . Component.QualifiedMove.getMoveType . Component.Turn.getQualifiedMove =<< Model.Game.maybeLastTurn game'
slave node'@Data.Tree.Node { Data.Tree.subForest = forest' } = max 0 . subtract (
case filter (
(
== Component.Move.getDestination (getLastMove node')
) . Component.Move.getDestination . getLastMove
) forest' of
[] -> 0
forest'' -> let
node''@Data.Tree.Node { Data.Tree.rootLabel = game'' } = Data.List.minimumBy (
\Data.Tree.Node { Data.Tree.rootLabel = gameL } Data.Tree.Node { Data.Tree.rootLabel = gameR } -> uncurry (
Component.Turn.compareByLVA evaluateRank
) . (
($ gameL) &&& ($ gameR)
) $ Data.Maybe.fromMaybe (
Control.Exception.throw $ Data.Exception.mkResultUndefined "BishBosh.Model.GameTree:\tModel.Game.maybeLastTurn failed."
) . Model.Game.maybeLastTurn
) forest''
in slave node'' . Data.Maybe.fromJust $ getMaybeImplicitlyTakenRank game''
) . evaluateRank
getRankAndMove :: Model.MoveFrequency.GetRankAndMove (BareGameTree x y) (Component.Move.Move x y)
{-# INLINE getRankAndMove #-}
getRankAndMove Data.Tree.Node { Data.Tree.rootLabel = game } = (Component.Turn.getRank &&& Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove) . Data.Maybe.fromJust $ Model.Game.maybeLastTurn game
newtype GameTree x y = MkGameTree {
deconstruct :: BareGameTree x y
} deriving Show
instance (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Data.Default.Default (GameTree x y) where
{-# SPECIALISE instance Data.Default.Default (GameTree T.X T.Y) #-}
def = fromGame Data.Default.def
instance Property.Tree.Prunable (GameTree x y) where
prune depth MkGameTree { deconstruct = bareGameTree } = MkGameTree $ Property.Tree.prune depth bareGameTree
instance (Enum x, Enum y) => Notation.MoveNotation.ShowNotation (GameTree x y) where
showsNotation moveNotation MkGameTree {
deconstruct = bareGameTree@Data.Tree.Node {
Data.Tree.rootLabel = game,
Data.Tree.subForest = forest
}
} = showString $ if Property.Null.isNull game
then Data.RoseTree.drawForest toString forest
else Data.RoseTree.drawTree toString bareGameTree
where
toString = Notation.MoveNotation.showNotation moveNotation . Data.Maybe.fromJust . Model.Game.maybeLastTurn
fromBareGameTree :: BareGameTree x y -> GameTree x y
fromBareGameTree = MkGameTree
fromGame :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Model.Game.Game x y -> GameTree x y
{-# SPECIALISE fromGame :: Model.Game.Game T.X T.Y -> GameTree T.X T.Y #-}
fromGame = MkGameTree . Data.Tree.unfoldTree (
\game -> (
game,
if Model.Game.isTerminated game
then []
else map (
`Model.Game.applyQualifiedMove` game
) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game
)
)
countGames :: Property.Tree.Depth -> Model.Game.NGames
countGames depth = Data.RoseTree.countTerminalNodes . deconstruct $ Property.Tree.prune depth (Data.Default.def :: GameTree T.X T.Y)
countMoves :: Property.Tree.Depth -> Model.Game.NGames
countMoves depth = pred . Data.Foldable.length . deconstruct $ Property.Tree.prune depth (Data.Default.def :: GameTree T.X T.Y)
traceRoute
:: (Eq x, Eq y)
=> GameTree x y
-> [Component.Turn.Turn x y]
-> Maybe [Model.Game.Game x y]
traceRoute MkGameTree { deconstruct = bareGameTree } = Data.RoseTree.traceRoute (\turn -> (== Just turn) . Model.Game.maybeLastTurn) bareGameTree
type MoveFrequency x y = Model.MoveFrequency.MoveFrequency (Component.Move.Move x y)
type Transformation x y = GameTree x y -> GameTree x y
sortGameTree :: (
Integral x,
Integral y,
Num rankValue,
Ord rankValue
)
=> Bool
-> Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm
-> Attribute.Rank.EvaluateRank rankValue
-> MoveFrequency x y
-> Transformation x y
{-# SPECIALISE sortGameTree :: Bool -> Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm -> Attribute.Rank.EvaluateRank T.RankValue -> MoveFrequency T.X T.Y -> Transformation T.X T.Y #-}
sortGameTree preferMovesTowardsCentre maybeCaptureMoveSortAlgorithm evaluateRank standardOpeningMoveFrequency MkGameTree { deconstruct = bareGameTree } = MkGameTree $ Data.RoseTree.mapForest (
\game -> Data.Maybe.maybe id (
\captureMoveSortAlgorithm -> case captureMoveSortAlgorithm of
Attribute.CaptureMoveSortAlgorithm.MVVLVA -> Data.List.sortBy $ compareByMVVLVA evaluateRank
Attribute.CaptureMoveSortAlgorithm.SEE -> Data.List.sortOn $ negate . staticExchangeEvaluation evaluateRank
) maybeCaptureMoveSortAlgorithm . (
if Property.Null.isNull standardOpeningMoveFrequency
then id
else Model.MoveFrequency.sortByDescendingMoveFrequency (Model.Game.getNextLogicalColour game) getRankAndMove standardOpeningMoveFrequency
) . (
if preferMovesTowardsCentre
then Data.List.sortOn $ \node -> Component.Move.getDeltaRadiusSquared $ getLastMove node :: Double
else id
)
) bareGameTree
toMoveFrequency :: (Ord x, Ord y) => GameTree x y -> MoveFrequency x y
toMoveFrequency MkGameTree {
deconstruct = bareGameTree@Data.Tree.Node { Data.Tree.rootLabel = rootGame }
} = slave (
Data.List.foldl' (
\moveFrequency logicalColour -> Model.MoveFrequency.insertMoves logicalColour (
Component.Turn.getRank &&& Component.QualifiedMove.getMove . Component.Turn.getQualifiedMove
) moveFrequency . State.TurnsByLogicalColour.dereference logicalColour $ Model.Game.getTurnsByLogicalColour rootGame
) Property.Empty.empty Attribute.LogicalColour.range
) bareGameTree where
slave moveFrequency Data.Tree.Node {
Data.Tree.rootLabel = game,
Data.Tree.subForest = forest
} = Data.List.foldl' slave (
Model.MoveFrequency.insertMoves (Model.Game.getNextLogicalColour game) getRankAndMove moveFrequency forest
) forest