summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorErin van der Veen2017-11-27 13:20:41 +0100
committerErin van der Veen2017-11-27 13:20:41 +0100
commit7e8b348d26cc1cf6366d7efabe8141a833f1dad5 (patch)
tree4ec4a0b3856b9d985efde81e6c974ec18b54941e
parentFix merge problem (diff)
parentCleanup (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/.gitignore3
-rw-r--r--test/ArbitraryMove.hs12
-rw-r--r--test/Makefile31
-rw-r--r--test/Test.hs52
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