{-# LANGUAGE LambdaCase #-}
module BishBosh.Model.GameTree(
MoveFrequency,
GameTree(
deconstruct
),
countGames,
countPositions,
traceRoute,
sortGameTree,
toMoveFrequency,
fromBareGameTree,
fromGame
) where
import Control.Arrow((&&&))
import qualified BishBosh.Attribute.CaptureMoveSortAlgorithm as Attribute.CaptureMoveSortAlgorithm
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.Arboreal as Property.Arboreal
import qualified BishBosh.Property.Empty as Property.Empty
import qualified BishBosh.Property.Null as Property.Null
import qualified BishBosh.Property.Opposable as Property.Opposable
import qualified BishBosh.Type.Count as Type.Count
import qualified BishBosh.Type.Length as Type.Length
import qualified BishBosh.Type.Mass as Type.Mass
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
:: Attribute.Rank.EvaluateRank
-> BareGameTree x y
-> BareGameTree x y
-> Ordering
compareByMVVLVA :: EvaluateRank -> BareGameTree x y -> BareGameTree x y -> Ordering
compareByMVVLVA EvaluateRank
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 -> Turn x y -> Turn x y -> Ordering
forall x y. EvaluateRank -> Turn x y -> Turn x y -> Ordering
Component.Turn.compareByMVVLVA EvaluateRank
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)
=> Attribute.Rank.EvaluateRank
-> BareGameTree x y
-> Type.Mass.RankValue
staticExchangeEvaluation :: EvaluateRank -> BareGameTree x y -> RankValue
staticExchangeEvaluation EvaluateRank
evaluateRank node :: BareGameTree x y
node@Data.Tree.Node { rootLabel :: forall a. Tree a -> a
Data.Tree.rootLabel = Game x y
game } = RankValue -> (Rank -> RankValue) -> Maybe Rank -> RankValue
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe RankValue
0 (BareGameTree x y -> Rank -> RankValue
forall c x y.
(Ord c, Fractional c, Eq x, Eq y) =>
Tree (Game x y) -> Rank -> c
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 :: Model.Game.Game x y -> Maybe Attribute.Rank.Rank
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) -> Rank -> c
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' } = c -> c -> c
forall a. Ord a => a -> a -> a
max c
0 (c -> c) -> (Rank -> c) -> Rank -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> c -> c
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
[] -> c
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 -> Turn x y -> Turn x y -> Ordering
forall x y. EvaluateRank -> Turn x y -> Turn x y -> Ordering
Component.Turn.compareByLVA EvaluateRank
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) -> Rank -> c
slave Tree (Game x y)
node'' (Rank -> c) -> (Maybe Rank -> Rank) -> Maybe Rank -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Rank -> Rank
forall a. HasCallStack => Maybe a -> a
Data.Maybe.fromJust (Maybe Rank -> c) -> Maybe Rank -> c
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''
) (c -> c) -> (Rank -> c) -> Rank -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RankValue -> c
forall a b. (Real a, Fractional b) => a -> b
realToFrac (RankValue -> c) -> EvaluateRank -> Rank -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvaluateRank
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 Type.Length.X Type.Length.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.Arboreal.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.Arboreal.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 Type.Length.X Type.Length.Y -> GameTree Type.Length.X Type.Length.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.Arboreal.Depth -> Type.Count.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.Arboreal.prune Int
depth (GameTree Int Int
forall a. Default a => a
Data.Default.def :: GameTree Type.Length.X Type.Length.Y)
countPositions :: Property.Arboreal.Depth -> Type.Count.NPositions
countPositions :: Int -> Int
countPositions Int
depth = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int)
-> (GameTree Int Int -> Int) -> GameTree Int Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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.Arboreal.prune Int
depth (GameTree Int Int
forall a. Default a => a
Data.Default.def :: GameTree Type.Length.X Type.Length.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)
=> Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm
-> Attribute.Rank.EvaluateRank
-> MoveFrequency x y
-> Transformation x y
{-# SPECIALISE sortGameTree :: Maybe Attribute.CaptureMoveSortAlgorithm.CaptureMoveSortAlgorithm -> Attribute.Rank.EvaluateRank -> MoveFrequency Type.Length.X Type.Length.Y -> Transformation Type.Length.X Type.Length.Y #-}
sortGameTree :: Maybe CaptureMoveSortAlgorithm
-> EvaluateRank -> MoveFrequency x y -> Transformation x y
sortGameTree Maybe CaptureMoveSortAlgorithm
maybeCaptureMoveSortAlgorithm EvaluateRank
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 (
\case
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 -> BareGameTree x y -> BareGameTree x y -> Ordering
forall x y.
EvaluateRank -> BareGameTree x y -> BareGameTree x y -> Ordering
compareByMVVLVA EvaluateRank
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 -> BareGameTree x y -> RankValue
forall x y.
(Eq x, Eq y) =>
EvaluateRank -> BareGameTree x y -> RankValue
staticExchangeEvaluation EvaluateRank
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
)
) 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 x y
bareGameTree } = LogicalColour
-> MoveFrequency x y -> BareGameTree x y -> MoveFrequency x y
forall x y.
(Ord x, Ord y) =>
LogicalColour
-> MoveFrequency (Move x y)
-> Tree (Game x y)
-> MoveFrequency (Move x y)
slave LogicalColour
forall a. Bounded a => a
maxBound MoveFrequency x y
forall a. Empty a => a
Property.Empty.empty BareGameTree x y
bareGameTree where
slave :: LogicalColour
-> MoveFrequency (Move x y)
-> Tree (Game x y)
-> MoveFrequency (Move x y)
slave LogicalColour
_ MoveFrequency (Move x y)
moveFrequency Data.Tree.Node { subForest :: forall a. Tree a -> Forest a
Data.Tree.subForest = [] } = MoveFrequency (Move x y)
moveFrequency
slave LogicalColour
logicalColour MoveFrequency (Move x y)
moveFrequency Data.Tree.Node { subForest :: forall a. Tree a -> Forest a
Data.Tree.subForest = [Tree (Game x y)]
forest } = (MoveFrequency (Move x y)
-> Tree (Game x y) -> MoveFrequency (Move x y))
-> MoveFrequency (Move x y)
-> [Tree (Game x y)]
-> MoveFrequency (Move x y)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Data.List.foldl' (
LogicalColour
-> MoveFrequency (Move x y)
-> Tree (Game x y)
-> MoveFrequency (Move x y)
slave (LogicalColour
-> MoveFrequency (Move x y)
-> Tree (Game x y)
-> MoveFrequency (Move x y))
-> LogicalColour
-> MoveFrequency (Move x y)
-> Tree (Game x y)
-> MoveFrequency (Move x y)
forall a b. (a -> b) -> a -> b
$ LogicalColour -> LogicalColour
forall a. Opposable a => a -> a
Property.Opposable.getOpposite LogicalColour
logicalColour
) (
LogicalColour
-> GetRankAndMove (Tree (Game x y)) (Move x y)
-> MoveFrequency (Move x y)
-> [Tree (Game x y)]
-> MoveFrequency (Move x y)
forall move a.
Ord move =>
LogicalColour
-> GetRankAndMove a move
-> MoveFrequency move
-> [a]
-> MoveFrequency move
Model.MoveFrequency.insertMoves LogicalColour
logicalColour GetRankAndMove (Tree (Game x y)) (Move x y)
forall x y. GetRankAndMove (BareGameTree x y) (Move x y)
getRankAndMove MoveFrequency (Move x y)
moveFrequency [Tree (Game x y)]
forest
) [Tree (Game x y)]
forest