{-# 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

import qualified ArbitraryMove as AM

deriving instance Eq PGN

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

type Move = String

arbitraryMove :: Gen Move
arbitraryMove = frequency
  [ (2, AM.arbitraryMove)
  , (1, invalidMove)
  ]
  where
    invalidMove :: Gen Move
    invalidMove = oneof
      [ liftM2 (\r c -> [r,c]) (choose ('i', 'z')) (elements "09")
      ]

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"