{-# 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 {
  forall a. Annotated a -> [Int]
_annPrefixNAG :: ![Int]
, forall a. Annotated a -> a
_annPly       :: !a
, forall a. Annotated a -> [Int]
_annSuffixNAG :: ![Int]
} deriving (Annotated a -> Annotated a -> Bool
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, 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
<$ :: forall a b. a -> Annotated b -> Annotated a
$c<$ :: forall a b. a -> Annotated b -> Annotated a
fmap :: forall a b. (a -> b) -> Annotated a -> Annotated b
$cfmap :: forall a b. (a -> b) -> Annotated a -> Annotated b
Functor, 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, forall a (m :: * -> *). (Lift a, Quote m) => Annotated a -> m Exp
forall a (m :: * -> *).
(Lift a, Quote m) =>
Annotated a -> Code m (Annotated a)
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Annotated a -> m Exp
forall (m :: * -> *).
Quote m =>
Annotated a -> Code m (Annotated a)
liftTyped :: forall (m :: * -> *).
Quote m =>
Annotated a -> Code m (Annotated a)
$cliftTyped :: forall a (m :: * -> *).
(Lift a, Quote m) =>
Annotated a -> Code m (Annotated a)
lift :: forall (m :: * -> *). Quote m => Annotated a -> m Exp
$clift :: forall a (m :: * -> *). (Lift a, Quote m) => Annotated a -> m Exp
Lift, Int -> Annotated a -> ShowS
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 :: forall a. a -> Annotated a
pure a
a = forall a. [Int] -> a -> [Int] -> Annotated a
Ann [] a
a []
  Ann [Int]
pn1 a -> b
f [Int]
sn1 <*> :: forall a b. Annotated (a -> b) -> Annotated a -> Annotated b
<*> Ann [Int]
pn2 a
a [Int]
sn2 = forall a. [Int] -> a -> [Int] -> Annotated a
Ann ([Int]
pn1 forall a. Semigroup a => a -> a -> a
<> [Int]
pn2) (a -> b
f a
a) ([Int]
sn1 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
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. 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, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Outcome -> m Exp
forall (m :: * -> *). Quote m => Outcome -> Code m Outcome
liftTyped :: forall (m :: * -> *). Quote m => Outcome -> Code m Outcome
$cliftTyped :: forall (m :: * -> *). Quote m => Outcome -> Code m Outcome
lift :: forall (m :: * -> *). Quote m => Outcome -> m Exp
$clift :: forall (m :: * -> *). Quote m => Outcome -> m Exp
Lift, Int -> Outcome -> ShowS
[Outcome] -> ShowS
Outcome -> String
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
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. 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
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
    forall a. Hashable a => Int -> a -> Int
`hashWithSalt` [(Text, Text)]
_cgTags
    forall a. Hashable a => Int -> a -> Int
`hashWithSalt` forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree (forall a. Hashable a => Int -> a -> Int
hashWithSalt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Hashable a => a -> Int
hash) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree (Annotated Ply)]
_cgForest
    forall a. Hashable a => Int -> a -> Int
`hashWithSalt` Outcome
_cgOutcome

makeLenses ''Game

newtype PGN = PGN [Game] deriving (PGN -> PGN -> Bool
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
[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
Monoid, NonEmpty PGN -> PGN
PGN -> PGN -> 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 :: forall b. Integral b => 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
_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)forall a. a -> [a] -> [a]
:[(Text, Text)]
tags
  _cgForest :: [Tree (Annotated Ply)]
_cgForest = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) 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) = forall a. Eq a => [Tree a] -> [Tree a]
merge forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall a. Annotated a -> a
_annPly 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 :: forall a. Eq a => [Tree a] -> [Tree a]
merge = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {a}. Eq a => [Tree a] -> Tree a -> [Tree a]
mergeTree [] where
    merge' :: Tree a -> Tree a -> Tree a
merge' Tree a
l Tree a
r = Tree a
l { subForest :: [Tree a]
subForest = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Tree a] -> Tree a -> [Tree a]
mergeTree (forall a. Tree a -> [Tree a]
subForest Tree a
l) (forall a. Tree a -> [Tree a]
subForest Tree a
r) }
    mergeTree :: [Tree a] -> Tree a -> [Tree a]
mergeTree [] Tree a
y = [Tree a
y]
    mergeTree (Tree a
x:[Tree a]
xs) Tree a
y
      | forall a. Tree a -> a
rootLabel Tree a
x forall a. Eq a => a -> a -> Bool
== forall a. Tree a -> a
rootLabel Tree a
y = Tree a
x Tree a -> Tree a -> Tree a
`merge'` Tree a
y forall a. a -> [a] -> [a]
: [Tree a]
xs
      | Bool
otherwise = Tree a
x forall a. a -> [a] -> [a]
: [Tree a]
xs [Tree a] -> Tree a -> [Tree 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 :: forall ann. 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 :: forall (m :: * -> *). MonadIO m => String -> m (Either String PGN)
readPGNFile String
fp = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
  forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parser PGN
pgn String
fp forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
stripBOM 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 :: forall ann. Handle -> RAVOrder (Doc ann) -> PGN -> IO ()
hPutPGN Handle
h RAVOrder (Doc ann)
ro (PGN [Game]
games) = forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Game]
games forall a b. (a -> b) -> a -> b
$ \Game
g -> do
  forall ann. Handle -> Doc ann -> IO ()
hPutDoc Handle
h forall a b. (a -> b) -> a -> b
$ 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 = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space
  forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
m ()
space1 (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Word8) =>
Tokens s -> m ()
L.skipLineComment Tokens ByteString
";") (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 :: forall a. Parser a -> Parser a
lexeme = 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 = forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$  forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"1-0" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Color -> Outcome
Win Color
White
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"0-1" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Color -> Outcome
Win Color
Black
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"1/2-1/2" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Outcome
Draw
            forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
"*" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Outcome
Undecided

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

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

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

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

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

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

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

game :: Parser Game
game :: Parser Game
game = do
  [(Text, Text)]
_cgTags <- Parser [(Text, Text)]
tagList
  Position
pos <- case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"FEN" [(Text, Text)]
_cgTags of
    Maybe Text
Nothing -> 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  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Position
p
      Maybe Position
Nothing -> 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
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"string" where
  p :: Parser Text
p = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum)) forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
quoteChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void ByteString Identity Word8
ch forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
quoteChar
  ch :: ParsecT Void ByteString Identity Word8
ch = forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
backslashChar forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (  forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
backslashChar forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Word8
backslashChar
                              forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
single Word8
quoteChar forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Word8
quoteChar
                               )
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall e s (m :: * -> *).
MonadParsec e s m =>
Token s -> m (Token s)
anySingleBut Word8
quoteChar

type RAVOrder a = ([Tree (Annotated Ply)] -> a) -> [Tree (Annotated Ply)] -> [a]

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

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

gameDoc :: RAVOrder (Doc ann) -> Game -> Doc ann
gameDoc :: forall ann. 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)]
.. }
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, Text)]
_cgTags = 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 = forall ann. [(Text, Text)] -> Doc ann
tagsDoc [(Text, Text)]
_cgTags forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
line forall a. Semigroup a => a -> a -> a
<> 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 <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"FEN" [(Text, Text)]
_cgTags = forall a. HasCallStack => Maybe a -> a
fromJust 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 :: forall ann. [(Text, Text)] -> Doc ann
tagsDoc = forall ann. FusionDepth -> Doc ann -> Doc ann
fuse FusionDepth
Shallow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. [Doc ann] -> Doc ann
vsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {a} {ann}. Pretty a => (a, Text) -> Doc ann
tagpair where
  tagpair :: (a, Text) -> Doc ann
tagpair (a
k, Text -> Text
esc -> Text
v) = forall ann. Doc ann -> Doc ann
brackets forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty a
k forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
dquotes (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 :: forall ann.
RAVOrder (Doc ann)
-> Position -> (Outcome, [Tree (Annotated Ply)]) -> Doc ann
moveDoc RAVOrder (Doc ann)
ro Position
p (Outcome
o,[Tree (Annotated Ply)]
f) = forall ann. [Doc ann] -> Doc ann
fillSep (Position -> Bool -> [Tree (Annotated Ply)] -> [Doc ann]
go Position
p Bool
True [Tree (Annotated Ply)]
f forall a. Semigroup a => a -> a -> a
<> [forall a ann. Pretty a => a -> Doc ann
pretty Outcome
o]) forall a. Semigroup a => a -> a -> a
<> 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 forall a. Eq a => a -> a -> Bool
== Color
White Bool -> Bool -> Bool
|| Bool
pmn
    = [Doc ann]
pnag forall a. Semigroup a => a -> a -> a
<> (Doc ann
mnforall a. a -> [a] -> [a]
:Doc ann
sanforall a. a -> [a] -> [a]
:[Doc ann]
snag) forall a. Semigroup a => a -> a -> a
<> [Doc ann]
rav forall a. Semigroup a => a -> a -> a
<> Position -> Bool -> [Tree (Annotated Ply)] -> [Doc ann]
go Position
pos' (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [Doc ann]
rav) (forall a. Tree a -> [Tree a]
subForest Tree (Annotated Ply)
t)
    | Bool
otherwise
    = [Doc ann]
pnag forall a. Semigroup a => a -> a -> a
<> (Doc ann
sanforall a. a -> [a] -> [a]
:[Doc ann]
snag) forall a. Semigroup a => a -> a -> a
<> [Doc ann]
rav forall a. Semigroup a => a -> a -> a
<> Position -> Bool -> [Tree (Annotated Ply)] -> [Doc ann]
go Position
pos' (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ [Doc ann]
rav) (forall a. Tree a -> [Tree a]
subForest Tree (Annotated Ply)
t)
   where
    pl :: Ply
pl = forall a. Annotated a -> a
_annPly forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> a
rootLabel forall a b. (a -> b) -> a -> b
$ Tree (Annotated Ply)
t
    san :: Doc ann
san = forall a ann. Pretty a => a -> Doc ann
pretty 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 = forall {a} {ann}. Pretty a => a -> Doc ann
prettynag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Annotated a -> [Int]
_annPrefixNAG (forall a. Tree a -> a
rootLabel Tree (Annotated Ply)
t)
    mn :: Doc ann
mn = forall a ann. Pretty a => a -> Doc ann
pretty (Position -> Int
moveNumber Position
pos) forall a. Semigroup a => a -> a -> a
<> if Position -> Color
color Position
pos forall a. Eq a => a -> a -> Bool
== Color
White then Doc ann
"." else Doc ann
"..."
    rav :: [Doc ann]
rav = RAVOrder (Doc ann)
ro (forall ann. Doc ann -> Doc ann
parens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. [Doc ann] -> Doc ann
fillSep 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 = forall {a} {ann}. Pretty a => a -> Doc ann
prettynag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Annotated a -> [Int]
_annSuffixNAG (forall a. Tree a -> a
rootLabel Tree (Annotated Ply)
t)
  prettynag :: a -> Doc ann
prettynag a
n = Doc ann
"$" forall a. Semigroup a => a -> a -> a
<> 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) = forall {a} {b}.
(Num a, Ord a, Eq b) =>
[Tree (a, b)] -> [Tree (a, b)]
merge forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. Integral a => Game -> [Tree (Ratio a, Ply)]
rate forall a b. (a -> b) -> a -> b
$ 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)]
.. } = forall a. Maybe a -> Bool
isNothing (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"FEN" [(Text, Text)]
_cgTags) Bool -> Bool -> Bool
&& Outcome
_cgOutcome 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. [Tree a] -> [Tree a]
trunk [Tree (Annotated Ply)]
_cgForest where
    w :: Color -> Ratio a
w Color
c = case Outcome
_cgOutcome of
      Win Color
c' | Color
c forall a. Eq a => a -> a -> Bool
== Color
c' -> Ratio a
1
             | Bool
otherwise -> -Ratio a
1
      Outcome
Draw -> a
1 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') = forall a. a -> [Tree a] -> Tree a
Node (Color -> Ratio a
w (Position -> Color
color Position
pos), forall a. Annotated a -> a
_annPly Annotated Ply
a) forall a b. (a -> b) -> a -> b
$
      Position -> Tree (Annotated Ply) -> Tree (Ratio a, Ply)
f (Position -> Ply -> Position
unsafeDoPly Position
pos (forall a. Annotated a -> a
_annPly Annotated Ply
a)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree (Annotated Ply)]
ts'
  trunk :: [Tree a] -> [Tree a]
trunk []    = []
  trunk (Tree a
x:[Tree a]
_) = [Tree a
x { subForest :: [Tree a]
subForest = [Tree a] -> [Tree a]
trunk (forall a. Tree a -> [Tree 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) =
      forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> a
rootLabel)
    forall a b. (a -> b) -> a -> b
$ forall a. a -> [Tree a] -> Tree a
Node (a
w, forall a b. (a, b) -> b
snd (a, b)
a) ([Tree (a, b)] -> [Tree (a, b)]
merge forall a b. (a -> b) -> a -> b
$ [Tree (a, b)]
ts forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Tree a -> [Tree a]
subForest [Tree (a, b)]
good) 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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall {a} {a} {a}. Eq a => (a, a) -> (a, a) -> Bool
eq (a, b)
a forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> a
rootLabel) [Tree (a, b)]
xs where eq :: (a, a) -> (a, a) -> Bool
eq (a, a)
x (a, a)
y = forall a b. (a, b) -> b
snd (a, a)
x forall a. Eq a => a -> a -> Bool
== forall a b. (a, b) -> b
snd (a, a)
y
    w :: a
w = forall a b. (a, b) -> a
fst (a, b)
a forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Tree a -> a
rootLabel forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Tree (a, b)]
good)