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
|
{-# 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
deriving instance Eq PGN
instance Arbitrary GameResult where arbitrary = elements [BlackWon, WhiteWon, Draw]
instance Arbitrary Board where arbitrary = return defaultBoard
arbitraryMove = return "e4"
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')
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"
|
