diff options
author | Erin van der Veen | 2017-11-27 13:20:41 +0100 |
---|---|---|
committer | Erin van der Veen | 2017-11-27 13:20:41 +0100 |
commit | 7e8b348d26cc1cf6366d7efabe8141a833f1dad5 (patch) | |
tree | 4ec4a0b3856b9d985efde81e6c974ec18b54941e | |
parent | Fix merge problem (diff) | |
parent | Cleanup (diff) |
Merge branch '9-test-on-legal-games' into 'master'
Add Markov chain test case generator
Closes #9
See merge request eveen/Testing-Techniques!11
-rw-r--r-- | test/.gitignore | 3 | ||||
-rw-r--r-- | test/ArbitraryMove.hs | 12 | ||||
-rw-r--r-- | test/Makefile | 31 | ||||
-rw-r--r-- | test/Test.hs | 52 |
4 files changed, 76 insertions, 22 deletions
diff --git a/test/.gitignore b/test/.gitignore index 0d7a855..0074782 100644 --- a/test/.gitignore +++ b/test/.gitignore @@ -1 +1,2 @@ -test_parser +dataset.pgn +Test diff --git a/test/ArbitraryMove.hs b/test/ArbitraryMove.hs index e786a68..4c6fb48 100644 --- a/test/ArbitraryMove.hs +++ b/test/ArbitraryMove.hs @@ -19,15 +19,7 @@ instance Arbitrary Board where arbitrary = return defaultBoard type Move = String arbitraryMove :: Gen Move -arbitraryMove = frequency - [ (2, probableArbitraryMove) - --, (1, invalidMove) - ] - where - invalidMove :: Gen Move - invalidMove = oneof - [ liftM2 (\r c -> [r,c]) (choose ('i', 'z')) (elements "09") - ] +arbitraryMove = probableArbitraryMove instance Arbitrary PGN where @@ -69,7 +61,7 @@ instance Arbitrary PGN - on a set of PGN games, e.g. from http://theweekinchess.com/twic. -} -probableArbitraryMove :: Gen String +probableArbitraryMove :: Gen Move probableArbitraryMove = frequency $ map (return <$>) [ (8, "a1=B") , (2, "a1=B+") diff --git a/test/Makefile b/test/Makefile new file mode 100644 index 0000000..ba62dab --- /dev/null +++ b/test/Makefile @@ -0,0 +1,31 @@ +EXE:=Test +DEP:=ArbitraryMove +AUX:=$(addsuffix .o, $(EXE) $(DEP))\ + $(addsuffix .hi, $(EXE) $(DEP))\ + $(addsuffix .dyn_o, $(EXE) $(DEP))\ + $(addsuffix .dyn_hi,$(EXE) $(DEP)) +SRC:=$(addsuffix .hs,$(DEP)) +GHC:=ghc +GHCFLAGS:=-O -main-is Test.main +DATA:=dataset.pgn + +.PHONY=all run clean + +all: $(EXE) + +$(DATA): + for i in $$(seq 1000 1020); do wget -q http://www.theweekinchess.com/zips/twic$${i}g.zip; unzip -q twic$${i}g.zip; rm twic$${i}g.zip; done + cat twic*.pgn > $@ + $(RM) twic*.pgn + +run: $(EXE) $(DATA) + ./$(EXE) < $(DATA) + +$(EXE): %: %.hs $(SRC) + $(GHC) $(GHCFLAGS) $< -o $@ + +clean: + $(RM) $(EXE) $(AUX) + +distclean: clean + $(RM) $(DATA) diff --git a/test/Test.hs b/test/Test.hs index 983b48d..b162a9f 100644 --- a/test/Test.hs +++ b/test/Test.hs @@ -2,15 +2,19 @@ -- vim: sw=2 ts=2 et ai: module Test where +import Control.Monad + import Data.Array -import Data.Attoparsec.ByteString.Char8 +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 Control.Monad +import System.IO +import System.Random import Test.QuickCheck import Test.QuickCheck.Random @@ -27,7 +31,11 @@ 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") $ + 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] @@ -113,11 +121,7 @@ prop_not_in_check_twice = atAnyTwoStates (\b1 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) - ) +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) @@ -125,6 +129,32 @@ prop_dont_touch_my_pieces = atAnyTwoStates (\b1 b2 -> notMoved (turn b2) b1 b2) notMoved :: Color -> Board -> Board -> Bool notMoved c = (\b a -> null (a \\ b)) `on` pieceCoords (Just c) Nothing -return [] -main = $forAllProperties (quickCheckWithResult (stdArgs - {maxSuccess=100000, replay=Just (mkQCGen 37,0)})) +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 |