module BishBosh.ContextualNotation.PositionHashQualifiedMoveTree(
OnymousQualifiedMove,
NodeLabel(),
PositionHashQualifiedMoveTree(),
findNextOnymousQualifiedMovesForPosition,
findNextOnymousQualifiedMoves,
maybeRandomlySelectOnymousQualifiedMove,
fromQualifiedMoveForest,
isTerminal
) where
import Control.Arrow((&&&), (***))
import qualified BishBosh.Attribute.MoveType as Attribute.MoveType
import qualified BishBosh.Component.Piece as Component.Piece
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.ContextualNotation.QualifiedMoveForest as ContextualNotation.QualifiedMoveForest
import qualified BishBosh.Model.Game as Model.Game
import qualified BishBosh.Model.Result as Model.Result
import qualified BishBosh.Property.Reflectable as Property.Reflectable
import qualified BishBosh.State.Board as State.Board
import qualified BishBosh.Types as T
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Control.Parallel.Strategies
import qualified Data.Array.IArray
import qualified Data.Bits
import qualified Data.Default
import qualified Data.List
import qualified Data.List.Extra
import qualified Data.Maybe
import qualified Data.Tree
import qualified Factory.Math.Statistics
import qualified System.Random
import qualified ToolShed.System.Random
data NodeLabel x y positionHash = MkNodeLabel {
getPositionHash :: positionHash,
getMaybeQualifiedMoveWithOnymousResult :: Maybe (Component.QualifiedMove.QualifiedMove x y, Maybe ContextualNotation.QualifiedMoveForest.OnymousResult)
}
type Tree x y positionHash = Data.Tree.Tree (NodeLabel x y positionHash)
data PositionHashQualifiedMoveTree x y positionHash = MkPositionHashQualifiedMoveTree {
getZobrist :: Component.Zobrist.Zobrist x y positionHash,
getTree :: Tree x y positionHash,
getMinimumPieces :: Component.Piece.NPieces
}
fromQualifiedMoveForest :: (
Data.Array.IArray.Ix x,
Data.Bits.Bits positionHash,
Enum x,
Enum y,
Ord y,
Show x,
Show y
)
=> Bool
-> Component.Zobrist.Zobrist x y positionHash
-> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest x y
-> PositionHashQualifiedMoveTree x y positionHash
{-# SPECIALISE fromQualifiedMoveForest :: Bool -> Component.Zobrist.Zobrist T.X T.Y T.PositionHash -> ContextualNotation.QualifiedMoveForest.QualifiedMoveForest T.X T.Y -> PositionHashQualifiedMoveTree T.X T.Y T.PositionHash #-}
fromQualifiedMoveForest incrementalEvaluation zobrist qualifiedMoveForest = MkPositionHashQualifiedMoveTree {
getZobrist = zobrist,
getTree = let
initialGame = Data.Default.def
initialPositionHash = Component.Zobrist.hash2D initialGame zobrist
in Data.Tree.Node {
Data.Tree.rootLabel = MkNodeLabel initialPositionHash Nothing,
Data.Tree.subForest = map (
if incrementalEvaluation
then let
slave game positionHash Data.Tree.Node {
Data.Tree.rootLabel = label@(qualifiedMove, _),
Data.Tree.subForest = qualifiedMoveForest'
} = Data.Tree.Node {
Data.Tree.rootLabel = MkNodeLabel positionHash' $ Just label,
Data.Tree.subForest = map (slave game' positionHash') qualifiedMoveForest'
} where
game' = Model.Game.applyQualifiedMove qualifiedMove game
positionHash' = Model.Game.incrementalHash game positionHash game' zobrist
in slave initialGame initialPositionHash
else let
slave game Data.Tree.Node {
Data.Tree.rootLabel = label@(qualifiedMove, _),
Data.Tree.subForest = qualifiedMoveForest'
} = Data.Tree.Node {
Data.Tree.rootLabel = MkNodeLabel (Component.Zobrist.hash2D game' zobrist) $ Just label,
Data.Tree.subForest = map (slave game') qualifiedMoveForest'
} where
game' = Model.Game.applyQualifiedMove qualifiedMove game
in slave initialGame
) $ ContextualNotation.QualifiedMoveForest.deconstruct qualifiedMoveForest
},
getMinimumPieces = ContextualNotation.QualifiedMoveForest.findMinimumPieces qualifiedMoveForest
}
isTerminal :: PositionHashQualifiedMoveTree x y positionHash -> Bool
isTerminal MkPositionHashQualifiedMoveTree { getTree = Data.Tree.Node { Data.Tree.subForest = [] } } = True
isTerminal _ = False
cantConverge :: Model.Game.Game x y -> PositionHashQualifiedMoveTree x y positionHash -> Bool
cantConverge game MkPositionHashQualifiedMoveTree { getMinimumPieces = minimumPieces } = State.Board.getNPieces (Model.Game.getBoard game) < minimumPieces
type OnymousQualifiedMove x y = (Component.QualifiedMove.QualifiedMove x y, [ContextualNotation.QualifiedMoveForest.OnymousResult])
onymiseQualifiedMove :: Tree x y positionHash -> OnymousQualifiedMove x y
onymiseQualifiedMove = (
fst . head &&& Data.Maybe.mapMaybe snd
) . map (
\MkNodeLabel { getMaybeQualifiedMoveWithOnymousResult = Just qualifiedMoveWithOnymousResult } -> qualifiedMoveWithOnymousResult
) . Data.Tree.flatten
type FindMatch x y positionHash = Model.Game.Game x y -> PositionHashQualifiedMoveTree x y positionHash -> [OnymousQualifiedMove x y]
findNextOnymousQualifiedMovesForGame :: (Eq x, Eq y) => FindMatch x y positionHash
findNextOnymousQualifiedMovesForGame requiredGame = slave (
Model.Game.listTurnsChronologically requiredGame
) . Data.Tree.subForest . getTree where
slave (turn : remainingTurns) = Data.Maybe.maybe [] (
slave remainingTurns . Data.Tree.subForest
) . Data.List.find (
\Data.Tree.Node {
Data.Tree.rootLabel = MkNodeLabel { getMaybeQualifiedMoveWithOnymousResult = Just (qualifiedMove, _) }
} -> qualifiedMove == Component.Turn.getQualifiedMove turn
)
slave _ = map onymiseQualifiedMove
findNextOnymousQualifiedMovesForPosition :: (
Data.Array.IArray.Ix x,
Data.Bits.Bits positionHash,
Enum x,
Enum y,
Ord y
) => FindMatch x y positionHash
{-# SPECIALISE findNextOnymousQualifiedMovesForPosition :: FindMatch T.X T.Y T.PositionHash #-}
findNextOnymousQualifiedMovesForPosition requiredGame positionHashQualifiedMoveTree@MkPositionHashQualifiedMoveTree {
getZobrist = zobrist,
getTree = tree
}
| cantConverge requiredGame positionHashQualifiedMoveTree = []
| otherwise = slave (2 * Component.Piece.nPiecesPerSide) tree
where
slave nPieces Data.Tree.Node {
Data.Tree.rootLabel = MkNodeLabel { getPositionHash = positionHash },
Data.Tree.subForest = forest
}
| nPieces < State.Board.getNPieces (
Model.Game.getBoard requiredGame
) = []
| otherwise = (
if positionHash == Component.Zobrist.hash2D requiredGame zobrist
then (
map onymiseQualifiedMove forest ++
)
else id
) $ concatMap (
\node@Data.Tree.Node {
Data.Tree.rootLabel = MkNodeLabel { getMaybeQualifiedMoveWithOnymousResult = Just (qualifiedMove, _) }
} -> slave (
Attribute.MoveType.nPiecesMutator (Component.QualifiedMove.getMoveType qualifiedMove) nPieces
) node
) forest
findNextJoiningOnymousQualifiedMovesFromPosition :: (
Data.Array.IArray.Ix x,
Data.Bits.Bits positionHash,
Control.DeepSeq.NFData x,
Control.DeepSeq.NFData y,
Enum x,
Enum y,
Ord y,
Show x,
Show y
) => FindMatch x y positionHash
{-# SPECIALISE findNextJoiningOnymousQualifiedMovesFromPosition :: FindMatch T.X T.Y T.PositionHash #-}
findNextJoiningOnymousQualifiedMovesFromPosition game positionHashQualifiedMoveTree = [
(
preMatchQualifiedMove,
concatMap snd matchingOnymousQualifiedMoves
) |
not $ Model.Game.isTerminated game,
(preMatchQualifiedMove, matchingOnymousQualifiedMoves) <- Control.Parallel.Strategies.withStrategy (
Control.Parallel.Strategies.parList $ Control.Parallel.Strategies.parTuple2 Control.Parallel.Strategies.r0 Control.Parallel.Strategies.rdeepseq
) . map (
id &&& (`findNextOnymousQualifiedMovesForPosition` positionHashQualifiedMoveTree) . (`Model.Game.applyQualifiedMove` game)
) $ Model.Game.findQualifiedMovesAvailableToNextPlayer game,
not $ null matchingOnymousQualifiedMoves
]
findNextOnymousQualifiedMoves :: (
Data.Array.IArray.Ix x,
Data.Bits.Bits positionHash,
Control.DeepSeq.NFData x,
Control.DeepSeq.NFData y,
Enum x,
Enum y,
Ord y,
Show x,
Show y
)
=> (Bool, Bool, Bool)
-> FindMatch x y positionHash
{-# SPECIALISE findNextOnymousQualifiedMoves :: (Bool, Bool, Bool) -> FindMatch T.X T.Y T.PositionHash #-}
findNextOnymousQualifiedMoves (tryToMatchMoves, tryToMatchViaJoiningMove, tryToMatchColourFlippedPosition) game positionHashQualifiedMoveTree
| cantConverge game positionHashQualifiedMoveTree = []
| otherwise = Data.Maybe.fromMaybe [] . Data.List.find (
not . null
) $ (
if tryToMatchMoves
then (findNextOnymousQualifiedMovesForGame game positionHashQualifiedMoveTree :)
else id
) [
colourFlipper findMatch game positionHashQualifiedMoveTree |
findMatch <- findNextOnymousQualifiedMovesForPosition : [findNextJoiningOnymousQualifiedMovesFromPosition | tryToMatchViaJoiningMove] ,
colourFlipper <- id : [
\findMatch' game' -> map (
Property.Reflectable.reflectOnX *** map (
Control.Arrow.first $ showString "Colour-flipped:\t"
)
) . findMatch' (
Property.Reflectable.reflectOnX game'
) | tryToMatchColourFlippedPosition
]
]
maybeRandomlySelectOnymousQualifiedMove :: (
Control.DeepSeq.NFData x,
Control.DeepSeq.NFData y,
Data.Array.IArray.Ix x,
Data.Bits.Bits positionHash,
Enum x,
Enum y,
Ord y,
Show x,
Show y,
System.Random.RandomGen randomGen
)
=> randomGen
-> (Bool, Bool, Bool)
-> Model.Game.Game x y
-> PositionHashQualifiedMoveTree x y positionHash
-> Maybe (Component.QualifiedMove.QualifiedMove x y, [ContextualNotation.QualifiedMoveForest.Name])
{-# SPECIALISE maybeRandomlySelectOnymousQualifiedMove
:: System.Random.RandomGen randomGen
=> randomGen
-> (Bool, Bool, Bool)
-> Model.Game.Game T.X T.Y
-> PositionHashQualifiedMoveTree T.X T.Y T.PositionHash
-> Maybe (Component.QualifiedMove.QualifiedMove T.X T.Y, [ContextualNotation.QualifiedMoveForest.Name])
#-}
maybeRandomlySelectOnymousQualifiedMove randomGen matchSwitches game positionHashQualifiedMoveTree = case findNextOnymousQualifiedMoves matchSwitches game positionHashQualifiedMoveTree of
[] -> Nothing
onymousQualifiedMoves -> fmap (
Control.Arrow.second $ Data.List.nub . map fst
) . ToolShed.System.Random.select randomGen . last $ Data.List.Extra.groupSortOn (
(
Factory.Math.Statistics.getMean :: [Int] -> Rational
) . map (
Data.Maybe.maybe 0 (
\victorsLogicalColour -> (
if victorsLogicalColour == Model.Game.getNextLogicalColour game
then id
else negate
) 1
) . Model.Result.findMaybeVictor . snd
) . snd
) onymousQualifiedMoves