diff options
| -rw-r--r-- | test/ArbitraryMove.hs | 4 | ||||
| -rw-r--r-- | test/Test.hs | 36 |
2 files changed, 21 insertions, 19 deletions
diff --git a/test/ArbitraryMove.hs b/test/ArbitraryMove.hs index df3d7fb..e786a68 100644 --- a/test/ArbitraryMove.hs +++ b/test/ArbitraryMove.hs @@ -56,8 +56,6 @@ instance Arbitrary PGN sensibleString = listOf $ choose ('a', 'z') - shrink pgn = [pgn {moves=ms} | ms <- shrink $ moves pgn] - {- This file can largely be generated with the following pipeline: - - grep -v '^\(\[\|$\)' \ @@ -915,7 +913,6 @@ probableArbitraryMove = frequency $ map (return <$>) , (28, "f8=R") , (5, "f8=R#") , (6, "f8=R+") - , (2, "ff") , (1, "fxe1=N") , (6, "fxe1=N+") , (49, "fxe1=Q") @@ -6364,7 +6361,6 @@ probableArbitraryMove = frequency $ map (return <$>) , (12, "Rcxh7") , (2, "Rcxh7+") , (1, "Rcxh8") - , (1, "Rd") , (223186, "Rd1") , (147, "Rd1#") , (26353, "Rd1+") diff --git a/test/Test.hs b/test/Test.hs index 897c788..2d785e7 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -13,6 +13,7 @@ import Data.Maybe import Control.Monad import Test.QuickCheck +import Test.QuickCheck.Random import Chess import Chess.FEN @@ -20,12 +21,13 @@ import Chess.PGN import ArbitraryMove -atAnyState :: (Board -> Bool) -> PGN -> Bool +atAnyState :: (Board -> Bool) -> PGN -> Property atAnyState = atAnyTwoStates . const -atAnyTwoStates :: (Board -> Board -> Bool) -> PGN -> Bool +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] @@ -34,14 +36,17 @@ atAnyTwoStates ok pgn = seqList [] _ = [] -prop_checkPGN :: PGN -> Bool -prop_checkPGN pgn - | isLeft parsed = False - | length parsed' /= 1 = False - | otherwise = pgn == ((head parsed') {initialPosition=Just defaultBoard}) +prop_checkPGN :: Property +prop_checkPGN = withMaxSuccess 1000 test where - parsed = parseOnly pgnParser (pack $ pgnToString pgn) - (Right parsed') = parsed + 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 @@ -84,30 +89,30 @@ pieceCoords clr piece brd = [(i,pc) | (i,Just pc) <- assocs $ board brd, match p (isJust clr && clr' == fromJust clr || isNothing clr) && (isJust piece && piece' == fromJust piece || isNothing piece) -prop_only_2_kings :: PGN -> Bool +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 -> Bool +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 -> Bool +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 -> Bool +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 -> Bool +prop_move_not_result_check :: PGN -> Property prop_move_not_result_check = atAnyTwoStates (\b1 b2 -> case turn b1 of White -> not (check White b2) @@ -115,4 +120,5 @@ prop_move_not_result_check = atAnyTwoStates (\b1 b2 -> ) return [] -main = $forAllProperties (quickCheckWithResult (stdArgs {maxSuccess=10000})) +main = $forAllProperties (quickCheckWithResult (stdArgs + {maxSuccess=100000, replay=Just (mkQCGen 37,0)})) |