summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--test/ArbitraryMove.hs58
-rw-r--r--test/Test.hs63
-rw-r--r--test/test_parser.hs107
3 files changed, 119 insertions, 109 deletions
diff --git a/test/ArbitraryMove.hs b/test/ArbitraryMove.hs
index e1c5228..bcde156 100644
--- a/test/ArbitraryMove.hs
+++ b/test/ArbitraryMove.hs
@@ -1,9 +1,63 @@
+{-# LANGUAGE StandaloneDeriving #-}
-- vim: sw=2 ts=2 et ai:
module ArbitraryMove (arbitraryMove)
where
+import Control.Monad
+
import Test.QuickCheck
+import Chess
+import Chess.FEN
+import Chess.PGN
+
+deriving instance Eq PGN
+
+instance Arbitrary GameResult where arbitrary = elements [BlackWon, WhiteWon, Draw]
+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")
+ ]
+
+instance Arbitrary PGN
+ where
+ arbitrary = liftM9 PGN
+ sensibleString
+ sensibleString
+ sensibleString
+ sensibleString
+ sensibleString
+ sensibleString
+ arbitrary
+ (Just <$> arbitrary)
+ (liftM2 (:) arbitraryMove (listOf arbitraryMove))
+ where
+ liftM9 f m1 m2 m3 m4 m5 m6 m7 m8 m9 = do
+ x1 <- m1
+ x2 <- m2
+ x3 <- m3
+ x4 <- m4
+ x5 <- m5
+ x6 <- m6
+ x7 <- m7
+ x8 <- m8
+ x9 <- m9
+ return $ f x1 x2 x3 x4 x5 x6 x7 x8 x9
+
+ 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 '^\(\[\|$\)' \
@@ -17,8 +71,8 @@ import Test.QuickCheck
- on a set of PGN games, e.g. from http://theweekinchess.com/twic.
-}
-arbitraryMove :: Gen String
-arbitraryMove = frequency $ map (return <$>)
+probableArbitraryMove :: Gen String
+probableArbitraryMove = frequency $ map (return <$>)
[ (8, "a1=B")
, (2, "a1=B+")
, (16, "a1=N")
diff --git a/test/Test.hs b/test/Test.hs
new file mode 100644
index 0000000..1f0a02d
--- /dev/null
+++ b/test/Test.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE TemplateHaskell #-}
+-- vim: sw=2 ts=2 et ai:
+module Test where
+
+import Data.Attoparsec.ByteString.Char8
+import Data.ByteString.Char8 (pack)
+
+import Data.Either
+import Data.List
+
+import Control.Monad
+
+import Test.QuickCheck
+
+import Chess
+import Chess.FEN
+import Chess.PGN
+
+import ArbitraryMove
+
+prop_checkPGN :: PGN -> Bool
+prop_checkPGN 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"
+
+return []
+main = $forAllProperties (quickCheckWithResult (stdArgs {maxSuccess=10000}))
diff --git a/test/test_parser.hs b/test/test_parser.hs
deleted file mode 100644
index 397248f..0000000
--- a/test/test_parser.hs
+++ /dev/null
@@ -1,107 +0,0 @@
-{-# LANGUAGE StandaloneDeriving #-}
--- vim: sw=2 ts=2 et ai:
-import Data.Attoparsec.ByteString.Char8
-import Data.ByteString.Char8 (pack)
-
-import Data.Either
-import Data.List
-
-import Control.Monad
-
-import Test.QuickCheck
-
-import Chess
-import Chess.FEN
-import Chess.PGN
-
-import qualified ArbitraryMove as AM
-
-deriving instance Eq PGN
-
-instance Arbitrary GameResult where arbitrary = elements [BlackWon, WhiteWon, Draw]
-instance Arbitrary Board where arbitrary = return defaultBoard
-
-type Move = String
-
-arbitraryMove :: Gen Move
-arbitraryMove = frequency
- [ (2, AM.arbitraryMove)
- , (1, invalidMove)
- ]
- where
- invalidMove :: Gen Move
- invalidMove = oneof
- [ liftM2 (\r c -> [r,c]) (choose ('i', 'z')) (elements "09")
- ]
-
-instance Arbitrary PGN
- where
- arbitrary = liftM9 PGN
- sensibleString
- sensibleString
- sensibleString
- sensibleString
- sensibleString
- sensibleString
- arbitrary
- (Just <$> arbitrary)
- (liftM2 (:) arbitraryMove (listOf arbitraryMove))
- where
- liftM9 f m1 m2 m3 m4 m5 m6 m7 m8 m9 = do
- x1 <- m1
- x2 <- m2
- x3 <- m3
- x4 <- m4
- x5 <- m5
- x6 <- m6
- x7 <- m7
- x8 <- m8
- x9 <- m9
- return $ f x1 x2 x3 x4 x5 x6 x7 x8 x9
-
- sensibleString = listOf $ choose ('a', 'z')
-
- shrink pgn = [pgn {moves=ms} | ms <- shrink $ moves pgn]
-
-main = quickCheck (withMaxSuccess 10000 checkPGN)
- where
- checkPGN :: PGN -> Bool
- checkPGN 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"
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-17 07:45:15 +0000