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