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
|
{-# LANGUAGE TemplateHaskell, ParallelListComp #-}
-- vim: sw=2 ts=2 et ai:
module Test where
import Data.Array
import Data.Attoparsec.ByteString.Char8
import Data.ByteString.Char8 (pack)
import Data.Either
import Data.List
import Data.Maybe
import Control.Monad
import Test.QuickCheck
import Chess
import Chess.FEN
import Chess.PGN
import ArbitraryMove
atAnyState :: (Board -> Bool) -> PGN -> Bool
atAnyState = atAnyTwoStates . const
atAnyTwoStates :: (Board -> Board -> Bool) -> PGN -> Bool
atAnyTwoStates ok pgn =
let moveList = seqList [moveSAN m | m <- moves pgn] $ Right defaultBoard in
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 :: 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"
-- 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 -> Bool
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 -> Bool
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 -> Bool
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 -> Bool
prop_not_in_check_twice = atAnyTwoStates (\b1 b2 ->
not (check Black b1 && check Black b2) &&
not (check White b1 && check White b2))
return []
main = $forAllProperties (quickCheckWithResult (stdArgs {maxSuccess=10000}))
|
