{-
	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@]	<https://www.chessprogramming.org/Warren_D._Smith>.
-}

module BishBosh.Notation.Smith(
-- * Types
-- ** Data-types
	Smith(
--		MkSmith,
		getQualifiedMove
	),
-- * Constants
	notation,
--	enpassantTag,
--	shortCastleTag,
--	longCastleTag,
	regexSyntax,
-- * Functions
-- ** Constructor
	fromQualifiedMove
) where

import			Control.Arrow((&&&))
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.Notation.Notation		as Notation.Notation
import qualified	BishBosh.Notation.PureCoordinate	as Notation.PureCoordinate
import qualified	Control.Arrow
import qualified	Data.Char
import qualified	Data.Default
import qualified	Data.List.Extra
import qualified	Data.Maybe

-- | Define the parameters of the notation, using the minimum permissible values for /x/ & /y/ coordinates.
notation :: Notation.Notation.Notation
notation :: Notation
notation	= Notation
Notation.PureCoordinate.notation	-- CAVEAT: the encoding of coordinates is only coincidentally identical.

-- | Token.
enpassantTag :: Char
enpassantTag :: Char
enpassantTag	= Char
'E'

-- | Token.
shortCastleTag :: Char
shortCastleTag :: Char
shortCastleTag	= Char
'c'

-- | Token.
longCastleTag :: Char
longCastleTag :: Char
longCastleTag	= Char
'C'

-- | Defines using a regex, the required syntax.
regexSyntax :: String
regexSyntax :: String
regexSyntax	= String -> ShowS
showString String
"([a-h][1-8]){2}[" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (
	(Rank -> String) -> [Rank] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Rank -> String
forall a. Show a => a -> String
show [Rank]
Attribute.Rank.range
 ) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
enpassantTag ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
shortCastleTag ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
longCastleTag ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"]?[" ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString (
	ShowS
Data.List.Extra.upper ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ (Rank -> String) -> [Rank] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Rank -> String
forall a. Show a => a -> String
show [Rank]
Attribute.Rank.promotionProspects
 ) String
"]?"

-- | Defines a /move/, to enable i/o in /Smith/-notation.
newtype Smith	= MkSmith {
	Smith -> QualifiedMove
getQualifiedMove	:: Component.QualifiedMove.QualifiedMove
} deriving Smith -> Smith -> Bool
(Smith -> Smith -> Bool) -> (Smith -> Smith -> Bool) -> Eq Smith
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Smith -> Smith -> Bool
$c/= :: Smith -> Smith -> Bool
== :: Smith -> Smith -> Bool
$c== :: Smith -> Smith -> Bool
Eq

-- | Constructor.
fromQualifiedMove :: Component.QualifiedMove.QualifiedMove -> Smith
fromQualifiedMove :: QualifiedMove -> Smith
fromQualifiedMove	= QualifiedMove -> Smith
MkSmith

instance Show Smith where
	showsPrec :: Int -> Smith -> ShowS
showsPrec Int
_ MkSmith { getQualifiedMove :: Smith -> QualifiedMove
getQualifiedMove = QualifiedMove
qualifiedMove }	= let
		(Move
move, MoveType
moveType)	= QualifiedMove -> Move
Component.QualifiedMove.getMove (QualifiedMove -> Move)
-> (QualifiedMove -> MoveType) -> QualifiedMove -> (Move, MoveType)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& QualifiedMove -> MoveType
Component.QualifiedMove.getMoveType (QualifiedMove -> (Move, MoveType))
-> QualifiedMove -> (Move, MoveType)
forall a b. (a -> b) -> a -> b
$ QualifiedMove
qualifiedMove
	 in Notation -> Coordinates -> ShowS
Notation.Notation.showsCoordinates Notation
notation (
		Move -> Coordinates
Component.Move.getSource Move
move
	 ) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Notation -> Coordinates -> ShowS
Notation.Notation.showsCoordinates Notation
notation (
		Move -> Coordinates
Component.Move.getDestination Move
move
	 ) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (
		case MoveType
moveType of
			Attribute.MoveType.Castle Bool
isShort	-> Char -> ShowS
showChar (Char -> ShowS) -> Char -> ShowS
forall a b. (a -> b) -> a -> b
$ if Bool
isShort
				then Char
shortCastleTag
				else Char
longCastleTag
			MoveType
Attribute.MoveType.EnPassant		-> Char -> ShowS
showChar Char
enpassantTag
			MoveType
_ {-normal-}				-> ShowS -> (Rank -> ShowS) -> Maybe Rank -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe ShowS
forall a. a -> a
id Rank -> ShowS
forall a. Show a => a -> ShowS
shows (
				MoveType -> Maybe Rank
Attribute.MoveType.getMaybeExplicitlyTakenRank MoveType
moveType
			 ) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> (Rank -> ShowS) -> Maybe Rank -> ShowS
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe ShowS
forall a. a -> a
id (
				String -> ShowS
showString (String -> ShowS) -> (Rank -> String) -> Rank -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
Data.List.Extra.upper ShowS -> (Rank -> String) -> Rank -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rank -> String
forall a. Show a => a -> String
show
			 ) (
				MoveType -> Maybe Rank
forall a. Promotable a => a -> Maybe Rank
Attribute.Rank.getMaybePromotionRank MoveType
moveType
			 )
	 )

-- N.B. this merely validates the syntax, leaving any semantic errors to 'Model.Game.validate'.
instance Read Smith where
	readsPrec :: Int -> ReadS Smith
readsPrec Int
_ String
s	= case ShowS
Data.List.Extra.trimStart String
s of
		Char
x : Char
y : Char
x' : Char
y' : String
remainder	-> [
			(
				QualifiedMove -> Smith
fromQualifiedMove (QualifiedMove -> Smith) -> QualifiedMove -> Smith
forall a b. (a -> b) -> a -> b
$ Move -> MoveType -> QualifiedMove
Component.QualifiedMove.mkQualifiedMove (Coordinates -> Coordinates -> Move
Component.Move.mkMove Coordinates
source Coordinates
destination) MoveType
moveType,
				String
remainder'
			) |
				let mkCoordinatesList :: CoordinatePairC -> [Coordinates]
mkCoordinatesList	= Maybe Coordinates -> [Coordinates]
forall a. Maybe a -> [a]
Data.Maybe.maybeToList (Maybe Coordinates -> [Coordinates])
-> (CoordinatePairC -> Maybe Coordinates)
-> CoordinatePairC
-> [Coordinates]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Notation -> CoordinatePairC -> Maybe Coordinates
Notation.Notation.mkMaybeCoordinates Notation
notation,
				Coordinates
source			<- CoordinatePairC -> [Coordinates]
mkCoordinatesList (Char
x, Char
y),
				Coordinates
destination		<- CoordinatePairC -> [Coordinates]
mkCoordinatesList (Char
x', Char
y'),
				Coordinates
source Coordinates -> Coordinates -> Bool
forall a. Eq a => a -> a -> Bool
/= Coordinates
destination,
				(MoveType
moveType, String
remainder')	<- case String
remainder of
					[]		-> [(MoveType
forall a. Default a => a
Data.Default.def, String
remainder)]
					Char
'c' : String
s1	-> [(MoveType
Attribute.MoveType.shortCastle, String
s1)]
					Char
'C' : String
s1	-> [(MoveType
Attribute.MoveType.longCastle, String
s1)]
					Char
'E' : String
s1	-> [(MoveType
Attribute.MoveType.enPassant, String
s1)]
					Char
c1 : String
s1		-> (
						\((Maybe Rank, Maybe Rank)
moveType, String
remainder')	-> [(MoveType, String)]
-> (MoveType -> [(MoveType, String)])
-> Maybe MoveType
-> [(MoveType, String)]
forall b a. b -> (a -> b) -> Maybe a -> b
Data.Maybe.maybe [] {-no parse-} (
							(MoveType, String) -> [(MoveType, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return {-List-monad-} ((MoveType, String) -> [(MoveType, String)])
-> (MoveType -> (MoveType, String))
-> MoveType
-> [(MoveType, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MoveType -> String -> (MoveType, String))
-> String -> MoveType -> (MoveType, String)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (,) String
remainder'
						) (Maybe MoveType -> [(MoveType, String)])
-> Maybe MoveType -> [(MoveType, String)]
forall a b. (a -> b) -> a -> b
$ (Maybe Rank -> Maybe Rank -> Maybe MoveType)
-> (Maybe Rank, Maybe Rank) -> Maybe MoveType
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe Rank -> Maybe Rank -> Maybe MoveType
Attribute.MoveType.mkMaybeNormalMoveType (Maybe Rank, Maybe Rank)
moveType
					 ) (((Maybe Rank, Maybe Rank), String) -> [(MoveType, String)])
-> ((Maybe Rank, Maybe Rank), String) -> [(MoveType, String)]
forall a b. (a -> b) -> a -> b
$ case ReadS Rank
forall a. Read a => ReadS a
reads [Char
c1] of
						[(Rank
rank, String
"")]
							| Char -> Bool
Data.Char.isUpper Char
c1 {-promotion-}	-> ((Maybe Rank
forall a. Maybe a
Nothing, Rank -> Maybe Rank
forall a. a -> Maybe a
Just Rank
rank), String
s1)
							| Bool
otherwise {-lower-case => capture-}	-> (Maybe Rank -> (Maybe Rank, Maybe Rank))
-> (Maybe Rank, String) -> ((Maybe Rank, Maybe Rank), String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Control.Arrow.first (
								(,) (Maybe Rank -> Maybe Rank -> (Maybe Rank, Maybe Rank))
-> Maybe Rank -> Maybe Rank -> (Maybe Rank, Maybe Rank)
forall a b. (a -> b) -> a -> b
$ Rank -> Maybe Rank
forall a. a -> Maybe a
Just Rank
rank
							) ((Maybe Rank, String) -> ((Maybe Rank, Maybe Rank), String))
-> (Maybe Rank, String) -> ((Maybe Rank, Maybe Rank), String)
forall a b. (a -> b) -> a -> b
$ case String
s1 of
								Char
c2 : String
s2
									| Char -> Bool
Data.Char.isUpper Char
c2	-> case ReadS Rank
forall a. Read a => ReadS a
reads [Char
c2] of
										[(Rank
promotionRank, String
"")]	-> (Rank -> Maybe Rank
forall a. a -> Maybe a
Just Rank
promotionRank, String
s2)
										[(Rank, String)]
_			-> (Maybe Rank
forall a. Maybe a
Nothing, String
s1)
									| Bool
otherwise		-> (Maybe Rank
forall a. Maybe a
Nothing, String
s1)
								[]	-> (Maybe Rank
forall a. Maybe a
Nothing, String
s1)
						[(Rank, String)]
_	-> ((Maybe Rank
forall a. Maybe a
Nothing, Maybe Rank
forall a. Maybe a
Nothing), String
remainder)
		 ] -- List-comprehension.
		String
_				-> []	-- No parse.

instance Attribute.Rank.Promotable Smith where
	getMaybePromotionRank :: Smith -> Maybe Rank
getMaybePromotionRank MkSmith { getQualifiedMove :: Smith -> QualifiedMove
getQualifiedMove = QualifiedMove
qualifiedMove }	= MoveType -> Maybe Rank
forall a. Promotable a => a -> Maybe Rank
Attribute.Rank.getMaybePromotionRank (MoveType -> Maybe Rank) -> MoveType -> Maybe Rank
forall a b. (a -> b) -> a -> b
$ QualifiedMove -> MoveType
Component.QualifiedMove.getMoveType QualifiedMove
qualifiedMove