{-# 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 (
PGN(..)
, Game(..), cgTags, cgOutcome, cgForest
, Outcome(..), _Win, _Draw, _Undecided
, Annotated(..), annPrefixNAG, annPly, annSuffixNAG
, readPGNFile, gameFromForest, pgnForest
, pgn
, 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)