{-
	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@]	Categorises /move/s, & provides ancillary information as required.
-}

module BishBosh.Attribute.MoveType(
-- * Types
-- ** Type-synonyms
--	IsShort,
-- ** Data-types
	MoveType(
		Castle,
		EnPassant
--		Normal
	),
-- * Constants
	tag,
	shortCastle,
	longCastle,
	enPassant,
-- * Functions
	nPiecesMutator,
	apply,
-- ** Constructors
	mkMaybeNormalMoveType,
	mkNormalMoveType,
-- ** Predicates
	isCastle,
	isEnPassant,
	isCapture,
	isPromotion,
	isQuiet,
	isSimple,
	isAcyclic,
-- ** Query
	getMaybeExplicitlyTakenRank,
	getMaybeImplicitlyTakenRank,
	getMaybePromotedRank
) where

import qualified	BishBosh.Attribute.Rank			as Attribute.Rank
import qualified	BishBosh.Property.FixedMembership	as Property.FixedMembership
import qualified	BishBosh.Text.ShowList			as Text.ShowList
import qualified	Control.Arrow
import qualified	Control.DeepSeq
import qualified	Control.Exception
import qualified	Data.Default
import qualified	Data.List.Extra
import qualified	Data.Maybe

-- | Used to qualify output.
tag :: String
tag :: String
tag	= String
"moveType"

-- | Self-documentation.
type IsShort	= Bool

-- | Constant value required to denote a /short castle/.
shortCastle :: MoveType
shortCastle :: MoveType
shortCastle	= IsShort -> MoveType
Castle IsShort
True

-- | Constant value required to denote a /long castle/.
longCastle :: MoveType
longCastle :: MoveType
longCastle	= IsShort -> MoveType
Castle IsShort
False

-- | Constant.
enPassant :: MoveType
enPassant :: MoveType
enPassant	= MoveType
EnPassant

-- | The sum-type of distinct types of /move/.
data MoveType
	= Castle IsShort	-- ^ Castling between the @King@ & one of its @Rook@s.
	| EnPassant		-- ^ Capture by a @Pawn@ of a @Pawn@ as it advanced two squares.
	| Normal {
		MoveType -> Maybe Rank
getMaybeTakenRank	:: Maybe Attribute.Rank.Rank,
		MoveType -> Maybe Rank
getMaybePromotionRank	:: Maybe Attribute.Rank.Rank
	}			-- ^ The /rank/ of any opposing /piece/ which was just taken & the /rank/ of any /piece/ to which a @Pawn@ was just promoted.
	deriving MoveType -> MoveType -> IsShort
(MoveType -> MoveType -> IsShort)
-> (MoveType -> MoveType -> IsShort) -> Eq MoveType
forall a. (a -> a -> IsShort) -> (a -> a -> IsShort) -> Eq a
/= :: MoveType -> MoveType -> IsShort
$c/= :: MoveType -> MoveType -> IsShort
== :: MoveType -> MoveType -> IsShort
$c== :: MoveType -> MoveType -> IsShort
Eq

instance Show MoveType where
	showsPrec :: Int -> MoveType -> ShowS
showsPrec Int
_ (Castle IsShort
isShort)	= String -> ShowS
showString String
"Castle (short" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
Text.ShowList.showsAssociation ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IsShort -> ShowS
forall a. Show a => a -> ShowS
shows IsShort
isShort ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
')'
	showsPrec Int
_ MoveType
EnPassant		= String -> ShowS
showString String
"En-passant"
	showsPrec Int
_ Normal {
		getMaybeTakenRank :: MoveType -> Maybe Rank
getMaybeTakenRank	= Maybe Rank
maybeTakenRank,
		getMaybePromotionRank :: MoveType -> Maybe Rank
getMaybePromotionRank	= Maybe Rank
maybePromotionRank
	} = [(String, ShowS)] -> ShowS
Text.ShowList.showsAssociationList' ([(String, ShowS)] -> ShowS) -> [(String, ShowS)] -> ShowS
forall a b. (a -> b) -> a -> b
$ [Maybe (String, ShowS)] -> [(String, ShowS)]
forall a. [Maybe a] -> [a]
Data.Maybe.catMaybes [
		(Rank -> (String, ShowS)) -> Maybe Rank -> Maybe (String, ShowS)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) String
"takenRank" (ShowS -> (String, ShowS))
-> (Rank -> ShowS) -> Rank -> (String, ShowS)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rank -> ShowS
forall a. Show a => a -> ShowS
shows) Maybe Rank
maybeTakenRank,
		(Rank -> (String, ShowS)) -> Maybe Rank -> Maybe (String, ShowS)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((,) String
"promotionRank" (ShowS -> (String, ShowS))
-> (Rank -> ShowS) -> Rank -> (String, ShowS)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rank -> ShowS
forall a. Show a => a -> ShowS
shows) Maybe Rank
maybePromotionRank
	 ]

instance Read MoveType where
	readsPrec :: Int -> ReadS MoveType
readsPrec Int
_ String
s	= case ShowS
Data.List.Extra.trimStart String
s of
		Char
'C' : Char
'a' : Char
's' : Char
't' : Char
'l' : Char
'e' : String
s1	-> [
			(IsShort -> MoveType
Castle IsShort
isShort, String
remainder) |
				(String
"(", String
s2)		<- ReadS String
lex String
s1,
				(String
"short", String
s3)		<- ReadS String
lex String
s2,
				(String
"=", String
s4)		<- ReadS String
lex String
s3,
				(IsShort
isShort, String
s5)		<- ReadS IsShort
forall a. Read a => ReadS a
reads String
s4,
				(String
")", String
remainder)	<- ReadS String
lex String
s5
		 ] -- List-comprehension.
		Char
'E' : Char
'n' : Char
'-' : Char
'p' : Char
'a' : Char
's' : Char
's' : Char
'a' : Char
'n' : Char
't' : String
remainder	-> [(MoveType
EnPassant, String
remainder)]
		String
_ -> [
			(MoveType
normalMoveType, String
remainder) |
				(String
"{", String
s1)			<- ReadS String
lex String
s,
				(Maybe Rank
maybeTakenRank, String
s2)		<- case [
					(Rank, String)
pair |
						(String
"takenRank", String
s11)	<- ReadS String
lex String
s1,
						(String
"=", String
s12)		<- ReadS String
lex String
s11,
						(Rank, String)
pair			<- ReadS Rank
forall a. Read a => ReadS a
reads String
s12
				] of
					[]	-> [(Maybe Rank
forall a. Maybe a
Nothing, String
s1)]	-- Infer that nothing was taken.
					[(Rank, String)]
parsed	-> ((Rank, String) -> (Maybe Rank, String))
-> [(Rank, String)] -> [(Maybe Rank, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((Rank -> Maybe Rank) -> (Rank, String) -> (Maybe Rank, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Control.Arrow.first Rank -> Maybe Rank
forall a. a -> Maybe a
Just) [(Rank, String)]
parsed,
				String
s3	<- String -> [String]
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ case ReadS String
lex String
s2 of
					[(String
",", String
s21)]	-> String
s21
					[(String, String)]
_		-> String
s2,
				(Maybe Rank
maybePromotionRank, String
s4)	<- case [
					(Rank, String)
pair |
						(String
"promotionRank", String
s31)	<- ReadS String
lex String
s3,
						(String
"=", String
s32)		<- ReadS String
lex String
s31,
						(Rank, String)
pair			<- ReadS Rank
forall a. Read a => ReadS a
reads String
s32
				] of
					[]	-> [(Maybe Rank
forall a. Maybe a
Nothing, String
s3)]	-- Infer that there was no promotion.
					[(Rank, String)]
parsed	-> ((Rank, String) -> (Maybe Rank, String))
-> [(Rank, String)] -> [(Maybe Rank, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((Rank -> Maybe Rank) -> (Rank, String) -> (Maybe Rank, String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Control.Arrow.first Rank -> Maybe Rank
forall a. a -> Maybe a
Just) [(Rank, String)]
parsed,
				(String
"}", String
remainder)		<- ReadS String
lex String
s4,
				MoveType
normalMoveType			<- Maybe MoveType -> [MoveType]
forall a. Maybe a -> [a]
Data.Maybe.maybeToList (Maybe MoveType -> [MoveType]) -> Maybe MoveType -> [MoveType]
forall a b. (a -> b) -> a -> b
$ Maybe Rank -> Maybe Rank -> Maybe MoveType
mkMaybeNormalMoveType Maybe Rank
maybeTakenRank Maybe Rank
maybePromotionRank
		 ] -- List-comprehension.

instance Control.DeepSeq.NFData MoveType where
	rnf :: MoveType -> ()
rnf (Castle IsShort
isShort)	= IsShort -> ()
forall a. NFData a => a -> ()
Control.DeepSeq.rnf IsShort
isShort
	rnf MoveType
EnPassant		= ()
	rnf Normal {
		getMaybeTakenRank :: MoveType -> Maybe Rank
getMaybeTakenRank	= Maybe Rank
maybeTakenRank,
		getMaybePromotionRank :: MoveType -> Maybe Rank
getMaybePromotionRank	= Maybe Rank
maybePromotionRank
	}			= (Maybe Rank, Maybe Rank) -> ()
forall a. NFData a => a -> ()
Control.DeepSeq.rnf (Maybe Rank
maybeTakenRank, Maybe Rank
maybePromotionRank)

instance Data.Default.Default MoveType where
	def :: MoveType
def	= Normal :: Maybe Rank -> Maybe Rank -> MoveType
Normal {
		getMaybeTakenRank :: Maybe Rank
getMaybeTakenRank	= Maybe Rank
forall a. Maybe a
Nothing,
		getMaybePromotionRank :: Maybe Rank
getMaybePromotionRank	= Maybe Rank
forall a. Maybe a
Nothing
	}

instance Attribute.Rank.Promotable MoveType where
	getMaybePromotionRank :: MoveType -> Maybe Rank
getMaybePromotionRank Normal { getMaybePromotionRank :: MoveType -> Maybe Rank
getMaybePromotionRank = Maybe Rank
maybePromotionRank }	= Maybe Rank
maybePromotionRank
	getMaybePromotionRank MoveType
_								= Maybe Rank
forall a. Maybe a
Nothing

instance Property.FixedMembership.FixedMembership MoveType where
	members :: [MoveType]
members	= MoveType
EnPassant MoveType -> [MoveType] -> [MoveType]
forall a. a -> [a] -> [a]
: (IsShort -> MoveType) -> [IsShort] -> [MoveType]
forall a b. (a -> b) -> [a] -> [b]
map IsShort -> MoveType
Castle [IsShort]
forall a. FixedMembership a => [a]
Property.FixedMembership.members [MoveType] -> [MoveType] -> [MoveType]
forall a. [a] -> [a] -> [a]
++ [
		Normal :: Maybe Rank -> Maybe Rank -> MoveType
Normal {
			getMaybeTakenRank :: Maybe Rank
getMaybeTakenRank	= Maybe Rank
maybeTakenRank,
			getMaybePromotionRank :: Maybe Rank
getMaybePromotionRank	= Maybe Rank
maybePromotionRank
		} |
			Maybe Rank
maybeTakenRank		<- Maybe Rank
forall a. Maybe a
Nothing Maybe Rank -> [Maybe Rank] -> [Maybe Rank]
forall a. a -> [a] -> [a]
: (Rank -> Maybe Rank) -> [Rank] -> [Maybe Rank]
forall a b. (a -> b) -> [a] -> [b]
map Rank -> Maybe Rank
forall a. a -> Maybe a
Just [Rank]
Attribute.Rank.expendable,
			Maybe Rank
maybePromotionRank	<- Maybe Rank
forall a. Maybe a
Nothing Maybe Rank -> [Maybe Rank] -> [Maybe Rank]
forall a. a -> [a] -> [a]
: (Rank -> Maybe Rank) -> [Rank] -> [Maybe Rank]
forall a b. (a -> b) -> [a] -> [b]
map Rank -> Maybe Rank
forall a. a -> Maybe a
Just [Rank]
Attribute.Rank.promotionProspects
	 ] -- List-comprehension.

-- | Smart constructor for normal move-types.
mkMaybeNormalMoveType
	:: Maybe Attribute.Rank.Rank	-- ^ The /rank/ of any opposing /piece/ which was just taken.
	-> Maybe Attribute.Rank.Rank	-- ^ The /rank/ to which a @Pawn@ was just promoted.
	-> Maybe MoveType		-- ^ Maybe the required /move-type/.
mkMaybeNormalMoveType :: Maybe Rank -> Maybe Rank -> Maybe MoveType
mkMaybeNormalMoveType Maybe Rank
maybeTakenRank Maybe Rank
maybePromotionRank
	| Maybe Rank
maybeTakenRank Maybe Rank -> Maybe Rank -> IsShort
forall a. Eq a => a -> a -> IsShort
/= Rank -> Maybe Rank
forall a. a -> Maybe a
Just Rank
Attribute.Rank.King
	, IsShort -> (Rank -> IsShort) -> Maybe Rank -> IsShort
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe IsShort
True {-nothing promoted-} (
		Rank -> [Rank] -> IsShort
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> IsShort
`elem` [Rank]
Attribute.Rank.promotionProspects
	) Maybe Rank
maybePromotionRank	= MoveType -> Maybe MoveType
forall a. a -> Maybe a
Just Normal :: Maybe Rank -> Maybe Rank -> MoveType
Normal {
		getMaybeTakenRank :: Maybe Rank
getMaybeTakenRank	= Maybe Rank
maybeTakenRank,
		getMaybePromotionRank :: Maybe Rank
getMaybePromotionRank	= Maybe Rank
maybePromotionRank
	}
	| IsShort
otherwise		= Maybe MoveType
forall a. Maybe a
Nothing

-- | Smart-constructor for normal move-types.
mkNormalMoveType
	:: Maybe Attribute.Rank.Rank	-- ^ The /rank/ of any opposing /piece/ which is to be taken.
	-> Maybe Attribute.Rank.Rank	-- ^ The /rank/ to which a @Pawn@ is to be promoted.
	-> MoveType
mkNormalMoveType :: Maybe Rank -> Maybe Rank -> MoveType
mkNormalMoveType Maybe Rank
maybeTakenRank Maybe Rank
maybePromotionRank	= IsShort -> MoveType -> MoveType
forall a. (?callStack::CallStack) => IsShort -> a -> a
Control.Exception.assert (
	Maybe Rank
maybeTakenRank Maybe Rank -> Maybe Rank -> IsShort
forall a. Eq a => a -> a -> IsShort
/= Rank -> Maybe Rank
forall a. a -> Maybe a
Just Rank
Attribute.Rank.King IsShort -> IsShort -> IsShort
&& IsShort -> (Rank -> IsShort) -> Maybe Rank -> IsShort
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe IsShort
True {-nothing promoted-} (
		Rank -> [Rank] -> IsShort
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> IsShort
`elem` [Rank]
Attribute.Rank.promotionProspects
	) Maybe Rank
maybePromotionRank
 ) Normal :: Maybe Rank -> Maybe Rank -> MoveType
Normal {
	getMaybeTakenRank :: Maybe Rank
getMaybeTakenRank	= Maybe Rank
maybeTakenRank,
	getMaybePromotionRank :: Maybe Rank
getMaybePromotionRank	= Maybe Rank
maybePromotionRank
}

-- | Predicate.
isCastle :: MoveType -> Bool
isCastle :: MoveType -> IsShort
isCastle (Castle IsShort
_)	= IsShort
True
isCastle MoveType
_		= IsShort
False

-- | Predicate.
isEnPassant :: MoveType -> Bool
isEnPassant :: MoveType -> IsShort
isEnPassant MoveType
EnPassant	= IsShort
True
isEnPassant MoveType
_		= IsShort
False

-- | Whether a piece was captured, including @Pawn@s taken En-passant.
isCapture :: MoveType -> Bool
{-# INLINE isCapture #-}
isCapture :: MoveType -> IsShort
isCapture Normal { getMaybeTakenRank :: MoveType -> Maybe Rank
getMaybeTakenRank = Just Rank
_ }	= IsShort
True
isCapture MoveType
moveType				= MoveType -> IsShort
isEnPassant MoveType
moveType

-- | Whether the /move/ includes @Pawn@-promotion.
isPromotion :: MoveType -> Bool
isPromotion :: MoveType -> IsShort
isPromotion = Maybe Rank -> IsShort
forall a. Maybe a -> IsShort
Data.Maybe.isJust (Maybe Rank -> IsShort)
-> (MoveType -> Maybe Rank) -> MoveType -> IsShort
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MoveType -> Maybe Rank
getMaybePromotedRank

-- | <https://www.chessprogramming.org/Quiet_Moves>.
isQuiet :: MoveType -> Bool
isQuiet :: MoveType -> IsShort
isQuiet Normal {
	getMaybeTakenRank :: MoveType -> Maybe Rank
getMaybeTakenRank	= Maybe Rank
Nothing,
	getMaybePromotionRank :: MoveType -> Maybe Rank
getMaybePromotionRank	= Maybe Rank
Nothing
}			= IsShort
True
isQuiet	MoveType
moveType	= MoveType -> IsShort
isCastle MoveType
moveType

-- | The simplest type of move.
isSimple :: MoveType -> Bool
isSimple :: MoveType -> IsShort
isSimple Normal {
	getMaybeTakenRank :: MoveType -> Maybe Rank
getMaybeTakenRank	= Maybe Rank
Nothing,
	getMaybePromotionRank :: MoveType -> Maybe Rank
getMaybePromotionRank	= Maybe Rank
Nothing
}		= IsShort
True
isSimple MoveType
_	= IsShort
False	-- Neither Castling nor En-passant qualifies.

{- |
	* Whether the /move/ can't be a member of a repeated cycle.

	* CAVEAT: one can't infer from a negative result that the move can be repeated, since the mover may have been a @Pawn@.
-}
isAcyclic :: MoveType -> Bool
isAcyclic :: MoveType -> IsShort
isAcyclic	= IsShort -> IsShort
not (IsShort -> IsShort)
-> (MoveType -> IsShort) -> MoveType -> IsShort
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MoveType -> IsShort
isSimple	-- Neither capture, promotion, castling nor en-passant can be repeated.

-- | Query whether a /piece/ was explicitly taken, excluding @Pawn@s taken En-passant.
getMaybeExplicitlyTakenRank :: MoveType -> Maybe Attribute.Rank.Rank
getMaybeExplicitlyTakenRank :: MoveType -> Maybe Rank
getMaybeExplicitlyTakenRank Normal { getMaybeTakenRank :: MoveType -> Maybe Rank
getMaybeTakenRank = Maybe Rank
maybeTakenRank }	= Maybe Rank
maybeTakenRank
getMaybeExplicitlyTakenRank MoveType
_							= Maybe Rank
forall a. Maybe a
Nothing

-- | Query whether a /piece/ was taken either explicitly, or implicitly during En-passant.
getMaybeImplicitlyTakenRank :: MoveType -> Maybe Attribute.Rank.Rank
getMaybeImplicitlyTakenRank :: MoveType -> Maybe Rank
getMaybeImplicitlyTakenRank MoveType
EnPassant	= Rank -> Maybe Rank
forall a. a -> Maybe a
Just Rank
Attribute.Rank.Pawn
getMaybeImplicitlyTakenRank MoveType
moveType	= MoveType -> Maybe Rank
getMaybeExplicitlyTakenRank MoveType
moveType

-- | Query the rank to which a piece was promoted.
getMaybePromotedRank :: MoveType -> Maybe Attribute.Rank.Rank
getMaybePromotedRank :: MoveType -> Maybe Rank
getMaybePromotedRank Normal { getMaybePromotionRank :: MoveType -> Maybe Rank
getMaybePromotionRank = Maybe Rank
maybePromotionRank }	= Maybe Rank
maybePromotionRank
getMaybePromotedRank MoveType
_								= Maybe Rank
forall a. Maybe a
Nothing

-- | Returns the mutator required to adjust the number of pieces after a move.
nPiecesMutator :: Enum nPieces => MoveType -> (nPieces -> nPieces)
{-# INLINE nPiecesMutator #-}
nPiecesMutator :: MoveType -> nPieces -> nPieces
nPiecesMutator MoveType
moveType
	| MoveType -> IsShort
isCapture MoveType
moveType	= nPieces -> nPieces
forall a. Enum a => a -> a
pred
	| IsShort
otherwise		= nPieces -> nPieces
forall a. a -> a
id

-- | Permit the caller to react in an arbitrary way, according to a specific move-type.
apply
	:: (
		IsShort -> a,	-- Castle.
		a,		-- En-passant
		(
			Maybe Attribute.Rank.Rank {-captured-},
			Maybe Attribute.Rank.Rank {-promotion-}
		) -> a
	)		-- ^ The handlers for each move-type; Castle, En-passant & Normal.
	-> MoveType
	-> a
apply :: (IsShort -> a, a, (Maybe Rank, Maybe Rank) -> a) -> MoveType -> a
apply (IsShort -> a
onCastle, a
_, (Maybe Rank, Maybe Rank) -> a
_) (Castle IsShort
isShort)	= IsShort -> a
onCastle IsShort
isShort
apply (IsShort -> a
_, a
onEnPassant, (Maybe Rank, Maybe Rank) -> a
_) MoveType
EnPassant	= a
onEnPassant
apply (IsShort -> a
_, a
_, (Maybe Rank, Maybe Rank) -> a
onNormal) Normal {
	getMaybeTakenRank :: MoveType -> Maybe Rank
getMaybeTakenRank	= Maybe Rank
maybeTakenRank,
	getMaybePromotionRank :: MoveType -> Maybe Rank
getMaybePromotionRank	= Maybe Rank
maybePromotionRank
}					= (Maybe Rank, Maybe Rank) -> a
onNormal (Maybe Rank
maybeTakenRank, Maybe Rank
maybePromotionRank)