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