{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DeriveLift                 #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TupleSections              #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE ViewPatterns               #-}
{-|
Module      : Game.Chess.PGN
Description : Portable Game Notation
Copyright   : (c) Mario Lang, 2021
License     : BSD3
Maintainer  : mlang@blind.guru
Stability   : experimental

A PGN file consists of a list of games.
Each game consists of a tag list, the outcome, and a forest of rosetrees.
-}
module Game.Chess.PGN (
  PGN(..)
, Game(..), cgTags, cgOutcome, cgForest
, Outcome(..), _Win, _Draw, _Undecided
, Annotated(..), annPrefixNAG, annPly, annSuffixNAG
, readPGNFile, gameFromForest, pgnForest
  -- * A PGN parser
, pgn
  -- * Prettyprinting
, hPutPGN, pgnDoc, RAVOrder, breadthFirst, depthFirst, gameDoc
, weightedForest
) where

import           Control.Lens               (makeLenses, makePrisms,
                                             makeWrapped)
import           Control.Monad              (void)
import           Control.Monad.IO.Class     (MonadIO (..))
import           Data.Bifunctor             (Bifunctor (first))
import           Data.ByteString.Char8      (ByteString)
import qualified Data.ByteString.Char8      as BS
import           Data.Char                  (chr, ord)
import           Data.Foldable              (for_)
import           Data.Functor               (($>))
import           Data.Hashable              (Hashable (..))
import           Data.List                  (partition, sortOn)
import           Data.Maybe                 (fromJust, isNothing)
import           Data.Ord                   (Down (Down))
import           Data.Ratio                 ((%))
import           Data.Text                  (Text)
import qualified Data.Text                  as T
import           Data.Text.Encoding         as T (decodeUtf8)
import           Data.Tree                  (Tree (..), foldTree)
import           Data.Void                  (Void)
import           Data.Word                  (Word8)
import           GHC.Generics               (Generic)
import           Game.Chess.Internal        (Color (..), Ply,
                                             Position (color, moveNumber),
                                             fromFEN, startpos, unsafeDoPly)
import           Game.Chess.SAN             (relaxedSAN, unsafeToSAN)
import           Language.Haskell.TH.Syntax (Lift)
import           Prettyprinter                (Doc, FusionDepth (Shallow),
                                             Pretty (pretty), brackets, dquotes,
                                             fillSep, fuse, line, parens, vsep,
                                             (<+>))
import           Prettyprinter.Render.Text    (hPutDoc)
import           System.IO                  (Handle, hPutStrLn)
import           Text.Megaparsec            (MonadParsec (eof), Parsec,
                                             anySingleBut, errorBundlePretty,
                                             many, match, oneOf, optional,
                                             parse, single, (<?>), (<|>))
import           Text.Megaparsec.Byte       (alphaNumChar, space, space1,
                                             string)
import qualified Text.Megaparsec.Byte.Lexer as L

data Annotated a = Ann {
  Annotated a -> [Int]
_annPrefixNAG :: ![Int]
, Annotated a -> a
_annPly       :: !a
, Annotated a -> [Int]
_annSuffixNAG :: ![Int]
} deriving (Annotated a -> Annotated a -> Bool
(Annotated a -> Annotated a -> Bool)
-> (Annotated a -> Annotated a -> Bool) -> Eq (Annotated a)
forall a. Eq a => Annotated a -> Annotated a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Annotated a -> Annotated a -> Bool
$c/= :: forall a. Eq a => Annotated a -> Annotated a -> Bool
== :: Annotated a -> Annotated a -> Bool
$c== :: forall a. Eq a => Annotated a -> Annotated a -> Bool
Eq, a -> Annotated b -> Annotated a
(a -> b) -> Annotated a -> Annotated b
(forall a b. (a -> b) -> Annotated a -> Annotated b)
-> (forall a b. a -> Annotated b -> Annotated a)
-> Functor Annotated
forall a b. a -> Annotated b -> Annotated a
forall a b. (a -> b) -> Annotated a -> Annotated b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Annotated b -> Annotated a
$c<$ :: forall a b. a -> Annotated b -> Annotated a
fmap :: (a -> b) -> Annotated a -> Annotated b
$cfmap :: forall a b. (a -> b) -> Annotated a -> Annotated b
Functor, (forall x. Annotated a -> Rep (Annotated a) x)
-> (forall x. Rep (Annotated a) x -> Annotated a)
-> Generic (Annotated a)
forall x. Rep (Annotated a) x -> Annotated a
forall x. Annotated a -> Rep (Annotated a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Annotated a) x -> Annotated a
forall a x. Annotated a -> Rep (Annotated a) x
$cto :: forall a x. Rep (Annotated a) x -> Annotated a
$cfrom :: forall a x. Annotated a -> Rep (Annotated a) x
Generic, Annotated a -> Q Exp
Annotated a -> Q (TExp (Annotated a))
(Annotated a -> Q Exp)
-> (Annotated a -> Q (TExp (Annotated a))) -> Lift (Annotated a)
forall a. Lift a => Annotated a -> Q Exp
forall a. Lift a => Annotated a -> Q (TExp (Annotated a))
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Annotated a -> Q (TExp (Annotated a))
$cliftTyped :: forall a. Lift a => Annotated a -> Q (TExp (Annotated a))
lift :: Annotated a -> Q Exp
$clift :: forall a. Lift a => Annotated a -> Q Exp
Lift, Int -> Annotated a -> ShowS
[Annotated a] -> ShowS
Annotated a -> String
(Int -> Annotated a -> ShowS)
-> (Annotated a -> String)
-> ([Annotated a] -> ShowS)
-> Show (Annotated a)
forall a. Show a => Int -> Annotated a -> ShowS
forall a. Show a => [Annotated a] -> ShowS
forall a. Show a => Annotated a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Annotated a] -> ShowS
$cshowList :: forall a. Show a => [Annotated a] -> ShowS
show :: Annotated a -> String
$cshow :: forall a. Show a => Annotated a -> String
showsPrec :: Int -> Annotated a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Annotated a -> ShowS
Show)

instance Applicative Annotated where
  pure :: a -> Annotated a
pure a
a = [Int] -> a -> [Int] -> Annotated a
forall a. [Int] -> a -> [Int] -> Annotated a
Ann [] a
a []
  Ann [Int]
pn1 a -> b
f [Int]
sn1 <*> :: Annotated (a -> b) -> Annotated a -> Annotated b
<*> Ann [Int]
pn2 a
a [Int]
sn2 = [Int] -> b -> [Int] -> Annotated b
forall a. [Int] -> a -> [Int] -> Annotated a
Ann ([Int]
pn1 [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Int]
pn2) (a -> b
f a
a) ([Int]
sn1 [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Int]
sn2)

makeLenses ''Annotated

instance Hashable a => Hashable (Annotated a)

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, (forall x. Outcome -> Rep Outcome x)
-> (forall x. Rep Outcome x -> Outcome) -> Generic Outcome
forall x. Rep Outcome x -> Outcome
forall x. Outcome -> Rep Outcome x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Outcome x -> Outcome
$cfrom :: forall x. Outcome -> Rep Outcome x
Generic, Outcome -> Q Exp
Outcome -> Q (TExp Outcome)
(Outcome -> Q Exp) -> (Outcome -> Q (TExp Outcome)) -> Lift Outcome
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Outcome -> Q (TExp Outcome)
$cliftTyped :: Outcome -> Q (TExp Outcome)
lift :: Outcome -> Q Exp
$clift :: Outcome -> Q Exp
Lift, 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)

instance Hashable Outcome

makePrisms ''Outcome

data Game = CG {
  Game -> [(Text, Text)]
_cgTags    :: ![(Text, Text)]
, Game -> [Tree (Annotated Ply)]
_cgForest  :: ![Tree (Annotated Ply)]
, Game -> Outcome
_cgOutcome :: !Outcome
} deriving (Game -> Game -> Bool
(Game -> Game -> Bool) -> (Game -> Game -> Bool) -> Eq Game
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Game -> Game -> Bool
$c/= :: Game -> Game -> Bool
== :: Game -> Game -> Bool
$c== :: Game -> Game -> Bool
Eq, (forall x. Game -> Rep Game x)
-> (forall x. Rep Game x -> Game) -> Generic Game
forall x. Rep Game x -> Game
forall x. Game -> Rep Game x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Game x -> Game
$cfrom :: forall x. Game -> Rep Game x
Generic, Int -> Game -> ShowS
[Game] -> ShowS
Game -> String
(Int -> Game -> ShowS)
-> (Game -> String) -> ([Game] -> ShowS) -> Show Game
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Game] -> ShowS
$cshowList :: [Game] -> ShowS
show :: Game -> String
$cshow :: Game -> String
showsPrec :: Int -> Game -> ShowS
$cshowsPrec :: Int -> Game -> ShowS
Show)

instance Hashable Game where
  hashWithSalt :: Int -> Game -> Int
hashWithSalt Int
s CG { [(Text, Text)]
[Tree (Annotated Ply)]
Outcome
_cgOutcome :: Outcome
_cgForest :: [Tree (Annotated Ply)]
_cgTags :: [(Text, Text)]
_cgOutcome :: Game -> Outcome
_cgForest :: Game -> [Tree (Annotated Ply)]
_cgTags :: Game -> [(Text, Text)]
.. } = Int
s
    Int -> [(Text, Text)] -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` [(Text, Text)]
_cgTags
    Int -> [Int] -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` (Annotated Ply -> [Int] -> Int) -> Tree (Annotated Ply) -> Int
forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree (Int -> [Int] -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt (Int -> [Int] -> Int)
-> (Annotated Ply -> Int) -> Annotated Ply -> [Int] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotated Ply -> Int
forall a. Hashable a => a -> Int
hash) (Tree (Annotated Ply) -> Int) -> [Tree (Annotated Ply)] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree (Annotated Ply)]
_cgForest
    Int -> Outcome -> Int
forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Outcome
_cgOutcome

makeLenses ''Game

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)

makeWrapped ''PGN

gameFromForest :: [(Text, Text)] -> [Tree Ply] -> Outcome -> Game
gameFromForest :: [(Text, Text)] -> [Tree Ply] -> Outcome -> Game
gameFromForest [(Text, Text)]
tags [Tree Ply]
forest Outcome
_cgOutcome = CG :: [(Text, Text)] -> [Tree (Annotated Ply)] -> Outcome -> Game
CG { [(Text, Text)]
[Tree (Annotated Ply)]
Outcome
_cgForest :: [Tree (Annotated Ply)]
_cgTags :: [(Text, Text)]
_cgOutcome :: Outcome
_cgOutcome :: Outcome
_cgForest :: [Tree (Annotated Ply)]
_cgTags :: [(Text, Text)]
.. } where
  _cgTags :: [(Text, Text)]
_cgTags = (Text
"Result", Text
r)(Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
:[(Text, Text)]
tags
  _cgForest :: [Tree (Annotated Ply)]
_cgForest = ((Tree Ply -> Tree (Annotated Ply))
-> [Tree Ply] -> [Tree (Annotated Ply)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Tree Ply -> Tree (Annotated Ply))
 -> [Tree Ply] -> [Tree (Annotated Ply)])
-> ((Ply -> Annotated Ply) -> Tree Ply -> Tree (Annotated Ply))
-> (Ply -> Annotated Ply)
-> [Tree Ply]
-> [Tree (Annotated Ply)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ply -> Annotated Ply) -> Tree Ply -> Tree (Annotated Ply)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Ply -> Annotated Ply
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Tree Ply]
forest
  r :: Text
r = case Outcome
_cgOutcome of
    Win Color
White -> Text
"1-0"
    Win Color
Black -> Text
"0-1"
    Outcome
Draw      -> Text
"1/2-1/2"
    Outcome
Undecided -> Text
"*"

pgnForest :: PGN -> [Tree Ply]
pgnForest :: PGN -> [Tree Ply]
pgnForest (PGN [Game]
gs) = [Tree Ply] -> [Tree Ply]
forall a. Eq a => [Tree a] -> [Tree a]
merge ([Tree Ply] -> [Tree Ply]) -> [Tree Ply] -> [Tree Ply]
forall a b. (a -> b) -> a -> b
$ (Game -> [Tree Ply]) -> [Game] -> [Tree Ply]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (((Tree (Annotated Ply) -> Tree Ply)
-> [Tree (Annotated Ply)] -> [Tree Ply]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Tree (Annotated Ply) -> Tree Ply)
 -> [Tree (Annotated Ply)] -> [Tree Ply])
-> ((Annotated Ply -> Ply) -> Tree (Annotated Ply) -> Tree Ply)
-> (Annotated Ply -> Ply)
-> [Tree (Annotated Ply)]
-> [Tree Ply]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Annotated Ply -> Ply) -> Tree (Annotated Ply) -> Tree Ply
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Annotated Ply -> Ply
forall a. Annotated a -> a
_annPly ([Tree (Annotated Ply)] -> [Tree Ply])
-> (Game -> [Tree (Annotated Ply)]) -> Game -> [Tree Ply]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game -> [Tree (Annotated Ply)]
_cgForest) [Game]
gs where
  merge :: Eq a => [Tree a] -> [Tree a]
  merge :: [Tree a] -> [Tree a]
merge = ([Tree a] -> Tree a -> [Tree a])
-> [Tree a] -> [Tree a] -> [Tree a]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Tree a] -> Tree a -> [Tree 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
"*"

readPGNFile :: MonadIO m => FilePath -> m (Either String PGN)
readPGNFile :: String -> m (Either String PGN)
readPGNFile String
fp = IO (Either String PGN) -> m (Either String PGN)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String PGN) -> m (Either String PGN))
-> IO (Either String PGN) -> m (Either String PGN)
forall a b. (a -> b) -> a -> b
$
  (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 (ParseErrorBundle ByteString Void) PGN)
-> (ByteString -> ByteString)
-> ByteString
-> Either (ParseErrorBundle ByteString Void) PGN
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
stripBOM (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

bom :: ByteString
bom :: ByteString
bom = ByteString
"\xEF\xBB\xBF"

stripBOM :: ByteString -> ByteString
stripBOM :: ByteString -> ByteString
stripBOM ByteString
bs
  | ByteString
bom ByteString -> ByteString -> Bool
`BS.isPrefixOf` ByteString
bs = Int -> ByteString -> ByteString
BS.drop (ByteString -> Int
BS.length ByteString
bom) ByteString
bs
  | Bool
otherwise              = ByteString
bs

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 Text
sym :: Parser Text
sym = Parser Text -> Parser Text
forall a. Parser a -> Parser a
lexeme (Parser Text -> Parser Text)
-> (ParsecT Void ByteString Identity [Word8] -> Parser Text)
-> ParsecT Void ByteString Identity [Word8]
-> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ByteString, [Word8]) -> Text)
-> ParsecT Void ByteString Identity (ByteString, [Word8])
-> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> ((ByteString, [Word8]) -> ByteString)
-> (ByteString, [Word8])
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, [Word8]) -> ByteString
forall a b. (a, b) -> a
fst) (ParsecT Void ByteString Identity (ByteString, [Word8])
 -> Parser Text)
-> (ParsecT Void ByteString Identity [Word8]
    -> ParsecT Void ByteString Identity (ByteString, [Word8]))
-> ParsecT Void ByteString Identity [Word8]
-> Parser Text
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] -> Parser Text)
-> ParsecT Void ByteString Identity [Word8] -> Parser Text
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 (Text, Text)
tagPair :: Parser (Text, Text)
tagPair = Parser (Text, Text) -> Parser (Text, Text)
forall a. Parser a -> Parser a
lexeme (Parser (Text, Text) -> Parser (Text, Text))
-> Parser (Text, Text) -> Parser (Text, Text)
forall a b. (a -> b) -> a -> b
$ do
  Parser ()
lbracketP
  Text
k <- Parser Text
sym
  Text
v <- Parser Text
str
  Parser ()
rbracketP
  (Text, Text) -> Parser (Text, Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
k, Text
v)

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

movetext :: Position -> Parser (Outcome, [Tree (Annotated Ply)])
movetext :: Position -> Parser (Outcome, [Tree (Annotated Ply)])
movetext Position
pos = (,[]) (Outcome -> (Outcome, [Tree (Annotated Ply)]))
-> Parser Outcome -> Parser (Outcome, [Tree (Annotated Ply)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Outcome
eog Parser (Outcome, [Tree (Annotated Ply)])
-> Parser (Outcome, [Tree (Annotated Ply)])
-> Parser (Outcome, [Tree (Annotated Ply)])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Position -> Parser (Outcome, [Tree (Annotated Ply)])
main Position
pos where
  main :: Position -> Parser (Outcome, [Tree (Annotated Ply)])
main Position
p = Position
-> ParsecT
     Void
     ByteString
     Identity
     (Ply, [Tree (Annotated Ply)] -> [Tree (Annotated Ply)])
ply Position
p ParsecT
  Void
  ByteString
  Identity
  (Ply, [Tree (Annotated Ply)] -> [Tree (Annotated Ply)])
-> ((Ply, [Tree (Annotated Ply)] -> [Tree (Annotated Ply)])
    -> Parser (Outcome, [Tree (Annotated Ply)]))
-> Parser (Outcome, [Tree (Annotated Ply)])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Ply
m, [Tree (Annotated Ply)] -> [Tree (Annotated Ply)]
n) -> ([Tree (Annotated Ply)] -> [Tree (Annotated Ply)])
-> (Outcome, [Tree (Annotated Ply)])
-> (Outcome, [Tree (Annotated Ply)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Tree (Annotated Ply)] -> [Tree (Annotated Ply)]
n ((Outcome, [Tree (Annotated Ply)])
 -> (Outcome, [Tree (Annotated Ply)]))
-> Parser (Outcome, [Tree (Annotated Ply)])
-> Parser (Outcome, [Tree (Annotated Ply)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position -> Parser (Outcome, [Tree (Annotated Ply)])
movetext (Position -> Ply -> Position
unsafeDoPly Position
p Ply
m)
  var :: Position -> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
var Position
p = Position
-> ParsecT
     Void
     ByteString
     Identity
     (Ply, [Tree (Annotated Ply)] -> [Tree (Annotated Ply)])
ply Position
p ParsecT
  Void
  ByteString
  Identity
  (Ply, [Tree (Annotated Ply)] -> [Tree (Annotated Ply)])
-> ((Ply, [Tree (Annotated Ply)] -> [Tree (Annotated Ply)])
    -> ParsecT Void ByteString Identity [Tree (Annotated Ply)])
-> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Ply
m, [Tree (Annotated Ply)] -> [Tree (Annotated Ply)]
n) -> [Tree (Annotated Ply)] -> [Tree (Annotated Ply)]
n ([Tree (Annotated Ply)] -> [Tree (Annotated Ply)])
-> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
-> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ()
rparenP Parser ()
-> [Tree (Annotated Ply)]
-> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> [] ParsecT Void ByteString Identity [Tree (Annotated Ply)]
-> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
-> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Position -> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
var (Position -> Ply -> Position
unsafeDoPly Position
p Ply
m))
  ply :: Position
-> ParsecT
     Void
     ByteString
     Identity
     (Ply, [Tree (Annotated Ply)] -> [Tree (Annotated Ply)])
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 (Annotated Ply)]
rav <- [[Tree (Annotated Ply)]] -> [Tree (Annotated Ply)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Tree (Annotated Ply)]] -> [Tree (Annotated Ply)])
-> ParsecT Void ByteString Identity [[Tree (Annotated Ply)]]
-> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
-> ParsecT Void ByteString Identity [[Tree (Annotated Ply)]]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Parser ()
lparenP Parser ()
-> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
-> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Position -> ParsecT Void ByteString Identity [Tree (Annotated Ply)]
var Position
p)
    (Ply, [Tree (Annotated Ply)] -> [Tree (Annotated Ply)])
-> ParsecT
     Void
     ByteString
     Identity
     (Ply, [Tree (Annotated Ply)] -> [Tree (Annotated Ply)])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Ply
m, \[Tree (Annotated Ply)]
xs -> Annotated Ply -> [Tree (Annotated Ply)] -> Tree (Annotated Ply)
forall a. a -> Forest a -> Tree a
Node ([Int] -> Ply -> [Int] -> Annotated Ply
forall a. [Int] -> a -> [Int] -> Annotated a
Ann [Int]
pnags Ply
m [Int]
snags) [Tree (Annotated Ply)]
xsTree (Annotated Ply)
-> [Tree (Annotated Ply)] -> [Tree (Annotated Ply)]
forall a. a -> [a] -> [a]
:[Tree (Annotated Ply)]
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
  [(Text, Text)]
_cgTags <- Parser [(Text, Text)]
tagList
  Position
pos <- case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"FEN" [(Text, Text)]
_cgTags 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"
  (Outcome
_cgOutcome, [Tree (Annotated Ply)]
_cgForest) <- Position -> Parser (Outcome, [Tree (Annotated Ply)])
movetext Position
pos
  Game -> ParsecT Void ByteString Identity Game
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Game -> ParsecT Void ByteString Identity Game)
-> Game -> ParsecT Void ByteString Identity Game
forall a b. (a -> b) -> a -> b
$ CG :: [(Text, Text)] -> [Tree (Annotated Ply)] -> Outcome -> Game
CG { [(Text, Text)]
[Tree (Annotated Ply)]
Outcome
_cgForest :: [Tree (Annotated Ply)]
_cgOutcome :: Outcome
_cgTags :: [(Text, Text)]
_cgOutcome :: Outcome
_cgForest :: [Tree (Annotated Ply)]
_cgTags :: [(Text, Text)]
.. }

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 = ([Tree (Annotated Ply)] -> a) -> [Tree (Annotated Ply)] -> [a]

breadthFirst, depthFirst :: RAVOrder a
breadthFirst :: RAVOrder a
breadthFirst [Tree (Annotated Ply)] -> a
_ [] = []
breadthFirst [Tree (Annotated Ply)] -> a
f [Tree (Annotated Ply)]
ts = a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> [a]) -> a -> [a]
forall a b. (a -> b) -> a -> b
$ [Tree (Annotated Ply)] -> a
f [Tree (Annotated Ply)]
ts
depthFirst :: RAVOrder a
depthFirst [Tree (Annotated Ply)] -> a
f = (Tree (Annotated Ply) -> a) -> [Tree (Annotated Ply)] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Tree (Annotated Ply) -> a) -> [Tree (Annotated Ply)] -> [a])
-> (Tree (Annotated Ply) -> a) -> [Tree (Annotated Ply)] -> [a]
forall a b. (a -> b) -> a -> b
$ [Tree (Annotated Ply)] -> a
f ([Tree (Annotated Ply)] -> a)
-> (Tree (Annotated Ply) -> [Tree (Annotated Ply)])
-> Tree (Annotated Ply)
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (Annotated Ply) -> [Tree (Annotated Ply)]
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 CG { [(Text, Text)]
[Tree (Annotated Ply)]
Outcome
_cgOutcome :: Outcome
_cgForest :: [Tree (Annotated Ply)]
_cgTags :: [(Text, Text)]
_cgOutcome :: Game -> Outcome
_cgForest :: Game -> [Tree (Annotated Ply)]
_cgTags :: Game -> [(Text, Text)]
.. }
  | [(Text, Text)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Text)]
_cgTags = RAVOrder (Doc ann)
-> Position -> (Outcome, [Tree (Annotated Ply)]) -> Doc ann
forall ann.
RAVOrder (Doc ann)
-> Position -> (Outcome, [Tree (Annotated Ply)]) -> Doc ann
moveDoc RAVOrder (Doc ann)
ro Position
pos (Outcome
_cgOutcome, [Tree (Annotated Ply)]
_cgForest)
  | Bool
otherwise = [(Text, Text)] -> Doc ann
forall ann. [(Text, Text)] -> Doc ann
tagsDoc [(Text, Text)]
_cgTags 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 (Annotated Ply)]) -> Doc ann
forall ann.
RAVOrder (Doc ann)
-> Position -> (Outcome, [Tree (Annotated Ply)]) -> Doc ann
moveDoc RAVOrder (Doc ann)
ro Position
pos (Outcome
_cgOutcome, [Tree (Annotated Ply)]
_cgForest)
 where
  pos :: Position
pos | Just Text
fen <- Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"FEN" [(Text, Text)]
_cgTags = 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 :: [(Text, Text)] -> Doc ann
tagsDoc :: [(Text, Text)] -> Doc ann
tagsDoc = FusionDepth -> Doc ann -> Doc ann
forall ann. FusionDepth -> Doc ann -> Doc ann
fuse FusionDepth
Shallow (Doc ann -> Doc ann)
-> ([(Text, Text)] -> Doc ann) -> [(Text, 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)
-> ([(Text, Text)] -> [Doc ann]) -> [(Text, Text)] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Doc ann) -> [(Text, Text)] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Text) -> Doc ann
forall a ann. Pretty a => (a, Text) -> Doc ann
tagpair where
  tagpair :: (a, Text) -> Doc ann
tagpair (a
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
$ a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
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, [Tree (Annotated Ply)])
        -> Doc ann
moveDoc :: RAVOrder (Doc ann)
-> Position -> (Outcome, [Tree (Annotated Ply)]) -> Doc ann
moveDoc RAVOrder (Doc ann)
ro Position
p (Outcome
o,[Tree (Annotated Ply)]
f) = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
fillSep (Position -> Bool -> [Tree (Annotated Ply)] -> [Doc ann]
go Position
p Bool
True [Tree (Annotated Ply)]
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 (Annotated Ply)] -> [Doc ann]
go Position
_ Bool
_ [] = []
  go Position
pos Bool
pmn (Tree (Annotated Ply)
t:[Tree (Annotated Ply)]
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 (Annotated Ply)] -> [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 (Annotated Ply) -> [Tree (Annotated Ply)]
forall a. Tree a -> Forest a
subForest Tree (Annotated Ply)
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 (Annotated Ply)] -> [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 (Annotated Ply) -> [Tree (Annotated Ply)]
forall a. Tree a -> Forest a
subForest Tree (Annotated Ply)
t)
   where
    pl :: Ply
pl = Annotated Ply -> Ply
forall a. Annotated a -> a
_annPly (Annotated Ply -> Ply)
-> (Tree (Annotated Ply) -> Annotated Ply)
-> Tree (Annotated Ply)
-> Ply
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree (Annotated Ply) -> Annotated Ply
forall a. Tree a -> a
rootLabel (Tree (Annotated Ply) -> Ply) -> Tree (Annotated Ply) -> Ply
forall a b. (a -> b) -> a -> b
$ Tree (Annotated Ply)
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
<$> Annotated Ply -> [Int]
forall a. Annotated a -> [Int]
_annPrefixNAG (Tree (Annotated Ply) -> Annotated Ply
forall a. Tree a -> a
rootLabel Tree (Annotated Ply)
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 (Annotated Ply)] -> Doc ann)
-> [Tree (Annotated Ply)]
-> 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 (Annotated Ply)] -> [Doc ann])
-> [Tree (Annotated Ply)]
-> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> Bool -> [Tree (Annotated Ply)] -> [Doc ann]
go Position
pos Bool
True) [Tree (Annotated Ply)]
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
<$> Annotated Ply -> [Int]
forall a. Annotated a -> [Int]
_annSuffixNAG (Tree (Annotated Ply) -> Annotated Ply
forall a. Tree a -> a
rootLabel Tree (Annotated Ply)
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 -> [Tree (Rational, Ply)]
weightedForest :: PGN -> [Tree (Rational, Ply)]
weightedForest (PGN [Game]
games) = [Tree (Rational, Ply)] -> [Tree (Rational, Ply)]
forall a b. (Num a, Ord a, Eq b) => [Tree (a, b)] -> [Tree (a, b)]
merge ([Tree (Rational, Ply)] -> [Tree (Rational, Ply)])
-> ([Game] -> [Tree (Rational, Ply)])
-> [Game]
-> [Tree (Rational, Ply)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Game -> [Tree (Rational, Ply)])
-> [Game] -> [Tree (Rational, Ply)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Game -> [Tree (Rational, Ply)]
forall a. Integral a => Game -> [Tree (Ratio a, Ply)]
rate ([Game] -> [Tree (Rational, Ply)])
-> [Game] -> [Tree (Rational, Ply)]
forall a b. (a -> b) -> a -> b
$ (Game -> Bool) -> [Game] -> [Game]
forall a. (a -> Bool) -> [a] -> [a]
filter Game -> Bool
ok [Game]
games where
  ok :: Game -> Bool
ok CG { [(Text, Text)]
[Tree (Annotated Ply)]
Outcome
_cgOutcome :: Outcome
_cgForest :: [Tree (Annotated Ply)]
_cgTags :: [(Text, Text)]
_cgOutcome :: Game -> Outcome
_cgForest :: Game -> [Tree (Annotated Ply)]
_cgTags :: Game -> [(Text, Text)]
.. } = Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"FEN" [(Text, Text)]
_cgTags) Bool -> Bool -> Bool
&& Outcome
_cgOutcome Outcome -> Outcome -> Bool
forall a. Eq a => a -> a -> Bool
/= Outcome
Undecided
  rate :: Game -> [Tree (Ratio a, Ply)]
rate CG { [(Text, Text)]
[Tree (Annotated Ply)]
Outcome
_cgOutcome :: Outcome
_cgForest :: [Tree (Annotated Ply)]
_cgTags :: [(Text, Text)]
_cgOutcome :: Game -> Outcome
_cgForest :: Game -> [Tree (Annotated Ply)]
_cgTags :: Game -> [(Text, Text)]
.. } = Position -> Tree (Annotated Ply) -> Tree (Ratio a, Ply)
f Position
startpos (Tree (Annotated Ply) -> Tree (Ratio a, Ply))
-> [Tree (Annotated Ply)] -> [Tree (Ratio a, Ply)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree (Annotated Ply)] -> [Tree (Annotated Ply)]
forall a. Forest a -> Forest a
trunk [Tree (Annotated Ply)]
_cgForest where
    w :: Color -> Ratio a
w Color
c = case Outcome
_cgOutcome of
      Win Color
c' | Color
c Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
c' -> Ratio a
1
             | Bool
otherwise -> -Ratio a
1
      Outcome
Draw -> a
1 a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
2
      Outcome
Undecided -> Ratio a
0
    f :: Position -> Tree (Annotated Ply) -> Tree (Ratio a, Ply)
f Position
pos (Node Annotated Ply
a [Tree (Annotated Ply)]
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), Annotated Ply -> Ply
forall a. Annotated a -> a
_annPly Annotated Ply
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 (Annotated Ply) -> Tree (Ratio a, Ply)
f (Position -> Ply -> Position
unsafeDoPly Position
pos (Annotated Ply -> Ply
forall a. Annotated a -> a
_annPly Annotated Ply
a)) (Tree (Annotated Ply) -> Tree (Ratio a, Ply))
-> [Tree (Annotated Ply)] -> [Tree (Ratio a, Ply)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree (Annotated Ply)]
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)