module BishBosh.ContextualNotation.PGN(
Tag,
IsStrictlySequential,
PGN(
getMaybeRoundName,
getIdentificationTagPairs,
getGame
),
quoteDelimiter,
unknownTagValue,
dateTag,
showsDate,
showsMoveText,
showsGame,
moveTextParser,
parser,
mkPGN,
mkPGN',
setGame
) where
import Control.Arrow((&&&), (***))
import qualified BishBosh.Attribute.LogicalColour as Attribute.LogicalColour
import qualified BishBosh.Component.Move as Component.Move
import qualified BishBosh.ContextualNotation.PGNComment as ContextualNotation.PGNComment
import qualified BishBosh.ContextualNotation.StandardAlgebraic as ContextualNotation.StandardAlgebraic
import qualified BishBosh.Data.Exception as Data.Exception
import qualified BishBosh.Model.Game as Model.Game
import qualified BishBosh.Model.GameTerminationReason as Model.GameTerminationReason
import qualified BishBosh.Model.Result as Model.Result
import qualified BishBosh.State.TurnsByLogicalColour as State.TurnsByLogicalColour
import qualified BishBosh.Text.ShowList as Text.ShowList
import qualified BishBosh.Types as T
import qualified Control.Applicative
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Control.Exception
import qualified Data.Char
import qualified Data.Default
import qualified Data.List
import qualified Data.Map
import qualified Data.Maybe
import qualified Data.Time.Calendar
import qualified Data.Time.Clock
import qualified Text.Printf
#ifdef USE_POLYPARSE
import qualified BishBosh.Text.Poly as Text.Poly
#if USE_POLYPARSE == 1
import qualified Text.ParserCombinators.Poly.Lazy as Poly
#else /* Plain */
import qualified Text.ParserCombinators.Poly.Plain as Poly
#endif
#else /* Parsec */
import qualified BishBosh.Data.Integral as Data.Integral
import qualified Text.ParserCombinators.Parsec as Parsec
import Text.ParserCombinators.Parsec((<?>), (<|>))
#endif
tagPairDelimiters :: (Char, Char)
tagPairDelimiters = ('[', ']')
ravDelimiters :: (Char, Char)
ravDelimiters = ('(', ')')
inProgressFlag :: Char
inProgressFlag = '*'
nagPrefix :: Char
nagPrefix = '$'
moveNumberTerminator :: Char
moveNumberTerminator = '.'
quoteDelimiter :: Char
quoteDelimiter = '"'
dateComponentSeparator :: Char
dateComponentSeparator = '.'
unknownTagValue :: Char
unknownTagValue = '?'
type Tag = String
type Value = String
type TagPair = (Tag, Value)
type IsStrictlySequential = Bool
eventNameTag :: Tag
eventNameTag = "Event"
siteNameTag :: Tag
siteNameTag = "Site"
dateTag :: Tag
dateTag = "Date"
roundNameTag :: Tag
roundNameTag = "Round"
whitePlayerNameTag :: Tag
whitePlayerNameTag = "White"
blackPlayerNameTag :: Tag
blackPlayerNameTag = "Black"
resultTag :: Tag
resultTag = "Result"
showsDate :: Data.Time.Calendar.Day -> ShowS
showsDate = (
\(y, m, d) -> shows (Text.Printf.printf "%04d.%02d.%02d" y m d :: String)
) . Data.Time.Calendar.toGregorian
data PGN x y = MkPGN {
getMaybeEventName :: Maybe Value,
getMaybeSiteName :: Maybe Value,
getDay :: Data.Time.Calendar.Day,
getMaybeRoundName :: Maybe Value,
getMaybeWhitePlayerName :: Maybe Value,
getMaybeBlackPlayerName :: Maybe Value,
getIdentificationTagPairs :: [TagPair],
getGame :: Model.Game.Game x y
} deriving Eq
instance (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Show (PGN x y) where
showsPrec _ MkPGN {
getMaybeEventName = maybeEventName,
getMaybeSiteName = maybeSiteName,
getDay = day,
getMaybeRoundName = maybeRoundName,
getMaybeWhitePlayerName = maybeWhitePlayerName,
getMaybeBlackPlayerName = maybeBlackPlayerName,
getIdentificationTagPairs = identificationTagPairs,
getGame = game
} = foldr (
\(tagName, showsTagValue) accum -> showChar (fst tagPairDelimiters) . showString tagName . showChar ' ' . showsTagValue . showChar (snd tagPairDelimiters) . showChar '\n' . accum
) (
showsMoveText game . showChar '\n'
) $ [
(
eventNameTag, representUnknownTagValue maybeEventName
), (
siteNameTag, representUnknownTagValue maybeSiteName
), (
dateTag, showsDate day
), (
roundNameTag, representUnknownTagValue maybeRoundName
), (
whitePlayerNameTag, representUnknownTagValue maybeWhitePlayerName
), (
blackPlayerNameTag, representUnknownTagValue maybeBlackPlayerName
), (
resultTag, quote . Data.Maybe.maybe (showChar inProgressFlag) (shows . Model.GameTerminationReason.toResult) $ Model.Game.getMaybeTerminationReason game
)
] ++ map (
Control.Arrow.second $ quote . showString
) identificationTagPairs where
quote :: ShowS -> ShowS
quote s = showChar quoteDelimiter . s . showChar quoteDelimiter
representUnknownTagValue :: Maybe Value -> ShowS
representUnknownTagValue = quote . Data.Maybe.maybe (showChar unknownTagValue) showString
instance (
Control.DeepSeq.NFData x,
Control.DeepSeq.NFData y
) => Control.DeepSeq.NFData (PGN x y) where
rnf MkPGN {
getIdentificationTagPairs = identificationTagPairs,
getGame = game
} = Control.DeepSeq.rnf (identificationTagPairs, game)
mkPGN
:: Maybe Value
-> Maybe Value
-> Data.Time.Calendar.Day
-> Maybe Value
-> Maybe Value
-> Maybe Value
-> [TagPair]
-> Model.Game.Game x y
-> PGN x y
mkPGN maybeEventName maybeSiteName day maybeRoundName maybeWhitePlayerName maybeBlackPlayerName identificationTagPairs game
| any (
(== [unknownTagValue]) . snd
) explicitTags = Control.Exception.throw . Data.Exception.mkInvalidDatum . showString "BishBosh.ContextualNotation.PGN.mkPGN:\tunknownTagValue" . Text.ShowList.showsAssociation . shows unknownTagValue . showString " used literally; " $ show explicitTags
| otherwise = MkPGN {
getMaybeEventName = maybeEventName,
getMaybeSiteName = maybeSiteName,
getDay = day,
getMaybeRoundName = maybeRoundName,
getMaybeWhitePlayerName = maybeWhitePlayerName,
getMaybeBlackPlayerName = maybeBlackPlayerName,
getIdentificationTagPairs = identificationTagPairs,
getGame = game
}
where
explicitTags = [
(tag, value) |
(tag, Just value) <- [
(
eventNameTag, maybeEventName
), (
siteNameTag, maybeSiteName
), (
whitePlayerNameTag, maybeWhitePlayerName
), (
blackPlayerNameTag, maybeBlackPlayerName
)
]
]
setGame :: Model.Game.Game x y -> PGN x y -> PGN x y
setGame game pgn = pgn { getGame = game }
mkPGN'
:: [Tag]
-> [TagPair]
-> Model.Game.Game x y
-> PGN x y
mkPGN' identificationTags tagPairs = mkPGN maybeEventName maybeSiteName (
let
#ifdef USE_POLYPARSE
dateParser :: Text.Poly.TextParser Data.Time.Calendar.Day
dateParser = do
[y, m, d] <- Text.Poly.spaces >> Poly.sepBy1 Text.Poly.unsignedDecimal (Text.Poly.char dateComponentSeparator)
return $ Data.Time.Calendar.fromGregorian (fromIntegral y) m d
in Data.Maybe.maybe (
Control.Exception.throw . Data.Exception.mkSearchFailure . showString "failed to find " $ show dateTag
) (
#if USE_POLYPARSE != 1
either (
Control.Exception.throw . Data.Exception.mkParseFailure . showString "failed to parse " . shows dateTag . showString "; " . show
) id .
#endif
fst . Poly.runParser dateParser
#else /* Parsec */
dateParser :: Parsec.Parser Data.Time.Calendar.Day
dateParser = do
[y, m, d] <- Parsec.spaces >> (Parsec.sepBy1 (Control.Applicative.some Parsec.digit) (Parsec.char dateComponentSeparator) <?> "YYYY.MM.DD")
return $ Data.Time.Calendar.fromGregorian (read y) (read m) (read d)
in Data.Maybe.maybe (
Control.Exception.throw . Data.Exception.mkSearchFailure . showString "failed to find " $ show dateTag
) (
either (
Control.Exception.throw . Data.Exception.mkParseFailure . showString "failed to parse " . shows dateTag . showString "; " . show
) id . Parsec.parse dateParser "Date-parser"
#endif
) maybeDate
) maybeRoundName maybeWhitePlayerName maybeBlackPlayerName $ filter (
(`elem` identificationTags) . fst
) tagPairs where
[maybeEventName, maybeSiteName, maybeDate, maybeRoundName, maybeWhitePlayerName, maybeBlackPlayerName] = map (
`Data.Map.lookup` Data.Map.fromList tagPairs
) [
eventNameTag,
siteNameTag,
dateTag,
roundNameTag,
whitePlayerNameTag,
blackPlayerNameTag
]
showsMoveText :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Model.Game.Game x y -> ShowS
showsMoveText game = foldr (.) (
Data.Maybe.maybe (
showsBlockComment "Game unfinished" . showChar ' ' . showChar inProgressFlag
) (
(
\(s, showsPGN) -> showsBlockComment s . showChar ' ' . showsPGN
) . (
filter (/= ContextualNotation.PGNComment.blockCommentEnd) . show &&& shows . Model.GameTerminationReason.toResult
)
) $ Model.Game.getMaybeTerminationReason game
) $ Data.List.unfoldr (
\(moveNumber, turns) -> case turns of
showsWhiteMove : remainder -> Just . (
(
\moveList -> shows moveNumber . showChar moveNumberTerminator . showChar ' ' . showsWhiteMove . Data.Maybe.maybe id (
\showsBlackMove -> showChar ' ' . showsBlackMove
) (
Data.Maybe.listToMaybe moveList
) . showChar ' '
) *** (,) (succ moveNumber)
) $ Data.List.splitAt 1 remainder
_ -> Nothing
) (
1 :: Component.Move.NMoves,
reverse $ fst . foldr (
\turn (l, game') -> (
ContextualNotation.StandardAlgebraic.showsTurn False turn game' : l,
Model.Game.takeTurn turn game'
)
) ([], Data.Default.def ) $ Model.Game.listTurns game
) where
showsBlockComment :: String -> ShowS
showsBlockComment = shows . ContextualNotation.PGNComment.BlockComment
showsGame :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Model.Game.Game x y -> IO ShowS
showsGame game = do
utcTime <- Data.Time.Clock.getCurrentTime
return . shows $ mkPGN Nothing Nothing (Data.Time.Clock.utctDay utcTime) Nothing Nothing Nothing [] game
nagParser :: (
Num i,
Ord i,
Show i
) =>
#ifdef USE_POLYPARSE
Text.Poly.TextParser i
nagParser = do
code <- Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Text.Poly.spaces >> Text.Poly.char nagPrefix >> Text.Poly.unsignedDecimal
if code > maxCode
then Poly.failBad . shows code . showString " > maximum NAG" . Text.ShowList.showsAssociation $ shows maxCode "."
else return code
#else /* Parsec */
Parsec.Parser i
nagParser = Parsec.try $ do
code <- Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> Parsec.char nagPrefix >> fmap Data.Integral.stringToUnsignedDecimal (Control.Applicative.some Parsec.digit)
if code > maxCode
then fail . shows code . showString " > maximum NAG" . Text.ShowList.showsAssociation $ shows maxCode "."
else return code
#endif
where
maxCode = 255
moveNumberParser :: Num n =>
#ifdef USE_POLYPARSE
Text.Poly.TextParser n
moveNumberParser = Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Text.Poly.unsignedDecimal `Poly.discard` Control.Applicative.some (Text.Poly.char moveNumberTerminator)
#else /* Parsec */
Parsec.Parser n
moveNumberParser = Parsec.try $ Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> fmap Data.Integral.stringToUnsignedDecimal (
Parsec.manyTill Parsec.digit (
Control.Applicative.some $ Parsec.char moveNumberTerminator
) <?> "Move-number"
)
#endif
maybeResultParser ::
#ifdef USE_POLYPARSE
Text.Poly.TextParser (Maybe Model.Result.Result)
maybeResultParser = Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Text.Poly.spaces >> Poly.oneOf' [
(
"Result",
Poly.oneOf $ map (
\result -> Text.Poly.string (show result) >> return (Just result)
) Model.Result.range
), (
"Game unfinished",
Poly.commit (Text.Poly.char inProgressFlag) >> return Nothing
)
]
#else /* Parsec */
Parsec.Parser (Maybe Model.Result.Result)
maybeResultParser = Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> (
Parsec.try (
Parsec.choice $ map (
\result -> Parsec.try $ (Parsec.string (show result) <?> "Result") >> return (Just result)
) Model.Result.range
) <|> (
(Parsec.char inProgressFlag <?> "Game unfinished") >> return Nothing
)
)
#endif
moveTextParser :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
#ifdef USE_POLYPARSE
=> IsStrictlySequential
-> ContextualNotation.StandardAlgebraic.ValidateMoves
-> Text.Poly.TextParser (Model.Game.Game x y)
moveTextParser isStrictlySequential validateMoves = let
elementSequenceParser :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Model.Game.Game x y -> Text.Poly.TextParser (Model.Game.Game x y)
elementSequenceParser game = let
expectedMoveNumber = succ . (`div` 2) . State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game
in do
moveNumber <- (
if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game
then fmap (Data.Maybe.fromMaybe expectedMoveNumber) . Control.Applicative.optional
else id
) moveNumberParser
if isStrictlySequential && moveNumber /= expectedMoveNumber
then do
context <- Poly.manyFinally' Poly.next $ Text.Poly.char '\n'
Poly.failBad . showString "found " . shows (Model.Game.getNextLogicalColour game) . showString " move-number" . Text.ShowList.showsAssociation . shows moveNumber . showString " where " . shows expectedMoveNumber . showString " expected, before " $ shows context "."
else do
game' <- fmap (`ContextualNotation.StandardAlgebraic.movePiece` game) $ Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> ContextualNotation.StandardAlgebraic.parser False validateMoves game
Control.Applicative.many (
nagParser :: Text.Poly.TextParser Int
) >> Control.Applicative.many (
uncurry Poly.bracket (
(
\c -> Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Text.Poly.spaces >> Text.Poly.char c
) *** (
\c -> Poly.commit $ Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Text.Poly.spaces >> Text.Poly.char c
) $ ravDelimiters
) $ elementSequenceParser game
) >> fmap (Data.Maybe.fromMaybe game') (
Control.Applicative.optional $ elementSequenceParser game'
)
in do
game <- fmap (Data.Maybe.fromMaybe Data.Default.def ) . Control.Applicative.optional $ elementSequenceParser Data.Default.def
#else /* Parsec */
=> IsStrictlySequential
-> ContextualNotation.StandardAlgebraic.ValidateMoves
-> Parsec.Parser (Model.Game.Game x y)
moveTextParser isStrictlySequential validateMoves = let
elementSequenceParser :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
) => Model.Game.Game x y -> Parsec.Parser (Model.Game.Game x y)
elementSequenceParser game = let
expectedMoveNumber = succ . (`div` 2) . State.TurnsByLogicalColour.getNPlies $ Model.Game.getTurnsByLogicalColour game
in do
moveNumber <- (
if Attribute.LogicalColour.isBlack $ Model.Game.getNextLogicalColour game
then fmap (Data.Maybe.fromMaybe expectedMoveNumber) . Control.Applicative.optional
else id
) moveNumberParser
if isStrictlySequential && moveNumber /= expectedMoveNumber
then fail . showString "found " . shows (Model.Game.getNextLogicalColour game) . showString " move-number" . Text.ShowList.showsAssociation . shows moveNumber . showString " where " $ shows expectedMoveNumber " expected."
else do
game' <- (`ContextualNotation.StandardAlgebraic.movePiece` game) <$> (Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> ContextualNotation.StandardAlgebraic.parser False validateMoves game)
Control.Applicative.many (
nagParser :: Parsec.Parser Int
) >> Control.Applicative.many (
Parsec.try . uncurry Parsec.between (
(
\c -> Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> Parsec.char c
) *** (
\c -> Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> Parsec.char c
) $ ravDelimiters
) $ elementSequenceParser game
) >> Parsec.option game' (
Parsec.try $ elementSequenceParser game'
)
in do
game <- Parsec.option Data.Default.def . Parsec.try $ elementSequenceParser Data.Default.def
#endif
Data.Maybe.maybe game (`Model.Game.updateTerminationReasonWith` game) `fmap` maybeResultParser
parser :: (
Enum x,
Enum y,
Ord x,
Ord y,
Show x,
Show y
)
=> IsStrictlySequential
-> ContextualNotation.StandardAlgebraic.ValidateMoves
-> [Tag]
#ifdef USE_POLYPARSE
-> Text.Poly.TextParser (PGN x y)
parser isStrictlySequential validateMoves identificationTags = do
tagPairs <- Control.Applicative.many $ tagPairParser <* Control.Applicative.many ContextualNotation.PGNComment.parser
moveText <- moveTextParser' <* Control.Applicative.many ContextualNotation.PGNComment.parser
return $ mkPGN' identificationTags (removeUnknownTagValues tagPairs) moveText
where
tagPairParser :: Text.Poly.TextParser TagPair
tagPairParser = Control.Applicative.many ContextualNotation.PGNComment.parser >> Text.Poly.spaces >> uncurry Poly.bracket (
Text.Poly.char *** Poly.commit . Text.Poly.char $ tagPairDelimiters
) (
do
tagName <- Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Text.Poly.spaces >> Poly.commit (Control.Applicative.some $ Poly.satisfyMsg isValidTagCharacter "Tag-name")
tagValue <- Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Text.Poly.spaces >> Poly.bracket (
Text.Poly.char quoteDelimiter
) (
Poly.commit $ Text.Poly.char quoteDelimiter
) (
Control.Applicative.many $ Poly.satisfyMsg (/= quoteDelimiter) "Tag-value"
)
Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Text.Poly.spaces
return (tagName, tagValue)
)
#else /* Parsec */
-> Parsec.Parser (PGN x y)
parser isStrictlySequential validateMoves identificationTags = mkPGN' identificationTags <$> (
removeUnknownTagValues <$> Control.Applicative.many (
tagPairParser <* Control.Applicative.many ContextualNotation.PGNComment.parser
)
) <*> moveTextParser' <* Control.Applicative.many ContextualNotation.PGNComment.parser
where
tagPairParser :: Parsec.Parser TagPair
tagPairParser = Parsec.try $ Control.Applicative.many ContextualNotation.PGNComment.parser >> Parsec.spaces >> uncurry Parsec.between (
Parsec.char *** Parsec.char $ tagPairDelimiters
) (
do
tagName <- Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> (Control.Applicative.some (Parsec.satisfy isValidTagCharacter) <?> "Tag-name")
tagValue <- Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces >> Parsec.between (
Parsec.char quoteDelimiter
) (
Parsec.char quoteDelimiter
) (
Control.Applicative.many (Parsec.satisfy (/= quoteDelimiter)) <?> "Tag-value"
)
Control.Applicative.many ContextualNotation.PGNComment.blockCommentParser >> Parsec.spaces
return (tagName, tagValue)
)
#endif
moveTextParser' = moveTextParser isStrictlySequential validateMoves
isValidTagCharacter :: Char -> Bool
isValidTagCharacter = uncurry (&&) . (not . Data.Char.isSpace &&& (/= quoteDelimiter))
removeUnknownTagValues :: [TagPair] -> [TagPair]
removeUnknownTagValues = filter ((/= [unknownTagValue]) . snd )