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