{-# LANGUAGE TemplateHaskell, ParallelListComp #-} -- vim: sw=2 ts=2 et ai: module Test where import Control.Monad import Data.Array import Data.Attoparsec.ByteString.Char8 (parseOnly) import Data.ByteString.Char8 (pack) import Data.Either import Data.Function import Data.List import Data.MarkovChain import Data.Maybe import System.IO import System.Random 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 let moves = length moveList in classify ( moves < 10) " <10 legal moves" $ classify ( 10 <= moves && moves < 50) "10- 50 legal moves" $ classify ( 50 <= moves && moves < 100) "50-100 legal moves" $ classify (100 <= moves ) "100+ legal moves" $ 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 -> not (check (turn b1) b2)) prop_dont_touch_my_pieces :: PGN -> Property prop_dont_touch_my_pieces = atAnyTwoStates (\b1 b2 -> notMoved (turn b2) b1 b2) where notMoved :: Color -> Board -> Board -> Bool notMoved c = (\b a -> null (a \\ b)) `on` pieceCoords (Just c) Nothing main = do pgns <- readPGN let gen = growingElements $ take 10000 $ runMulti 4 (map moves pgns) 0 (mkStdGen 37) putStrLn "Testing: parser" quickCheck prop_checkPGN putStrLn $ "Building Markov chain from " ++ show (length pgns) ++ " games" check "only 2 kings" gen prop_only_2_kings check "no pawns on rank 1 or 8" gen prop_no_pawns_on_1_and_8 check "no new pieces / more than one piece hit" gen prop_number_of_pieces check "no check on same colour twice" gen prop_not_in_check_twice check "player cannot cause himself to be check" gen prop_move_not_result_check check "player cannot move opponent's pieces" gen prop_dont_touch_my_pieces where check name gen p = do putStrLn $ "Testing: " ++ name quickCheckWith args (forAll (mkPGN <$> gen) p) where args = stdArgs {maxSuccess=10000, replay=Just (mkQCGen 37,0)} mkPGN :: [String] -> PGN mkPGN = PGN "" "" "" "" "" "" Nothing Nothing readPGN :: IO [PGN] readPGN = do hSetEncoding stdin latin1 pgn <- pack <$> getContents case parseOnly pgnParser pgn of Left err -> error err Right [] -> error "no games" Right games -> return games