1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
{-# LANGUAGE TemplateHaskell, ParallelListComp #-}
-- vim: sw=2 ts=2 et ai:
module Test where
import Control.Monad
import Data.Array
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 System.IO
import System.Random
import Test.QuickCheck
import Test.QuickCheck.Random
import Chess
import Chess.FEN
import Chess.PGN
import ArbitraryMove
atAnyState :: (Board -> Bool) -> PGN -> Property
atAnyState = atAnyTwoStates . const
atAnyTwoStates :: (Board -> Board -> Bool) -> PGN -> Property
atAnyTwoStates ok pgn =
let moveList = seqList [moveSAN m | m <- moves pgn] $ Right defaultBoard in
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]
seqList (f:fs) (Right io) = f io:seqList fs (f io)
seqList _ (Left _) = []
seqList [] _ = []
prop_checkPGN :: Property
prop_checkPGN = withMaxSuccess 1000 test
where
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
(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"
-- From Chess.hs, with adaptations
pieceCoords :: Maybe Color -> Maybe PieceType -> Board -> [((Int,Int),Piece)]
pieceCoords clr piece brd = [(i,pc) | (i,Just pc) <- assocs $ board brd, match pc]
where
match :: Piece -> Bool
match (Piece clr' piece') =
(isJust clr && clr' == fromJust clr || isNothing clr) &&
(isJust piece && piece' == fromJust piece || isNothing piece)
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 -> 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 -> 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 -> 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 -> Property
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)
where
notMoved :: Color -> Board -> Board -> Bool
notMoved c = (\b a -> null (a \\ b)) `on` pieceCoords (Just c) Nothing
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
|
