{-# LANGUAGE GADTs #-}
module Game.Chess.PGN (
  readPGNFile, gameFromForest, pgnForest, PGN(..), Game, Outcome(..)
, hPutPGN, pgnDoc, RAVOrder, breadthFirst, depthFirst, gameDoc
, weightedForest
) where

import Control.Monad
import Data.Bifunctor
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Foldable
import Data.Functor
import Data.List
import Data.Maybe
import Data.Ord
import Data.Ratio
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Prettyprint.Doc hiding (space)
import Data.Text.Prettyprint.Doc.Render.Text
import Data.Tree
import Data.Word
import Data.Void
import Game.Chess
import Game.Chess.SAN
import System.IO
import Text.Megaparsec
import Text.Megaparsec.Byte
import qualified Text.Megaparsec.Byte.Lexer as L

gameFromForest :: [(ByteString, Text)] -> Forest Ply -> Outcome -> Game
gameFromForest :: [(ByteString, Text)] -> Forest Ply -> Outcome -> Game
gameFromForest [(ByteString, Text)]
tags Forest Ply
forest Outcome
o = ((ByteString
"Result", Text
r)(ByteString, Text) -> [(ByteString, Text)] -> [(ByteString, Text)]
forall a. a -> [a] -> [a]
:[(ByteString, Text)]
tags, (Outcome
o, ((Tree Ply -> Tree PlyData) -> Forest Ply -> [Tree PlyData]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Tree Ply -> Tree PlyData) -> Forest Ply -> [Tree PlyData])
-> ((Ply -> PlyData) -> Tree Ply -> Tree PlyData)
-> (Ply -> PlyData)
-> Forest Ply
-> [Tree PlyData]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ply -> PlyData) -> Tree Ply -> Tree PlyData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Ply -> PlyData
f Forest Ply
forest)) where
  f :: Ply -> PlyData
f Ply
pl = [Int] -> Ply -> [Int] -> PlyData
PlyData [] Ply
pl []
  r :: Text
r = case Outcome
o of
    Win Color
White -> Text
"1-0"
    Win Color
Black -> Text
"0-1"
    Outcome
Draw      -> Text
"1/2-1/2"
    Outcome
Undecided -> Text
"*"

newtype PGN = PGN [Game] deriving (PGN -> PGN -> Bool
(PGN -> PGN -> Bool) -> (PGN -> PGN -> Bool) -> Eq PGN
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PGN -> PGN -> Bool
$c/= :: PGN -> PGN -> Bool
== :: PGN -> PGN -> Bool
$c== :: PGN -> PGN -> Bool
Eq, Semigroup PGN
PGN
Semigroup PGN
-> PGN -> (PGN -> PGN -> PGN) -> ([PGN] -> PGN) -> Monoid PGN
[PGN] -> PGN
PGN -> PGN -> PGN
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [PGN] -> PGN
$cmconcat :: [PGN] -> PGN
mappend :: PGN -> PGN -> PGN
$cmappend :: PGN -> PGN -> PGN
mempty :: PGN
$cmempty :: PGN
$cp1Monoid :: Semigroup PGN
Monoid, b -> PGN -> PGN
NonEmpty PGN -> PGN
PGN -> PGN -> PGN
(PGN -> PGN -> PGN)
-> (NonEmpty PGN -> PGN)
-> (forall b. Integral b => b -> PGN -> PGN)
-> Semigroup PGN
forall b. Integral b => b -> PGN -> PGN
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> PGN -> PGN
$cstimes :: forall b. Integral b => b -> PGN -> PGN
sconcat :: NonEmpty PGN -> PGN
$csconcat :: NonEmpty PGN -> PGN
<> :: PGN -> PGN -> PGN
$c<> :: PGN -> PGN -> PGN
Semigroup)
type Game = ([(ByteString, Text)], (Outcome, Forest PlyData))
data Outcome = Win Color
             | Draw
             | Undecided
             deriving (Outcome -> Outcome -> Bool
(Outcome -> Outcome -> Bool)
-> (Outcome -> Outcome -> Bool) -> Eq Outcome
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Outcome -> Outcome -> Bool
$c/= :: Outcome -> Outcome -> Bool
== :: Outcome -> Outcome -> Bool
$c== :: Outcome -> Outcome -> Bool
Eq, Int -> Outcome -> ShowS
[Outcome] -> ShowS
Outcome -> String
(Int -> Outcome -> ShowS)
-> (Outcome -> String) -> ([Outcome] -> ShowS) -> Show Outcome
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Outcome] -> ShowS
$cshowList :: [Outcome] -> ShowS
show :: Outcome -> String
$cshow :: Outcome -> String
showsPrec :: Int -> Outcome -> ShowS
$cshowsPrec :: Int -> Outcome -> ShowS
Show)

pgnForest :: PGN -> Forest Ply
pgnForest :: PGN -> Forest Ply
pgnForest (PGN [Game]
gs) = Forest Ply -> Forest Ply
forall a. Eq a => Forest a -> Forest a
merge (Forest Ply -> Forest Ply) -> Forest Ply -> Forest Ply
forall a b. (a -> b) -> a -> b
$ (Game -> Forest Ply) -> [Game] -> Forest Ply
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Tree PlyData -> Tree Ply) -> [Tree PlyData] -> Forest Ply
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Tree PlyData -> Tree Ply) -> [Tree PlyData] -> Forest Ply)
-> ((PlyData -> Ply) -> Tree PlyData -> Tree Ply)
-> (PlyData -> Ply)
-> [Tree PlyData]
-> Forest Ply
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PlyData -> Ply) -> Tree PlyData -> Tree Ply
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) PlyData -> Ply
pgnPly ([Tree PlyData] -> Forest Ply)
-> (Game -> [Tree PlyData]) -> Game -> Forest Ply
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Outcome, [Tree PlyData]) -> [Tree PlyData]
forall a b. (a, b) -> b
snd ((Outcome, [Tree PlyData]) -> [Tree PlyData])
-> (Game -> (Outcome, [Tree PlyData])) -> Game -> [Tree PlyData]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game -> (Outcome, [Tree PlyData])
forall a b. (a, b) -> b
snd) [Game]
gs

merge :: Eq a => Forest a -> Forest a
merge :: Forest a -> Forest a
merge = (Forest a -> Tree a -> Forest a)
-> Forest a -> Forest a -> Forest a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Forest a -> Tree a -> Forest a
forall a. Eq a => Forest a -> Tree a -> Forest a
mergeTree [] where
  merge' :: Tree a -> Tree a -> Tree a
merge' Tree a
l Tree a
r = Tree a
l { subForest :: Forest a
subForest = (Forest a -> Tree a -> Forest a)
-> Forest a -> Forest a -> Forest a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Forest a -> Tree a -> Forest a
mergeTree (Tree a -> Forest a
forall a. Tree a -> Forest a
subForest Tree a
l) (Tree a -> Forest a
forall a. Tree a -> Forest a
subForest Tree a
r) }
  mergeTree :: Forest a -> Tree a -> Forest a
mergeTree [] Tree a
y = [Tree a
y]
  mergeTree (Tree a
x:Forest a
xs) Tree a
y
    | Tree a -> a
forall a. Tree a -> a
rootLabel Tree a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Tree a -> a
forall a. Tree a -> a
rootLabel Tree a
y = Tree a
x Tree a -> Tree a -> Tree a
`merge'` Tree a
y Tree a -> Forest a -> Forest a
forall a. a -> [a] -> [a]
: Forest a
xs
    | Bool
otherwise = Tree a
x Tree a -> Forest a -> Forest a
forall a. a -> [a] -> [a]
: Forest a
xs Forest a -> Tree a -> Forest a
`mergeTree` Tree a
y


instance Ord Outcome where
  Win Color
_ compare :: Outcome -> Outcome -> Ordering
`compare` Win Color
_ = Ordering
EQ
  Win Color
_ `compare` Outcome
_ = Ordering
GT
  Outcome
_ `compare` Win Color
_ = Ordering
LT
  Outcome
Draw `compare` Outcome
Draw = Ordering
EQ
  Outcome
Draw `compare` Outcome
_ = Ordering
GT
  Outcome
_ `compare` Outcome
Draw = Ordering
LT
  Outcome
Undecided `compare` Outcome
Undecided = Ordering
EQ

instance Pretty Outcome where
  pretty :: Outcome -> Doc ann
pretty (Win Color
White) = Doc ann
"1-0"
  pretty (Win Color
Black) = Doc ann
"0-1"
  pretty Outcome
Draw        = Doc ann
"1/2-1/2"
  pretty Outcome
Undecided   = Doc ann
"*"

data PlyData = PlyData {
  PlyData -> [Int]
prefixNAG :: ![Int]
, PlyData -> Ply
pgnPly :: !Ply
, PlyData -> [Int]
suffixNAG :: ![Int]
} deriving (PlyData -> PlyData -> Bool
(PlyData -> PlyData -> Bool)
-> (PlyData -> PlyData -> Bool) -> Eq PlyData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PlyData -> PlyData -> Bool
$c/= :: PlyData -> PlyData -> Bool
== :: PlyData -> PlyData -> Bool
$c== :: PlyData -> PlyData -> Bool
Eq, Int -> PlyData -> ShowS
[PlyData] -> ShowS
PlyData -> String
(Int -> PlyData -> ShowS)
-> (PlyData -> String) -> ([PlyData] -> ShowS) -> Show PlyData
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlyData] -> ShowS
$cshowList :: [PlyData] -> ShowS
show :: PlyData -> String
$cshow :: PlyData -> String
showsPrec :: Int -> PlyData -> ShowS
$cshowsPrec :: Int -> PlyData -> ShowS
Show)

readPGNFile :: FilePath -> IO (Either String PGN)
readPGNFile :: String -> IO (Either String PGN)
readPGNFile String
fp = (ParseErrorBundle ByteString Void -> String)
-> Either (ParseErrorBundle ByteString Void) PGN
-> Either String PGN
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle ByteString Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty (Either (ParseErrorBundle ByteString Void) PGN
 -> Either String PGN)
-> (ByteString -> Either (ParseErrorBundle ByteString Void) PGN)
-> ByteString
-> Either String PGN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void ByteString PGN
-> String
-> ByteString
-> Either (ParseErrorBundle ByteString Void) PGN
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void ByteString PGN
pgn String
fp (ByteString -> Either String PGN)
-> IO ByteString -> IO (Either String PGN)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS.readFile String
fp

hPutPGN :: Handle -> RAVOrder (Doc ann) -> PGN -> IO ()
hPutPGN :: Handle -> RAVOrder (Doc ann) -> PGN -> IO ()
hPutPGN Handle
h RAVOrder (Doc ann)
ro (PGN [Game]
games) = [Game] -> (Game -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Game]
games ((Game -> IO ()) -> IO ()) -> (Game -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Game
g -> do
  Handle -> Doc ann -> IO ()
forall ann. Handle -> Doc ann -> IO ()
hPutDoc Handle
h (Doc ann -> IO ()) -> Doc ann -> IO ()
forall a b. (a -> b) -> a -> b
$ RAVOrder (Doc ann) -> Game -> Doc ann
forall ann. RAVOrder (Doc ann) -> Game -> Doc ann
gameDoc RAVOrder (Doc ann)
ro Game
g
  Handle -> String -> IO ()
hPutStrLn Handle
h String
""

type Parser = Parsec Void ByteString

spaceConsumer :: Parser ()
spaceConsumer :: Parser ()
spaceConsumer = Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
  Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
space1 (Tokens ByteString -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Tokens s -> m ()
L.skipLineComment Tokens ByteString
";") (Tokens ByteString -> Tokens ByteString -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Tokens s -> Tokens s -> m ()
L.skipBlockComment Tokens ByteString
"{" Tokens ByteString
"}")

lexeme :: Parser a -> Parser a
lexeme :: Parser a -> Parser a
lexeme = Parser () -> Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
spaceConsumer

eog :: Parser Outcome
eog :: Parser Outcome
eog = Parser Outcome -> Parser Outcome
forall a. Parser a -> Parser a
lexeme (Parser Outcome -> Parser Outcome)
-> Parser Outcome -> Parser Outcome
forall a b. (a -> b) -> a -> b
$  Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"1-0" ParsecT Void ByteString Identity ByteString
-> Outcome -> Parser Outcome
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Color -> Outcome
Win Color
White
            Parser Outcome -> Parser Outcome -> Parser Outcome
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"0-1" ParsecT Void ByteString Identity ByteString
-> Outcome -> Parser Outcome
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Color -> Outcome
Win Color
Black
            Parser Outcome -> Parser Outcome -> Parser Outcome
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"1/2-1/2" ParsecT Void ByteString Identity ByteString
-> Outcome -> Parser Outcome
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Outcome
Draw
            Parser Outcome -> Parser Outcome -> Parser Outcome
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"*" ParsecT Void ByteString Identity ByteString
-> Outcome -> Parser Outcome
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Outcome
Undecided

sym :: Parser ByteString
sym :: ParsecT Void ByteString Identity ByteString
sym = ParsecT Void ByteString Identity ByteString
-> ParsecT Void ByteString Identity ByteString
forall a. Parser a -> Parser a
lexeme (ParsecT Void ByteString Identity ByteString
 -> ParsecT Void ByteString Identity ByteString)
-> (ParsecT Void ByteString Identity [Word8]
    -> ParsecT Void ByteString Identity ByteString)
-> ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, [Word8]) -> ByteString)
-> ParsecT Void ByteString Identity (ByteString, [Word8])
-> ParsecT Void ByteString Identity ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, [Word8]) -> ByteString
forall a b. (a, b) -> a
fst (ParsecT Void ByteString Identity (ByteString, [Word8])
 -> ParsecT Void ByteString Identity ByteString)
-> (ParsecT Void ByteString Identity [Word8]
    -> ParsecT Void ByteString Identity (ByteString, [Word8]))
-> ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity (ByteString, [Word8])
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match (ParsecT Void ByteString Identity [Word8]
 -> ParsecT Void ByteString Identity ByteString)
-> ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity ByteString
forall a b. (a -> b) -> a -> b
$ do
  ParsecT Void ByteString Identity Word8 -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void ByteString Identity Word8
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
alphaNumChar
  ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT Void ByteString Identity Word8
 -> ParsecT Void ByteString Identity [Word8])
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
forall a b. (a -> b) -> a -> b
$ ParsecT Void ByteString Identity Word8
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m (Token s)
alphaNumChar ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Token ByteString]
-> ParsecT Void ByteString Identity (Token ByteString)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Word8
35,Word8
43,Word8
45,Word8
58,Word8
61,Word8
95]

periodChar, quoteChar, backslashChar, dollarChar :: Word8
periodChar :: Word8
periodChar    = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'.'
quoteChar :: Word8
quoteChar     = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'"'
backslashChar :: Word8
backslashChar = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'\\'
dollarChar :: Word8
dollarChar    = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'$'

lbracketP, rbracketP, lparenP, rparenP :: Parser ()
lbracketP :: Parser ()
lbracketP = ParsecT Void ByteString Identity Word8 -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void ByteString Identity Word8 -> Parser ())
-> (Int -> ParsecT Void ByteString Identity Word8)
-> Int
-> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
forall a. Parser a -> Parser a
lexeme (ParsecT Void ByteString Identity Word8
 -> ParsecT Void ByteString Identity Word8)
-> (Int -> ParsecT Void ByteString Identity Word8)
-> Int
-> ParsecT Void ByteString Identity Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ParsecT Void ByteString Identity Word8
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single (Word8 -> ParsecT Void ByteString Identity Word8)
-> (Int -> Word8) -> Int -> ParsecT Void ByteString Identity Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Parser ()) -> Int -> Parser ()
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'['
rbracketP :: Parser ()
rbracketP = ParsecT Void ByteString Identity Word8 -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void ByteString Identity Word8 -> Parser ())
-> (Int -> ParsecT Void ByteString Identity Word8)
-> Int
-> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
forall a. Parser a -> Parser a
lexeme (ParsecT Void ByteString Identity Word8
 -> ParsecT Void ByteString Identity Word8)
-> (Int -> ParsecT Void ByteString Identity Word8)
-> Int
-> ParsecT Void ByteString Identity Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ParsecT Void ByteString Identity Word8
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single (Word8 -> ParsecT Void ByteString Identity Word8)
-> (Int -> Word8) -> Int -> ParsecT Void ByteString Identity Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Parser ()) -> Int -> Parser ()
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
']'
lparenP :: Parser ()
lparenP   = ParsecT Void ByteString Identity Word8 -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void ByteString Identity Word8 -> Parser ())
-> (Int -> ParsecT Void ByteString Identity Word8)
-> Int
-> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
forall a. Parser a -> Parser a
lexeme (ParsecT Void ByteString Identity Word8
 -> ParsecT Void ByteString Identity Word8)
-> (Int -> ParsecT Void ByteString Identity Word8)
-> Int
-> ParsecT Void ByteString Identity Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ParsecT Void ByteString Identity Word8
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single (Word8 -> ParsecT Void ByteString Identity Word8)
-> (Int -> Word8) -> Int -> ParsecT Void ByteString Identity Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Parser ()) -> Int -> Parser ()
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'('
rparenP :: Parser ()
rparenP   = ParsecT Void ByteString Identity Word8 -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void ByteString Identity Word8 -> Parser ())
-> (Int -> ParsecT Void ByteString Identity Word8)
-> Int
-> Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
forall a. Parser a -> Parser a
lexeme (ParsecT Void ByteString Identity Word8
 -> ParsecT Void ByteString Identity Word8)
-> (Int -> ParsecT Void ByteString Identity Word8)
-> Int
-> ParsecT Void ByteString Identity Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ParsecT Void ByteString Identity Word8
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single (Word8 -> ParsecT Void ByteString Identity Word8)
-> (Int -> Word8) -> Int -> ParsecT Void ByteString Identity Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Parser ()) -> Int -> Parser ()
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
')'

nag :: Parser Int
nag :: Parser Int
nag = Parser Int -> Parser Int
forall a. Parser a -> Parser a
lexeme (Parser Int -> Parser Int) -> Parser Int -> Parser Int
forall a b. (a -> b) -> a -> b
$  Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
dollarChar ParsecT Void ByteString Identity Word8 -> Parser Int -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Word8, Num a) =>
m a
L.decimal
            Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"!!" ParsecT Void ByteString Identity ByteString -> Int -> Parser Int
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
3
            Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"??" ParsecT Void ByteString Identity ByteString -> Int -> Parser Int
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
4
            Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"!?" ParsecT Void ByteString Identity ByteString -> Int -> Parser Int
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
5
            Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"?!" ParsecT Void ByteString Identity ByteString -> Int -> Parser Int
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
6
            Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"!"  ParsecT Void ByteString Identity ByteString -> Int -> Parser Int
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
1
            Parser Int -> Parser Int -> Parser Int
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"?"  ParsecT Void ByteString Identity ByteString -> Int -> Parser Int
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Int
2

tagPair :: Parser (ByteString, Text)
tagPair :: Parser (ByteString, Text)
tagPair = Parser (ByteString, Text) -> Parser (ByteString, Text)
forall a. Parser a -> Parser a
lexeme (Parser (ByteString, Text) -> Parser (ByteString, Text))
-> Parser (ByteString, Text) -> Parser (ByteString, Text)
forall a b. (a -> b) -> a -> b
$ do
  Parser ()
lbracketP
  ByteString
k <- ParsecT Void ByteString Identity ByteString
sym
  Text
v <- Parser Text
str
  Parser ()
rbracketP
  (ByteString, Text) -> Parser (ByteString, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString
k, Text
v)

tagList :: Parser [(ByteString, Text)]
tagList :: Parser [(ByteString, Text)]
tagList = Parser (ByteString, Text) -> Parser [(ByteString, Text)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser (ByteString, Text)
tagPair

movetext :: Position -> Parser (Outcome, Forest PlyData)
movetext :: Position -> Parser (Outcome, [Tree PlyData])
movetext Position
pos = (,[]) (Outcome -> (Outcome, [Tree PlyData]))
-> Parser Outcome -> Parser (Outcome, [Tree PlyData])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Outcome
eog Parser (Outcome, [Tree PlyData])
-> Parser (Outcome, [Tree PlyData])
-> Parser (Outcome, [Tree PlyData])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Position -> Parser (Outcome, [Tree PlyData])
main Position
pos where
  main :: Position -> Parser (Outcome, [Tree PlyData])
main Position
p = Position
-> ParsecT
     Void ByteString Identity (Ply, [Tree PlyData] -> [Tree PlyData])
ply Position
p ParsecT
  Void ByteString Identity (Ply, [Tree PlyData] -> [Tree PlyData])
-> ((Ply, [Tree PlyData] -> [Tree PlyData])
    -> Parser (Outcome, [Tree PlyData]))
-> Parser (Outcome, [Tree PlyData])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Ply
m, [Tree PlyData] -> [Tree PlyData]
n) -> ([Tree PlyData] -> [Tree PlyData])
-> (Outcome, [Tree PlyData]) -> (Outcome, [Tree PlyData])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Tree PlyData] -> [Tree PlyData]
n ((Outcome, [Tree PlyData]) -> (Outcome, [Tree PlyData]))
-> Parser (Outcome, [Tree PlyData])
-> Parser (Outcome, [Tree PlyData])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position -> Parser (Outcome, [Tree PlyData])
movetext (Position -> Ply -> Position
unsafeDoPly Position
p Ply
m)
  var :: Position -> ParsecT Void ByteString Identity [Tree PlyData]
var Position
p = Position
-> ParsecT
     Void ByteString Identity (Ply, [Tree PlyData] -> [Tree PlyData])
ply Position
p ParsecT
  Void ByteString Identity (Ply, [Tree PlyData] -> [Tree PlyData])
-> ((Ply, [Tree PlyData] -> [Tree PlyData])
    -> ParsecT Void ByteString Identity [Tree PlyData])
-> ParsecT Void ByteString Identity [Tree PlyData]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Ply
m, [Tree PlyData] -> [Tree PlyData]
n) -> [Tree PlyData] -> [Tree PlyData]
n ([Tree PlyData] -> [Tree PlyData])
-> ParsecT Void ByteString Identity [Tree PlyData]
-> ParsecT Void ByteString Identity [Tree PlyData]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ()
rparenP Parser ()
-> [Tree PlyData]
-> ParsecT Void ByteString Identity [Tree PlyData]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [] ParsecT Void ByteString Identity [Tree PlyData]
-> ParsecT Void ByteString Identity [Tree PlyData]
-> ParsecT Void ByteString Identity [Tree PlyData]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Position -> ParsecT Void ByteString Identity [Tree PlyData]
var (Position -> Ply -> Position
unsafeDoPly Position
p Ply
m))
  ply :: Position
-> ParsecT
     Void ByteString Identity (Ply, [Tree PlyData] -> [Tree PlyData])
ply Position
p = do
    [Int]
pnags <- Parser Int -> ParsecT Void ByteString Identity [Int]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Int
nag
    Position -> Parser ()
validateMoveNumber Position
p
    Ply
m <- Parser Ply -> Parser Ply
forall a. Parser a -> Parser a
lexeme (Parser Ply -> Parser Ply) -> Parser Ply -> Parser Ply
forall a b. (a -> b) -> a -> b
$ Position -> Parser Ply
forall s.
(Stream s, SANToken (Token s), IsString (Tokens s)) =>
Position -> Parser s Ply
relaxedSAN Position
p
    [Int]
snags <- Parser Int -> ParsecT Void ByteString Identity [Int]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Int
nag
    [Tree PlyData]
rav <- [[Tree PlyData]] -> [Tree PlyData]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Tree PlyData]] -> [Tree PlyData])
-> ParsecT Void ByteString Identity [[Tree PlyData]]
-> ParsecT Void ByteString Identity [Tree PlyData]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void ByteString Identity [Tree PlyData]
-> ParsecT Void ByteString Identity [[Tree PlyData]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Parser ()
lparenP Parser ()
-> ParsecT Void ByteString Identity [Tree PlyData]
-> ParsecT Void ByteString Identity [Tree PlyData]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Position -> ParsecT Void ByteString Identity [Tree PlyData]
var Position
p)
    (Ply, [Tree PlyData] -> [Tree PlyData])
-> ParsecT
     Void ByteString Identity (Ply, [Tree PlyData] -> [Tree PlyData])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ply
m, \[Tree PlyData]
xs -> PlyData -> [Tree PlyData] -> Tree PlyData
forall a. a -> Forest a -> Tree a
Node ([Int] -> Ply -> [Int] -> PlyData
PlyData [Int]
pnags Ply
m [Int]
snags) [Tree PlyData]
xsTree PlyData -> [Tree PlyData] -> [Tree PlyData]
forall a. a -> [a] -> [a]
:[Tree PlyData]
rav)
  validateMoveNumber :: Position -> Parser ()
validateMoveNumber Position
p =
    Parser Int -> ParsecT Void ByteString Identity (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser Int -> Parser Int
forall a. Parser a -> Parser a
lexeme (Parser Int -> Parser Int) -> Parser Int -> Parser Int
forall a b. (a -> b) -> a -> b
$ Parser Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Word8, Num a) =>
m a
L.decimal Parser Int -> Parser () -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
space Parser Int
-> ParsecT Void ByteString Identity [Word8] -> Parser Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
periodChar)) ParsecT Void ByteString Identity (Maybe Int)
-> (Maybe Int -> Parser ()) -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Int
n | Position -> Int
moveNumber Position
p Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n ->
        String -> Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser ()) -> String -> Parser ()
forall a b. (a -> b) -> a -> b
$ String
"Invalid move number: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" /= " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Position -> Int
moveNumber Position
p)
      Maybe Int
_ -> () -> Parser ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

pgn :: Parser PGN
pgn :: Parsec Void ByteString PGN
pgn = Parser ()
spaceConsumer Parser ()
-> Parsec Void ByteString PGN -> Parsec Void ByteString PGN
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ([Game] -> PGN)
-> ParsecT Void ByteString Identity [Game]
-> Parsec Void ByteString PGN
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Game] -> PGN
PGN (ParsecT Void ByteString Identity Game
-> ParsecT Void ByteString Identity [Game]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void ByteString Identity Game
game) Parsec Void ByteString PGN
-> Parser () -> Parsec Void ByteString PGN
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
spaceConsumer Parsec Void ByteString PGN
-> Parser () -> Parsec Void ByteString PGN
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof

game :: Parser Game
game :: ParsecT Void ByteString Identity Game
game = do
  [(ByteString, Text)]
tl <- Parser [(ByteString, Text)]
tagList
  Position
pos <- case ByteString -> [(ByteString, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"FEN" [(ByteString, Text)]
tl of
    Maybe Text
Nothing -> Position -> ParsecT Void ByteString Identity Position
forall (f :: * -> *) a. Applicative f => a -> f a
pure Position
startpos
    Just Text
fen -> case String -> Maybe Position
fromFEN (Text -> String
T.unpack Text
fen) of
      Just Position
p -> Position -> ParsecT Void ByteString Identity Position
forall (f :: * -> *) a. Applicative f => a -> f a
pure Position
p
      Maybe Position
Nothing -> String -> ParsecT Void ByteString Identity Position
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid FEN"
  ([(ByteString, Text)]
tl,) ((Outcome, [Tree PlyData]) -> Game)
-> Parser (Outcome, [Tree PlyData])
-> ParsecT Void ByteString Identity Game
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position -> Parser (Outcome, [Tree PlyData])
movetext Position
pos
  
str :: Parser Text
str :: Parser Text
str = Parser Text
p Parser Text -> String -> Parser Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"string" where
  p :: Parser Text
p = ([Word8] -> Text)
-> ParsecT Void ByteString Identity [Word8] -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
T.pack (String -> Text) -> ([Word8] -> String) -> [Word8] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Char) -> [Word8] -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a. Enum a => a -> Int
fromEnum)) (ParsecT Void ByteString Identity [Word8] -> Parser Text)
-> ParsecT Void ByteString Identity [Word8] -> Parser Text
forall a b. (a -> b) -> a -> b
$ Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
quoteChar ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity [Word8]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void ByteString Identity Word8
ch ParsecT Void ByteString Identity [Word8]
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity [Word8]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
quoteChar
  ch :: ParsecT Void ByteString Identity Word8
ch = Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
backslashChar ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (  Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
backslashChar ParsecT Void ByteString Identity Word8
-> Word8 -> ParsecT Void ByteString Identity Word8
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Word8
backslashChar
                          ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
Token ByteString
quoteChar ParsecT Void ByteString Identity Word8
-> Word8 -> ParsecT Void ByteString Identity Word8
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Word8
quoteChar
                           )
   ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
-> ParsecT Void ByteString Identity Word8
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token ByteString
-> ParsecT Void ByteString Identity (Token ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
anySingleBut Word8
Token ByteString
quoteChar

type RAVOrder a = (Forest PlyData -> a) -> Forest PlyData -> [a]

breadthFirst, depthFirst :: RAVOrder a
breadthFirst :: RAVOrder a
breadthFirst [Tree PlyData] -> a
_ [] = []
breadthFirst [Tree PlyData] -> a
f [Tree PlyData]
ts = a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> [a]) -> a -> [a]
forall a b. (a -> b) -> a -> b
$ [Tree PlyData] -> a
f [Tree PlyData]
ts
depthFirst :: RAVOrder a
depthFirst [Tree PlyData] -> a
f = (Tree PlyData -> a) -> [Tree PlyData] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Tree PlyData -> a) -> [Tree PlyData] -> [a])
-> (Tree PlyData -> a) -> [Tree PlyData] -> [a]
forall a b. (a -> b) -> a -> b
$ [Tree PlyData] -> a
f ([Tree PlyData] -> a)
-> (Tree PlyData -> [Tree PlyData]) -> Tree PlyData -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree PlyData -> [Tree PlyData]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

pgnDoc :: RAVOrder (Doc ann) -> PGN -> Doc ann
pgnDoc :: RAVOrder (Doc ann) -> PGN -> Doc ann
pgnDoc RAVOrder (Doc ann)
ro (PGN [Game]
games) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$ RAVOrder (Doc ann) -> Game -> Doc ann
forall ann. RAVOrder (Doc ann) -> Game -> Doc ann
gameDoc RAVOrder (Doc ann)
ro (Game -> Doc ann) -> [Game] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Game]
games

gameDoc :: RAVOrder (Doc ann) -> Game -> Doc ann
gameDoc :: RAVOrder (Doc ann) -> Game -> Doc ann
gameDoc RAVOrder (Doc ann)
ro ([(ByteString, Text)]
tl, (Outcome, [Tree PlyData])
mt)
  | [(ByteString, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ByteString, Text)]
tl = RAVOrder (Doc ann)
-> Position -> (Outcome, [Tree PlyData]) -> Doc ann
forall ann.
RAVOrder (Doc ann)
-> Position -> (Outcome, [Tree PlyData]) -> Doc ann
moveDoc RAVOrder (Doc ann)
ro Position
pos (Outcome, [Tree PlyData])
mt
  | Bool
otherwise = [(ByteString, Text)] -> Doc ann
forall ann. [(ByteString, Text)] -> Doc ann
tagsDoc [(ByteString, Text)]
tl Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> RAVOrder (Doc ann)
-> Position -> (Outcome, [Tree PlyData]) -> Doc ann
forall ann.
RAVOrder (Doc ann)
-> Position -> (Outcome, [Tree PlyData]) -> Doc ann
moveDoc RAVOrder (Doc ann)
ro Position
pos (Outcome, [Tree PlyData])
mt
 where
  pos :: Position
pos | Just Text
fen <- ByteString -> [(ByteString, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"FEN" [(ByteString, Text)]
tl = Maybe Position -> Position
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Position -> Position) -> Maybe Position -> Position
forall a b. (a -> b) -> a -> b
$ String -> Maybe Position
fromFEN (Text -> String
T.unpack Text
fen)
      | Bool
otherwise = Position
startpos

tagsDoc :: [(ByteString, Text)] -> Doc ann
tagsDoc :: [(ByteString, Text)] -> Doc ann
tagsDoc = FusionDepth -> Doc ann -> Doc ann
forall ann. FusionDepth -> Doc ann -> Doc ann
fuse FusionDepth
Shallow (Doc ann -> Doc ann)
-> ([(ByteString, Text)] -> Doc ann)
-> [(ByteString, Text)]
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vsep ([Doc ann] -> Doc ann)
-> ([(ByteString, Text)] -> [Doc ann])
-> [(ByteString, Text)]
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, Text) -> Doc ann)
-> [(ByteString, Text)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString, Text) -> Doc ann
forall ann. (ByteString, Text) -> Doc ann
tagpair where
  tagpair :: (ByteString, Text) -> Doc ann
tagpair (ByteString
k, Text -> Text
esc -> Text
v) = Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
brackets (Doc ann -> Doc ann) -> Doc ann -> Doc ann
forall a b. (a -> b) -> a -> b
$ String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (ByteString -> String
BS.unpack ByteString
k) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
dquotes (Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
v)
  esc :: Text -> Text
esc = (Char -> Text) -> Text -> Text
T.concatMap Char -> Text
e where
    e :: Char -> Text
e Char
'\\' = String -> Text
T.pack String
"\\\\"
    e Char
'"' = String -> Text
T.pack String
"\\\""
    e Char
c = Char -> Text
T.singleton Char
c

moveDoc :: RAVOrder (Doc ann) -> Position -> (Outcome, Forest PlyData) -> Doc ann
moveDoc :: RAVOrder (Doc ann)
-> Position -> (Outcome, [Tree PlyData]) -> Doc ann
moveDoc RAVOrder (Doc ann)
ro Position
p (Outcome
o,[Tree PlyData]
f) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fillSep (Position -> Bool -> [Tree PlyData] -> [Doc ann]
go Position
p Bool
True [Tree PlyData]
f [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> [Outcome -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Outcome
o]) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
line where
  go :: Position -> Bool -> [Tree PlyData] -> [Doc ann]
go Position
_ Bool
_ [] = []
  go Position
pos Bool
pmn (Tree PlyData
t:[Tree PlyData]
ts)
    | Position -> Color
color Position
pos Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
White Bool -> Bool -> Bool
|| Bool
pmn
    = [Doc ann]
pnag [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> (Doc ann
mnDoc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
:Doc ann
sanDoc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
:[Doc ann]
snag) [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> [Doc ann]
rav [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> Position -> Bool -> [Tree PlyData] -> [Doc ann]
go Position
pos' (Bool -> Bool
not (Bool -> Bool) -> ([Doc ann] -> Bool) -> [Doc ann] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Doc ann] -> Bool) -> [Doc ann] -> Bool
forall a b. (a -> b) -> a -> b
$ [Doc ann]
rav) (Tree PlyData -> [Tree PlyData]
forall a. Tree a -> Forest a
subForest Tree PlyData
t)
    | Bool
otherwise
    = [Doc ann]
pnag [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> (Doc ann
sanDoc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
:[Doc ann]
snag) [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> [Doc ann]
rav [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> Position -> Bool -> [Tree PlyData] -> [Doc ann]
go Position
pos' (Bool -> Bool
not (Bool -> Bool) -> ([Doc ann] -> Bool) -> [Doc ann] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Doc ann] -> Bool) -> [Doc ann] -> Bool
forall a b. (a -> b) -> a -> b
$ [Doc ann]
rav) (Tree PlyData -> [Tree PlyData]
forall a. Tree a -> Forest a
subForest Tree PlyData
t)
   where
    pl :: Ply
pl = PlyData -> Ply
pgnPly (PlyData -> Ply)
-> (Tree PlyData -> PlyData) -> Tree PlyData -> Ply
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree PlyData -> PlyData
forall a. Tree a -> a
rootLabel (Tree PlyData -> Ply) -> Tree PlyData -> Ply
forall a b. (a -> b) -> a -> b
$ Tree PlyData
t
    san :: Doc ann
san = String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (String -> Doc ann) -> String -> Doc ann
forall a b. (a -> b) -> a -> b
$ Position -> Ply -> String
unsafeToSAN Position
pos Ply
pl
    pos' :: Position
pos' = Position -> Ply -> Position
unsafeDoPly Position
pos Ply
pl
    pnag :: [Doc ann]
pnag = Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
prettynag (Int -> Doc ann) -> [Int] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PlyData -> [Int]
prefixNAG (Tree PlyData -> PlyData
forall a. Tree a -> a
rootLabel Tree PlyData
t)
    mn :: Doc ann
mn = Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Position -> Int
moveNumber Position
pos) Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> if Position -> Color
color Position
pos Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
White then Doc ann
"." else Doc ann
"..."
    rav :: [Doc ann]
rav = RAVOrder (Doc ann)
ro (Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
parens (Doc ann -> Doc ann)
-> ([Tree PlyData] -> Doc ann) -> [Tree PlyData] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fillSep ([Doc ann] -> Doc ann)
-> ([Tree PlyData] -> [Doc ann]) -> [Tree PlyData] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> Bool -> [Tree PlyData] -> [Doc ann]
go Position
pos Bool
True) [Tree PlyData]
ts
    snag :: [Doc ann]
snag = Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
prettynag (Int -> Doc ann) -> [Int] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PlyData -> [Int]
suffixNAG (Tree PlyData -> PlyData
forall a. Tree a -> a
rootLabel Tree PlyData
t)
  prettynag :: a -> Doc ann
prettynag a
n = Doc ann
"$" Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
n

weightedForest :: PGN -> Forest (Rational, Ply)
weightedForest :: PGN -> Forest (Rational, Ply)
weightedForest (PGN [Game]
games) = Forest (Rational, Ply) -> Forest (Rational, Ply)
forall a b. (Num a, Ord a, Eq b) => [Tree (a, b)] -> [Tree (a, b)]
merge (Forest (Rational, Ply) -> Forest (Rational, Ply))
-> ([(Outcome, [Tree PlyData])] -> Forest (Rational, Ply))
-> [(Outcome, [Tree PlyData])]
-> Forest (Rational, Ply)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Outcome, [Tree PlyData]) -> Forest (Rational, Ply))
-> [(Outcome, [Tree PlyData])] -> Forest (Rational, Ply)
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Outcome, [Tree PlyData]) -> Forest (Rational, Ply)
forall a.
Integral a =>
(Outcome, [Tree PlyData]) -> [Tree (Ratio a, Ply)]
rate ([(Outcome, [Tree PlyData])] -> Forest (Rational, Ply))
-> [(Outcome, [Tree PlyData])] -> Forest (Rational, Ply)
forall a b. (a -> b) -> a -> b
$ Game -> (Outcome, [Tree PlyData])
forall a b. (a, b) -> b
snd (Game -> (Outcome, [Tree PlyData]))
-> [Game] -> [(Outcome, [Tree PlyData])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Game -> Bool) -> [Game] -> [Game]
forall a. (a -> Bool) -> [a] -> [a]
filter Game -> Bool
forall a a b.
(Eq a, IsString a) =>
([(a, a)], (Outcome, b)) -> Bool
ok [Game]
games where
  ok :: ([(a, a)], (Outcome, b)) -> Bool
ok ([(a, a)]
tags, (Outcome
o, b
_)) = Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing (a -> [(a, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"FEN" [(a, a)]
tags) Bool -> Bool -> Bool
&& Outcome
o Outcome -> Outcome -> Bool
forall a. Eq a => a -> a -> Bool
/= Outcome
Undecided
  rate :: (Outcome, [Tree PlyData]) -> [Tree (Ratio a, Ply)]
rate (Outcome
o, [Tree PlyData]
ts) = Position -> Tree PlyData -> Tree (Ratio a, Ply)
f Position
startpos (Tree PlyData -> Tree (Ratio a, Ply))
-> [Tree PlyData] -> [Tree (Ratio a, Ply)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree PlyData] -> [Tree PlyData]
forall a. Forest a -> Forest a
trunk [Tree PlyData]
ts where
    w :: Color -> Ratio a
w Color
c | Outcome
o Outcome -> Outcome -> Bool
forall a. Eq a => a -> a -> Bool
== Color -> Outcome
Win Color
c = Ratio a
1
        | Outcome
o Outcome -> Outcome -> Bool
forall a. Eq a => a -> a -> Bool
== Color -> Outcome
Win (Color -> Color
opponent Color
c) = -Ratio a
1
        | Outcome
o Outcome -> Outcome -> Bool
forall a. Eq a => a -> a -> Bool
== Outcome
Draw = a
1 a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
2
        | Bool
otherwise = Ratio a
0
    f :: Position -> Tree PlyData -> Tree (Ratio a, Ply)
f Position
pos (Node PlyData
a [Tree PlyData]
ts') = (Ratio a, Ply) -> [Tree (Ratio a, Ply)] -> Tree (Ratio a, Ply)
forall a. a -> Forest a -> Tree a
Node (Color -> Ratio a
w (Position -> Color
color Position
pos), PlyData -> Ply
pgnPly PlyData
a) ([Tree (Ratio a, Ply)] -> Tree (Ratio a, Ply))
-> [Tree (Ratio a, Ply)] -> Tree (Ratio a, Ply)
forall a b. (a -> b) -> a -> b
$
      Position -> Tree PlyData -> Tree (Ratio a, Ply)
f (Position -> Ply -> Position
unsafeDoPly Position
pos (PlyData -> Ply
pgnPly PlyData
a)) (Tree PlyData -> Tree (Ratio a, Ply))
-> [Tree PlyData] -> [Tree (Ratio a, Ply)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree PlyData]
ts'
  trunk :: Forest a -> Forest a
trunk [] = []
  trunk (Tree a
x:Forest a
_) = [Tree a
x { subForest :: Forest a
subForest = Forest a -> Forest a
trunk (Tree a -> Forest a
forall a. Tree a -> Forest a
subForest Tree a
x)}]
  merge :: [Tree (a, b)] -> [Tree (a, b)]
merge [] = []
  merge ((Node (a, b)
a [Tree (a, b)]
ts) : [Tree (a, b)]
xs) =
      (Tree (a, b) -> Down a) -> [Tree (a, b)] -> [Tree (a, b)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (a -> Down a
forall a. a -> Down a
Down (a -> Down a) -> (Tree (a, b) -> a) -> Tree (a, b) -> Down a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst ((a, b) -> a) -> (Tree (a, b) -> (a, b)) -> Tree (a, b) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (a, b) -> (a, b)
forall a. Tree a -> a
rootLabel)
    ([Tree (a, b)] -> [Tree (a, b)]) -> [Tree (a, b)] -> [Tree (a, b)]
forall a b. (a -> b) -> a -> b
$ (a, b) -> [Tree (a, b)] -> Tree (a, b)
forall a. a -> Forest a -> Tree a
Node (a
w, (a, b) -> b
forall a b. (a, b) -> b
snd (a, b)
a) ([Tree (a, b)] -> [Tree (a, b)]
merge ([Tree (a, b)] -> [Tree (a, b)]) -> [Tree (a, b)] -> [Tree (a, b)]
forall a b. (a -> b) -> a -> b
$ [Tree (a, b)]
ts [Tree (a, b)] -> [Tree (a, b)] -> [Tree (a, b)]
forall a. [a] -> [a] -> [a]
++ (Tree (a, b) -> [Tree (a, b)]) -> [Tree (a, b)] -> [Tree (a, b)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tree (a, b) -> [Tree (a, b)]
forall a. Tree a -> Forest a
subForest [Tree (a, b)]
good) Tree (a, b) -> [Tree (a, b)] -> [Tree (a, b)]
forall a. a -> [a] -> [a]
: [Tree (a, b)] -> [Tree (a, b)]
merge [Tree (a, b)]
bad
   where
    ([Tree (a, b)]
good, [Tree (a, b)]
bad) = (Tree (a, b) -> Bool)
-> [Tree (a, b)] -> ([Tree (a, b)], [Tree (a, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((a, b) -> (a, b) -> Bool
forall a a a. Eq a => (a, a) -> (a, a) -> Bool
eq (a, b)
a ((a, b) -> Bool) -> (Tree (a, b) -> (a, b)) -> Tree (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (a, b) -> (a, b)
forall a. Tree a -> a
rootLabel) [Tree (a, b)]
xs where eq :: (a, a) -> (a, a) -> Bool
eq (a, a)
x (a, a)
y = (a, a) -> a
forall a b. (a, b) -> b
snd (a, a)
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== (a, a) -> a
forall a b. (a, b) -> b
snd (a, a)
y
    w :: a
w = (a, b) -> a
forall a b. (a, b) -> a
fst (a, b)
a a -> a -> a
forall a. Num a => a -> a -> a
+ [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((a, b) -> a
forall a b. (a, b) -> a
fst ((a, b) -> a) -> (Tree (a, b) -> (a, b)) -> Tree (a, b) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (a, b) -> (a, b)
forall a. Tree a -> a
rootLabel (Tree (a, b) -> a) -> [Tree (a, b)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree (a, b)]
good)