{-
	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
	origin,
--	xOriginOffset,
--	yOriginOffset,
	regexSyntax,
-- * Functions
--	encode,
	showsCoordinates,
-- ** 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.Cartesian.Abscissa		as Cartesian.Abscissa
import qualified	BishBosh.Cartesian.Coordinates		as Cartesian.Coordinates
import qualified	BishBosh.Cartesian.Ordinate		as Cartesian.Ordinate
import qualified	BishBosh.Component.Move			as Component.Move
import qualified	BishBosh.Component.QualifiedMove	as Component.QualifiedMove
import qualified	Control.Arrow
import qualified	Data.Char
import qualified	Data.Default
import qualified	Data.List.Extra
import qualified	Data.Maybe

-- | The origin.
origin :: (Int, Int)
origin :: (Int, Int)
origin	= ((Char -> Int) -> Char -> Int
forall a b. (a -> b) -> a -> b
$ Char
'a') ((Char -> Int) -> Int)
-> ((Char -> Int) -> Int) -> (Char -> Int) -> (Int, Int)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ((Char -> Int) -> Char -> Int
forall a b. (a -> b) -> a -> b
$ Char
'1') ((Char -> Int) -> (Int, Int)) -> (Char -> Int) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ Char -> Int
Data.Char.ord

-- | The offset of the application's internal coordinate-system from this conventional one.
xOriginOffset, yOriginOffset :: Int
(Int
xOriginOffset, Int
yOriginOffset)	= (Int
Cartesian.Abscissa.xOrigin Int -> Int -> Int
forall a. Num a => a -> a -> a
-) (Int -> Int) -> (Int -> Int) -> (Int, Int) -> (Int, Int)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** (Int
Cartesian.Ordinate.yOrigin Int -> Int -> Int
forall a. Num a => a -> a -> a
-) ((Int, Int) -> (Int, Int)) -> (Int, Int) -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ (Int, Int)
origin

-- | 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
. String -> ShowS
showString String
"EcC]?[" 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 -> Char) -> [Rank] -> String
forall a b. (a -> b) -> [a] -> [b]
map (String -> Char
forall a. [a] -> a
head (String -> Char) -> (Rank -> String) -> Rank -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 x y	= MkSmith {
	Smith x y -> QualifiedMove x y
getQualifiedMove	:: Component.QualifiedMove.QualifiedMove x y
} deriving Smith x y -> Smith x y -> Bool
(Smith x y -> Smith x y -> Bool)
-> (Smith x y -> Smith x y -> Bool) -> Eq (Smith x y)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall x y. (Eq x, Eq y) => Smith x y -> Smith x y -> Bool
/= :: Smith x y -> Smith x y -> Bool
$c/= :: forall x y. (Eq x, Eq y) => Smith x y -> Smith x y -> Bool
== :: Smith x y -> Smith x y -> Bool
$c== :: forall x y. (Eq x, Eq y) => Smith x y -> Smith x y -> Bool
Eq

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

-- | Encodes the ordinate & abscissa.
encode :: (Enum x, Enum y) => Cartesian.Coordinates.Coordinates x y -> (ShowS, ShowS)
encode :: Coordinates x y -> (ShowS, ShowS)
encode	= Char -> ShowS
showChar (Char -> ShowS)
-> (Coordinates x y -> Char) -> Coordinates x y -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
Data.Char.chr (Int -> Char)
-> (Coordinates x y -> Int) -> Coordinates x y -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
xOriginOffset (Int -> Int) -> (Coordinates x y -> Int) -> Coordinates x y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Int
forall a. Enum a => a -> Int
fromEnum (x -> Int) -> (Coordinates x y -> x) -> Coordinates x y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> x
forall x y. Coordinates x y -> x
Cartesian.Coordinates.getX (Coordinates x y -> ShowS)
-> (Coordinates x y -> ShowS) -> Coordinates x y -> (ShowS, ShowS)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Char -> ShowS
showChar (Char -> ShowS)
-> (Coordinates x y -> Char) -> Coordinates x y -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
Data.Char.chr (Int -> Char)
-> (Coordinates x y -> Int) -> Coordinates x y -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
yOriginOffset (Int -> Int) -> (Coordinates x y -> Int) -> Coordinates x y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. y -> Int
forall a. Enum a => a -> Int
fromEnum (y -> Int) -> (Coordinates x y -> y) -> Coordinates x y -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> y
forall x y. Coordinates x y -> y
Cartesian.Coordinates.getY

-- | Shows the specified /coordinates/.
showsCoordinates :: (Enum x, Enum y) => Cartesian.Coordinates.Coordinates x y -> ShowS
showsCoordinates :: Coordinates x y -> ShowS
showsCoordinates	= (ShowS -> ShowS -> ShowS) -> (ShowS, ShowS) -> ShowS
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((ShowS, ShowS) -> ShowS)
-> (Coordinates x y -> (ShowS, ShowS)) -> Coordinates x y -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> (ShowS, ShowS)
forall x y. (Enum x, Enum y) => Coordinates x y -> (ShowS, ShowS)
encode

instance (Enum x, Enum y) => Show (Smith x y) where
	showsPrec :: Int -> Smith x y -> ShowS
showsPrec Int
_ MkSmith { getQualifiedMove :: forall x y. Smith x y -> QualifiedMove x y
getQualifiedMove = QualifiedMove x y
qualifiedMove }	= let
		(Move x y
move, MoveType
moveType)	= QualifiedMove x y -> Move x y
forall x y. QualifiedMove x y -> Move x y
Component.QualifiedMove.getMove (QualifiedMove x y -> Move x y)
-> (QualifiedMove x y -> MoveType)
-> QualifiedMove x y
-> (Move x y, MoveType)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& QualifiedMove x y -> MoveType
forall x y. QualifiedMove x y -> MoveType
Component.QualifiedMove.getMoveType (QualifiedMove x y -> (Move x y, MoveType))
-> QualifiedMove x y -> (Move x y, MoveType)
forall a b. (a -> b) -> a -> b
$ QualifiedMove x y
qualifiedMove
	 in Coordinates x y -> ShowS
forall x y. (Enum x, Enum y) => Coordinates x y -> ShowS
showsCoordinates (
		Move x y -> Coordinates x y
forall x y. Move x y -> Coordinates x y
Component.Move.getSource Move x y
move
	 ) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coordinates x y -> ShowS
forall x y. (Enum x, Enum y) => Coordinates x y -> ShowS
showsCoordinates (
		Move x y -> Coordinates x y
forall x y. Move x y -> Coordinates x y
Component.Move.getDestination Move x y
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
'c'
				else Char
'C'
			MoveType
Attribute.MoveType.EnPassant		-> Char -> ShowS
showChar Char
'E'
			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 (
	Enum	x,
	Enum	y,
	Ord	x,
	Ord	y
 ) => Read (Smith x y) where
	readsPrec :: Int -> ReadS (Smith x y)
readsPrec Int
_ String
s	= case ShowS
Data.List.Extra.trimStart String
s of
		Char
x : Char
y : Char
x' : Char
y' : String
remainder	-> let
			fromSmith :: Char -> Char -> Maybe (Coordinates x y)
fromSmith Char
x'' Char
y''	= x -> y -> Maybe (Coordinates x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
x -> y -> Maybe (Coordinates x y)
Cartesian.Coordinates.mkMaybeCoordinates (
				Int -> x
forall a. Enum a => Int -> a
toEnum (Int -> x) -> Int -> x
forall a b. (a -> b) -> a -> b
$ Char -> Int
Data.Char.ord Char
x'' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
xOriginOffset
			 ) (
				Int -> y
forall a. Enum a => Int -> a
toEnum (Int -> y) -> Int -> y
forall a b. (a -> b) -> a -> b
$ Char -> Int
Data.Char.ord Char
y'' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
yOriginOffset
			 )
		 in [
			(
				QualifiedMove x y -> Smith x y
forall x y. QualifiedMove x y -> Smith x y
fromQualifiedMove (QualifiedMove x y -> Smith x y) -> QualifiedMove x y -> Smith x y
forall a b. (a -> b) -> a -> b
$ Move x y -> MoveType -> QualifiedMove x y
forall x y. Move x y -> MoveType -> QualifiedMove x y
Component.QualifiedMove.mkQualifiedMove (Coordinates x y -> Coordinates x y -> Move x y
forall x y.
(Eq x, Eq y) =>
Coordinates x y -> Coordinates x y -> Move x y
Component.Move.mkMove Coordinates x y
source Coordinates x y
destination) MoveType
moveType,
				String
remainder'
			) |
				Coordinates x y
source			<- Maybe (Coordinates x y) -> [Coordinates x y]
forall a. Maybe a -> [a]
Data.Maybe.maybeToList (Maybe (Coordinates x y) -> [Coordinates x y])
-> Maybe (Coordinates x y) -> [Coordinates x y]
forall a b. (a -> b) -> a -> b
$ Char -> Char -> Maybe (Coordinates x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
Char -> Char -> Maybe (Coordinates x y)
fromSmith Char
x Char
y,
				Coordinates x y
destination		<- Maybe (Coordinates x y) -> [Coordinates x y]
forall a. Maybe a -> [a]
Data.Maybe.maybeToList (Maybe (Coordinates x y) -> [Coordinates x y])
-> Maybe (Coordinates x y) -> [Coordinates x y]
forall a b. (a -> b) -> a -> b
$ Char -> Char -> Maybe (Coordinates x y)
forall x y.
(Enum x, Enum y, Ord x, Ord y) =>
Char -> Char -> Maybe (Coordinates x y)
fromSmith Char
x' Char
y',
				Coordinates x y
source Coordinates x y -> Coordinates x y -> Bool
forall a. Eq a => a -> a -> Bool
/= Coordinates x y
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 x y) where
	getMaybePromotionRank :: Smith x y -> Maybe Rank
getMaybePromotionRank MkSmith { getQualifiedMove :: forall x y. Smith x y -> QualifiedMove x y
getQualifiedMove = QualifiedMove x y
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 x y -> MoveType
forall x y. QualifiedMove x y -> MoveType
Component.QualifiedMove.getMoveType QualifiedMove x y
qualifiedMove