module Chess.Internal.FEN where

import Chess.Internal.Move
import Chess.Internal.Board
import Chess.Internal.Piece
import Data.List
import Data.Char

writeBoard :: Board -> String
writeBoard :: Board -> String
writeBoard = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" ([String] -> String) -> (Board -> [String]) -> Board -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [String]) -> (Board -> String) -> Board -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
emptyToNum ([String] -> String) -> (Board -> [String]) -> Board -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall a. Eq a => [a] -> [[a]]
group (String -> [String]) -> (Board -> String) -> Board -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Board -> String
printBoardCompact
    where emptyToNum :: String -> String
emptyToNum str :: String
str@(Char
' ':String
_) = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str
          emptyToNum String
str = String
str

writePlayer :: Color -> String
writePlayer :: Color -> String
writePlayer Color
White = String
"w"
writePlayer Color
Black = String
"b"

writeCastlings :: [CastlingType] -> [CastlingType] -> String
writeCastlings :: [CastlingType] -> [CastlingType] -> String
writeCastlings [] [] = String
"-"
writeCastlings [CastlingType]
white [CastlingType]
black = String -> String
forall a. Ord a => [a] -> [a]
sort ((CastlingType -> Char) -> [CastlingType] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Color -> CastlingType -> Char
castlingToChar Color
White) [CastlingType]
white String -> String -> String
forall a. [a] -> [a] -> [a]
++ (CastlingType -> Char) -> [CastlingType] -> String
forall a b. (a -> b) -> [a] -> [b]
map (Color -> CastlingType -> Char
castlingToChar Color
Black) [CastlingType]
black)
        where castlingToChar :: Color -> CastlingType -> Char
castlingToChar Color
White CastlingType
Long = Char
'Q'
              castlingToChar Color
White CastlingType
Short = Char
'K'
              castlingToChar Color
Black CastlingType
Long = Char
'q'
              castlingToChar Color
Black CastlingType
Short = Char
'k'

writeEnPassant :: Maybe Coordinates -> String
writeEnPassant :: Maybe Coordinates -> String
writeEnPassant Maybe Coordinates
Nothing = String
"-"
writeEnPassant (Just Coordinates
coordinate) = Coordinates -> String
printCoordinate Coordinates
coordinate

readBoard :: String -> Maybe Board
readBoard :: String -> Maybe Board
readBoard String
str | [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
parts Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
8 = Maybe Board
forall a. Maybe a
Nothing
              | Bool
otherwise = String -> Maybe Board
parseBoardCompact (String -> Maybe Board) -> String -> Maybe Board
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
parts
    where numToEmpty :: Char -> String
numToEmpty Char
x | Char -> Bool
isNumber Char
x = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Char -> Int
digitToInt Char
x) Char
' '
                       | Bool
otherwise = [Char
x]
          parts :: [String]
parts = (Char -> Bool) -> String -> [String]
split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> String
numToEmpty String
str

readPlayer :: String -> Maybe Color
readPlayer :: String -> Maybe Color
readPlayer String
"w" = Color -> Maybe Color
forall a. a -> Maybe a
Just Color
White
readPlayer String
"b" = Color -> Maybe Color
forall a. a -> Maybe a
Just Color
Black
readPlayer String
_ = Maybe Color
forall a. Maybe a
Nothing

readCastlings :: String -> Maybe ([CastlingType], [CastlingType])
readCastlings :: String -> Maybe ([CastlingType], [CastlingType])
readCastlings String
"-" = ([CastlingType], [CastlingType])
-> Maybe ([CastlingType], [CastlingType])
forall a. a -> Maybe a
Just ([], [])
readCastlings String
str = case String -> Maybe ([CastlingType], [CastlingType])
readCastlings' String
str of
                            Maybe ([CastlingType], [CastlingType])
Nothing -> Maybe ([CastlingType], [CastlingType])
forall a. Maybe a
Nothing
                            Just ([CastlingType]
whites, [CastlingType]
blacks) -> if [CastlingType] -> Bool
forall a. Ord a => [a] -> Bool
castlingCountValid [CastlingType]
whites Bool -> Bool -> Bool
&& [CastlingType] -> Bool
forall a. Ord a => [a] -> Bool
castlingCountValid [CastlingType]
blacks then ([CastlingType], [CastlingType])
-> Maybe ([CastlingType], [CastlingType])
forall a. a -> Maybe a
Just ([CastlingType]
whites, [CastlingType]
blacks)
                                                                                                               else Maybe ([CastlingType], [CastlingType])
forall a. Maybe a
Nothing
        where castlingCountValid :: [a] -> Bool
castlingCountValid [a]
castlings = [a] -> [a]
forall a. Ord a => [a] -> [a]
sort ([a] -> [a]
forall a. Eq a => [a] -> [a]
nub [a]
castlings) [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
castlings

readCastlings' :: String -> Maybe ([CastlingType], [CastlingType])
readCastlings' :: String -> Maybe ([CastlingType], [CastlingType])
readCastlings' String
str = do [CastlingType]
whiteCastlings <- (Char -> Maybe CastlingType) -> String -> Maybe [CastlingType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Char -> Maybe CastlingType
toCastling String
whites
                        [CastlingType]
blackCastlings <- (Char -> Maybe CastlingType) -> String -> Maybe [CastlingType]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Char -> Maybe CastlingType
toCastling String
blacks
                        ([CastlingType], [CastlingType])
-> Maybe ([CastlingType], [CastlingType])
forall (m :: * -> *) a. Monad m => a -> m a
return ([CastlingType]
whiteCastlings, [CastlingType]
blackCastlings)
        where whites :: String
whites = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isUpper String
str
              blacks :: String
blacks = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isLower String
str
              toCastling :: Char -> Maybe CastlingType
toCastling Char
'q' = CastlingType -> Maybe CastlingType
forall a. a -> Maybe a
Just CastlingType
Long
              toCastling Char
'k' = CastlingType -> Maybe CastlingType
forall a. a -> Maybe a
Just CastlingType
Short
              toCastling Char
'Q' = CastlingType -> Maybe CastlingType
forall a. a -> Maybe a
Just CastlingType
Long
              toCastling Char
'K' = CastlingType -> Maybe CastlingType
forall a. a -> Maybe a
Just CastlingType
Short
              toCastling Char
_ = Maybe CastlingType
forall a. Maybe a
Nothing

readEnPassant :: String -> Maybe (Maybe Coordinates)
readEnPassant :: String -> Maybe (Maybe Coordinates)
readEnPassant String
"-" = Maybe Coordinates -> Maybe (Maybe Coordinates)
forall a. a -> Maybe a
Just Maybe Coordinates
forall a. Maybe a
Nothing
readEnPassant String
str = case String -> Maybe Coordinates
parseCoordinate String
str of
                      Maybe Coordinates
Nothing -> Maybe (Maybe Coordinates)
forall a. Maybe a
Nothing
                      Maybe Coordinates
coordinate -> Maybe Coordinates -> Maybe (Maybe Coordinates)
forall a. a -> Maybe a
Just Maybe Coordinates
coordinate

readNumberWithLimit :: (Ord a, Read a) => a -> String -> Maybe a
readNumberWithLimit :: a -> String -> Maybe a
readNumberWithLimit a
limit String
str = case String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe String
str of
                                        Maybe a
Nothing -> Maybe a
forall a. Maybe a
Nothing
                                        Just a
number -> if a
number a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
limit
                                                         then a -> Maybe a
forall a. a -> Maybe a
Just a
number
                                                         else Maybe a
forall a. Maybe a
Nothing

readMaybe :: Read a => String -> Maybe a
readMaybe :: String -> Maybe a
readMaybe = ((a, String) -> a) -> Maybe (a, String) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, String) -> a
forall a b. (a, b) -> a
fst (Maybe (a, String) -> Maybe a)
-> (String -> Maybe (a, String)) -> String -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, String) -> Bool) -> [(a, String)] -> Maybe (a, String)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> ((a, String) -> String) -> (a, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, String) -> String
forall a b. (a, b) -> b
snd) ([(a, String)] -> Maybe (a, String))
-> (String -> [(a, String)]) -> String -> Maybe (a, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(a, String)]
forall a. Read a => ReadS a
reads

split :: (Char -> Bool) -> String -> [String]
split :: (Char -> Bool) -> String -> [String]
split Char -> Bool
p String
str = case (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
p String
str of
                String
"" -> []
                String
str' -> String
w String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Char -> Bool) -> String -> [String]
split Char -> Bool
p String
str''
                    where (String
w, String
str'') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
p String
str'