{-# LANGUAGE TemplateHaskell, ParallelListComp #-}
-- vim: sw=2 ts=2 et ai:
module Test where

import Data.Array
import Data.Attoparsec.ByteString.Char8
import Data.ByteString.Char8 (pack)

import Data.Either
import Data.List
import Data.Maybe

import Control.Monad

import Test.QuickCheck
import Test.QuickCheck.Random

import Chess
import Chess.FEN
import Chess.PGN

import ArbitraryMove

atAnyState :: (Board -> Bool) -> PGN -> Property
atAnyState = atAnyTwoStates . const

atAnyTwoStates :: (Board -> Board -> Bool) -> PGN -> Property
atAnyTwoStates ok pgn =
  let moveList = seqList [moveSAN m | m <- moves pgn] $ Right defaultBoard in
  classify True (let l = length moveList - 1 in show l ++ " legal move" ++ if (l == 1) then "" else "s") $
  and [ok b1 b2 | Right b1 <- moveList | Right b2 <- tail moveList]
  where
    seqList :: [r -> Either e r] -> Either e r -> [Either e r]
    seqList (f:fs) (Right io) = f io:seqList fs (f io)
    seqList _      (Left _)   = []
    seqList []     _          = []


prop_checkPGN :: Property
prop_checkPGN = withMaxSuccess 1000 test
  where
    test :: PGN -> Bool
    test 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"

-- From Chess.hs, with adaptations
pieceCoords :: Maybe Color -> Maybe PieceType -> Board -> [((Int,Int),Piece)]
pieceCoords clr piece brd = [(i,pc) | (i,Just pc) <- assocs $ board brd, match pc]
  where
    match :: Piece -> Bool
    match (Piece clr' piece') =
      (isJust clr   && clr'   == fromJust clr   || isNothing clr) &&
      (isJust piece && piece' == fromJust piece || isNothing piece)

prop_only_2_kings :: PGN -> Property
prop_only_2_kings = atAnyState (\b ->
  length (pieceCoords (Just Black) (Just King) b) == 1 &&
  length (pieceCoords (Just White) (Just King) b) == 1)

prop_no_pawns_on_1_and_8 :: PGN -> Property
prop_no_pawns_on_1_and_8 = atAnyState $ all notOn1or8 . pieceCoords Nothing (Just Pawn)
  where
    notOn1or8 :: ((Int,Int),a) -> Bool
    notOn1or8 ((_,r),_) = r /= 0 && r /= 7

prop_number_of_pieces :: PGN -> Property
prop_number_of_pieces = atAnyTwoStates (\b1 b2 ->
  length (pieceCoords Nothing Nothing b1) == length (pieceCoords Nothing Nothing b2)
  ||
  length (pieceCoords Nothing Nothing b1) - 1 == length (pieceCoords Nothing Nothing b2)
  )

prop_not_in_check_twice :: PGN -> Property
prop_not_in_check_twice = atAnyTwoStates (\b1 b2 ->
  not (check Black b1 && check Black b2) &&
  not (check White b1 && check White b2))

prop_move_not_result_check :: PGN -> Property
prop_move_not_result_check = atAnyTwoStates (\b1 b2 ->
  case turn b1 of
    White -> not (check White b2)
    Black -> not (check Black b2)
  )

return []
main = $forAllProperties (quickCheckWithResult (stdArgs
  {maxSuccess=100000, replay=Just (mkQCGen 37,0)}))