{-# LANGUAGE StandaloneDeriving #-}
-- vim: sw=2 ts=2 et ai:
import Data.Attoparsec.ByteString.Char8
import Data.ByteString.Char8 (pack)

import Data.Either
import Data.List

import Control.Monad

import Test.QuickCheck

import Chess
import Chess.FEN
import Chess.PGN

deriving instance Eq PGN

instance Arbitrary GameResult where arbitrary = elements [BlackWon, WhiteWon, Draw]
instance Arbitrary Board where arbitrary = return defaultBoard
arbitraryMove = return "e4"

instance Arbitrary PGN
  where
    arbitrary = liftM9 PGN
        sensibleString
        sensibleString
        sensibleString
        sensibleString
        sensibleString
        sensibleString
        arbitrary
        (Just <$> arbitrary)
        (liftM2 (:) arbitraryMove (listOf arbitraryMove))
      where
        liftM9 f m1 m2 m3 m4 m5 m6 m7 m8 m9 = do
          x1 <- m1
          x2 <- m2
          x3 <- m3
          x4 <- m4
          x5 <- m5
          x6 <- m6
          x7 <- m7
          x8 <- m8
          x9 <- m9
          return $ f x1 x2 x3 x4 x5 x6 x7 x8 x9

        sensibleString = listOf $ choose ('a', 'z')

main = quickCheck (withMaxSuccess 10000 checkPGN)
  where
    checkPGN :: PGN -> Bool
    checkPGN pgn
      | isLeft parsed       = False
      | length parsed' /= 1 = False
      | otherwise           = pgn == ((head parsed') {initialPosition=Just defaultBoard})
      where
        parsed = parseOnly pgnParser (pack $ pgnToString pgn)
        (Right parsed') = parsed

pgnToString :: PGN -> String
pgnToString pgn = makePGN
    (event pgn)
    (site pgn)
    (date pgn)
    (Chess.PGN.round pgn)
    (whitePlayer pgn)
    (blackPlayer pgn)
    (resultString $ result pgn)
    ("1. " ++ intercalate " 1. " (moves pgn) ++ " " ++ resultString (result pgn))
  where
    resultString :: Maybe GameResult -> String
    resultString Nothing = "*"
    resultString (Just WhiteWon) = "1-0"
    resultString (Just BlackWon) = "0-1"
    resultString (Just Draw)     = "1/2-1/2"

makePGN :: String -> String -> String -> String -> String -> String -> String -> String -> String
makePGN event site date round white black result moves =
  concatMap (uncurry tagPair)
    [ ("Event",  event)
    , ("Site",   site)
    , ("Date",   date)
    , ("Round",  round)
    , ("White",  white)
    , ("Black",  black)
    , ("Result", result)
    ] ++ "\r\n" ++ moves
  where
    tagPair :: String -> String -> String
    tagPair tag val = "[" ++ tag ++ " \"" ++ val ++ "\"]\r\n"