{-
	Copyright (C) 2018 Dr. Alistair Ward

	This file is part of BishBosh.

	BishBosh is free software: you can redistribute it and/or modify
	it under the terms of the GNU General Public License as published by
	the Free Software Foundation, either version 3 of the License, or
	(at your option) any later version.

	BishBosh is distributed in the hope that it will be useful,
	but WITHOUT ANY WARRANTY; without even the implied warranty of
	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
	GNU General Public License for more details.

	You should have received a copy of the GNU General Public License
	along with BishBosh.  If not, see <http://www.gnu.org/licenses/>.
-}
{- |
 [@AUTHOR@]	Dr. Alistair Ward

 [@DESCRIPTION@]

	* Defines chess as a constant tree of all possible moves.

	* Because of the conceptually infinite size of this data-structure, care must be taken not to attempt to call 'show', '(==)', ...
-}

module BishBosh.Model.GameTree(
-- * Types
-- ** Type-synonyms
--	BareGameTree,
	MoveFrequency,
--	Transformation,
-- ** Data-types
	GameTree(
--		MkGameTree,
		deconstruct
	),
-- * Function
--	compareByMVVLVA,
--	getLastMove,
--	staticExchangeEvaluation,
--	getRankAndMove,
	countGames,
	countMoves,
	traceRoute,
	sortGameTree,
	toMoveFrequency,
-- ** Constructor
	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

-- | Each node defines the state of the game.
type BareGameTree x y	= Data.Tree.Tree (Model.Game.Game x y)

-- | Forwards request to 'Component.Turn.compareByMVVLVA'.
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

-- | Get the last move responsible for the current position.
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

{- |
	* <https://www.chessprogramming.org/Static_Exchange_Evaluation>.

	* Returns the net /rankValue/-difference in the /piece/s lost by either side, after a continuous battle at the specified coordinates.

	* CAVEAT: assumes that the battle continues until either player concludes it's disadvantageous to continue, or fire-power has been exhausted.
-}
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 {-nothing taken-} (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	-- Find the rank of any victim.
	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 {-this player shouldn't progress the battle-} (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	-- Find counter-attacks at the same coordinates.
		 ) Forest (Game x y)
forest' of
			[]		-> rankValue
0	-- Fire-power has been exhausted => terminate recursion.
			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'' -- Select the least valuable aggressor.
			 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''	-- Recurse.
	 ) (rankValue -> rankValue)
-> EvaluateRank rankValue -> EvaluateRank rankValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvaluateRank rankValue
evaluateRank {-of victim-}

-- | Accessor.
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

-- | Wrap a 'BareGameTree'.
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 {-CAVEAT: required by QuickCheck, but shouldn't actually be called-}

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

-- | Constructor.
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

-- | Constructs a game-tree with the specified game at its root.
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
	) -- Pair.
 )

{- |
	* Counts the number of /game-state/s in the constant game of chess, at the specified depth, including any which terminated earlier.

	* N.B.: some of the /game-state/s may have identical positions, reached by different sequences of /move/s.
-}
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)

-- | Counts the number of possible plies in chess, down to the specified depth.
countMoves :: Property.Tree.Depth -> Model.Game.NGames
countMoves :: Int -> Int
countMoves Int
depth	= Int -> Int
forall a. Enum a => a -> a
pred {-the apex is constructed without moving-} (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)

-- | Trace the route down the tree which matches the specified list of turns.
traceRoute
	:: (Eq x, Eq y)
	=> GameTree x y
	-> [Component.Turn.Turn x y]	-- ^ The data against which, nodes from the tree should be matched.
	-> Maybe [Model.Game.Game x y]	-- ^ Returns 'Nothing' on match-failure.
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

-- | Focus the underlying type.
type MoveFrequency x y	= Model.MoveFrequency.MoveFrequency (Component.Move.Move x y)

-- | Self-documentation.
type Transformation x y	= GameTree x y -> GameTree x y

{- |
	* Independently sorts the forest of moves at each node of the tree, without regard to runtime-data.

	* Depending on preferences, the list of moves available to each game is sequentially sorted by:
		those which reduce the radius from the centre of the board.
		either those which capture a valuable piece using a cheap piece, or those which win extended battles at a specific location.

	* The above sort-algorithms are stable & can therefore be applied independently.
-}
sortGameTree :: (
	Integral	x,
	Integral	y,
	Num		rankValue,
	Ord		rankValue
 )
	=> Bool	-- ^ preferMovesTowardsCentre.
	-> 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 {-largest first-} (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

{- |
	* Count the instances of each /move/ in the specified tree, including any pre-applied to the apex game.

	* CAVEAT: ambiguity remains regarding the /move-type/ (especially any piece taken).

	* CAVEAT: a node is counted as just one instance of the move, rather than the number of games which passed through that node.
	Had the move-frequency been derived from a list of games, a different distribution would result,
	but then early moves would appear popular rather than just the consequence of limited choice.
-}
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 {-MoveFrequency-} [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 {-recurse-} (
		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