1 files changed, 41 insertions, 11 deletions
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