{-# 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 Chess
import Chess.FEN
import Chess.PGN

import ArbitraryMove

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

atAnyTwoStates :: (Board -> Board -> Bool) -> PGN -> Bool
atAnyTwoStates ok pgn =
  let moveList = seqList [moveSAN m | m <- moves pgn] $ Right defaultBoard in
  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 :: PGN -> Bool
prop_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"

-- 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 -> Bool
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 -> Bool
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 -> Bool
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 -> Bool
prop_not_in_check_twice = atAnyTwoStates (\b1 b2 ->
  not (check Black b1 && check Black b2) &&
  not (check White b1 && check White b2))

return []
main = $forAllProperties (quickCheckWithResult (stdArgs {maxSuccess=10000}))