Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: malcolmt/chess-tools
base: f4161d244c
...
head fork: malcolmt/chess-tools
compare: 6508e0a821
Checking mergeability… Don't worry, you can still create the pull request.
  • 3 commits
  • 8 files changed
  • 0 commit comments
  • 1 contributor
Commits on Oct 31, 2011
@malcolmt Build now completes with -Wall -Werror. b645584
@malcolmt Add HPC output files to .gitignore. c4c1b54
@malcolmt Bullet-proofing and testing coverage.
- Converted the various index to square and algebraic squares to use
  Maybe types and handle errors sensibly.

- Added tests for a few missing items and cleaned up some of the
  existing tests a bit.

- Ran HPC reports on the whole thing and, aside from a few unused
  Show instances and one thunk in some (intentionally) bad data,
  everything is executed by the test suite.
6508e0a
View
7 .gitignore
@@ -1,3 +1,8 @@
-html/
+.hpc/
dist/
+html/
+*.hi
+*.o
+*.tix
+Suite
View
3  src/ChessTools/Board.hs
@@ -39,6 +39,7 @@ module ChessTools.Board (
import Data.Array ((!))
import Data.List (groupBy, sort)
+import Data.Maybe (fromJust)
import ChessTools.Board.Internal
@@ -102,7 +103,7 @@ repIndexList s@(BoardSize h v _) = CL $ map head $ groupBy compFirst $ sort l
where l = [(d1 `biMinus` d2, (s1, s2)) |
(d1, s1) <- squares, (d2, s2) <- squares]
compFirst x y = fst x == fst y
- squares = zip (map (squareToIndex s) sqs) sqs
+ squares = zip (map (fromJust . squareToIndex s) sqs) sqs
sqs = [Square (x, y) | x <- [0 .. h - 1], y <- [0 .. v - 1]]
View
15 src/ChessTools/Board/Internal.hs
@@ -24,7 +24,7 @@ data BoardSize = BoardSize {
boardVertBuffer :: Int -- ^ Vertical buffer size for
-- jumping pieces.
}
- deriving (Show, Eq)
+ deriving (Show)
-- | The coordinates of a cell on the board.
--
@@ -80,20 +80,23 @@ newtype CoveringIndexList = CL [(LIndex, (Square, Square))]
-- | Convert a 'Square' to an index into a board array. The index is the same
-- for all board arrays associated with a given 'BoardSize'.
-squareToIndex :: BoardSize -> Square -> BIndex
+squareToIndex :: BoardSize -> Square -> Maybe BIndex
squareToIndex s (Square (x, y))
- | x < 0 || y < 0 || x >= h || y >= v = BI 0
- | otherwise = BI $ (y + vBuf) * rowLength s + leftBuf s + x
+ | x < 0 || y < 0 || x >= h || y >= v = Nothing
+ | otherwise = Just . BI $ (y + vBuf) * rowLength s + leftBuf s + x
where BoardSize h v vBuf = s
-- | Convert a board array index to a 'Square'. This is the inverse of
-- 'squareToIndex'.
-indexToSquare :: BoardSize -> BIndex -> Square
-indexToSquare s (BI idx) = Square (x, y)
+indexToSquare :: BoardSize -> BIndex -> Maybe Square
+indexToSquare s (BI idx)
+ | x < 0 || y < 0 || x >= h || y >= v = Nothing
+ | otherwise = Just $ Square (x, y)
where rl = rowLength s
idx' = idx - rl * boardVertBuffer s
(y, x') = idx' `divMod` rl
x = x' - leftBuf s
+ BoardSize h v _ = s
-- | The length of a single (virtual) row in the board array. This is wider
-- than the board row length due to the buffer space at each end of the row.
View
32 src/ChessTools/Board/Western.hs
@@ -4,6 +4,7 @@
module ChessTools.Board.Western (
algebraicToIndex
, indexToAlgebraic
+ , westernBoardSize
) where
@@ -15,31 +16,28 @@ import ChessTools.Board
westernBoardSize :: BoardSize
westernBoardSize = BoardSize 8 8 2
-coveringIndices :: CoveringIndexList
-coveringIndices = repIndexList westernBoardSize
+-- XXX: Not yet used; commented out to maintain warning-free build.
+-- coveringIndices :: CoveringIndexList
+-- coveringIndices = repIndexList westernBoardSize
-- | Converts a square name, such as /"e5"/ to an index into a board array.
-- Returns 'Nothing' if the provided string is invalid (too long or not a
-- reference to a legal square).
-algebraicToIndex :: [Char] -> Maybe BIndex
-algebraicToIndex cs
- | length cs /= 2 = Nothing
- | file < 0 || file > 7 = Nothing
- | rank < 0 || rank > 7 = Nothing
- | otherwise = Just . squareToIndex westernBoardSize $ Square (file, rank)
- where f:r:[] = cs
- file = ord f - ord 'a'
+algebraicToIndex :: String -> Maybe BIndex
+algebraicToIndex (f:r:[]) = squareToIndex westernBoardSize $ Square (file, rank)
+ where file = ord f - ord 'a'
rank = ord r - ord '1'
+algebraicToIndex _ = Nothing
+
+
-- | Converts an index into a board array back into an algebraic notation
-- square designation, such as "/e5/".
-
--- FIXME: How to handle errors? How to even detect errors? (I don't want
--- indexToSquare having to go through Maybe all the time, since it will be
--- called all over the place.)
-indexToAlgebraic :: BIndex -> Maybe [Char]
-indexToAlgebraic x = Just $ chr (f + ord 'a') : chr (r + ord '1') : []
- where Square (f, r) = indexToSquare westernBoardSize x
+indexToAlgebraic :: BIndex -> Maybe String
+indexToAlgebraic x = case sq of
+ Just (Square (f, r)) -> Just $ chr (f + ord 'a') : [chr (r + ord '1')]
+ _ -> Nothing
+ where sq = indexToSquare westernBoardSize x
-- | Determine if a move /from/ an index /to/ another index is legal on the
-- given 'Board'.
View
101 src/ChessTools/Test/Board.hs
@@ -2,20 +2,14 @@ module ChessTools.Test.Board
where
import Control.Applicative ((<$>), (<*>))
+import Control.Monad (join, liftM)
import Data.List (group, sort)
+import Data.Maybe (fromJust)
import Test.QuickCheck
import ChessTools.Board
import ChessTools.Board.Internal
-
-
-instance Arbitrary BoardSize where
- arbitrary = sized $ \n -> do
- let n' = n + 2
- dx <- choose (2, n')
- dy <- choose (2, n')
- vbuf <- choose (0, 4)
- return $ BoardSize dx dy vbuf
+import ChessTools.Test.Utils
-- | For some of the more complex tests (there's at least one function that is
@@ -23,33 +17,41 @@ instance Arbitrary BoardSize where
-- board sizes. An upper bound of 11 by 11 is arbitrarily used here.
smallBoardGen :: Gen BoardSize
smallBoardGen = sized $ \n ->
- resize (min n 11) arbitrary
+ resize (min n 11) boardSizeGen
+genBadSquare :: BoardSize -> Gen Square
+genBadSquare (BoardSize h v _) = oneof [badX, badY]
+ where badX = do
+ sx <- oneof [choose (-5, -1), choose (h, h + 5)]
+ sy <- choose (-5, v + 5)
+ return $ Square (sx, sy)
--- | Square coordinates depend upon the dimensions of the board that contains
--- them. Hence, this generator requires a seeding parameter: the board size.
-genSquare :: BoardSize -> Gen Square
-genSquare bs = do
- sx <- choose (0, boardHorizSize bs - 1)
- sy <- choose (0, boardVertSize bs - 1)
- return $ Square (sx, sy)
+ badY = do
+ sx <- choose (-5, h + 5)
+ sy <- oneof [choose (-5, -1), choose (v, v + 5)]
+ return $ Square (sx, sy)
genTwoSquares :: BoardSize -> Gen (Square, Square)
genTwoSquares bs = (,) <$> genSquare bs <*> genSquare bs
boardAndSquareGen :: Gen (BoardSize, Square)
boardAndSquareGen = do
- bs <- arbitrary :: Gen BoardSize
+ bs <- boardSizeGen
sq <- genSquare bs
return (bs, sq)
boardAndTwoSquareGen :: Gen (BoardSize, Square, Square)
boardAndTwoSquareGen = do
- bs <- arbitrary :: Gen BoardSize
+ bs <- boardSizeGen
s1 <- genSquare bs
s2 <- genSquare bs
return (bs, s1, s2)
+boardAndBadSquareGen :: Gen (BoardSize, Square)
+boardAndBadSquareGen = do
+ bs <- boardSizeGen
+ sq <- genBadSquare bs
+ return (bs, sq)
-- XXX: It's a little annoying that this is precisely how squareToIndex is
-- implemented, so it's not really verifying the result of that conversion by
@@ -57,23 +59,40 @@ boardAndTwoSquareGen = do
boardAndIndexGen :: Gen (BoardSize, BIndex)
boardAndIndexGen = do
- bs <- arbitrary :: Gen BoardSize
- Square (dx, dy) <- genSquare bs
- return (bs, BI ((dy + boardVertBuffer bs) * rowLength bs + dx + leftBuf bs))
+ bs <- boardSizeGen
+ idx <- genIndex bs
+ return (bs, idx)
+boardAndBadIndexGen :: Gen (BoardSize, BIndex)
+boardAndBadIndexGen = do
+ bs <- boardSizeGen
+ idx <- genBadIndex bs
+ return (bs, idx)
-- The squareToIndex and indexToSquare functions should be inverses of each
-- other. That is:
-- index -> square -> index should be the identity
-- square -> index -> square should be the identity
+prop_indexToSquareInverse :: Property
prop_indexToSquareInverse = forAll boardAndIndexGen $ \(b, idx) ->
- squareToIndex b (indexToSquare b idx) == idx
+ join (squareToIndex b `liftM` indexToSquare b idx) == Just idx
+prop_squareToIndexInverse :: Property
prop_squareToIndexInverse = forAll boardAndSquareGen $ \(b, sq) ->
- indexToSquare b (squareToIndex b sq) == sq
+ join (indexToSquare b `liftM` squareToIndex b sq) == Just sq
+
+-- squareToIndex and indexToSquare should handle bad input appropriately.
+prop_errorSquareToIndex :: Property
+prop_errorSquareToIndex = forAll boardAndBadSquareGen $ \(b, sq) ->
+ squareToIndex b sq == Nothing
+
+prop_errorIndexToSquare :: Property
+prop_errorIndexToSquare = forAll boardAndBadIndexGen $ \(b, idx) ->
+ indexToSquare b idx == Nothing
-- As squares move from lower left ("a1" in western chess) to upper right (h8),
-- the index into the lookup table should increase.
+prop_indexIncreasesWithSquare :: Property
prop_indexIncreasesWithSquare = forAll boardAndTwoSquareGen $ \(b, s1, s2) ->
let idx1 = squareToIndex b s1
idx2 = squareToIndex b s2
@@ -81,14 +100,16 @@ prop_indexIncreasesWithSquare = forAll boardAndTwoSquareGen $ \(b, s1, s2) ->
-- The board array size should be computed correctly (this is the
-- representation of the board of pieces, not a lookup array, which is smaller).
-prop_boardArraySize bs = boardArraySize bs == expected
- where BoardSize h v vbuf = bs
- expected = h * v + v * (h - 1) + 2 * vbuf * (2 * h - 1)
-
+prop_boardArraySize :: Property
+prop_boardArraySize = forAll boardSizeGen $ \b ->
+ let BoardSize h v vbuf = b
+ expected = h * v + v * (h - 1) + 2 * vbuf * (2 * h - 1)
+ in boardArraySize b == expected
-- The list returned from repIndexList should actually be representative. That
-- is, it should contain as many values as the size of the lookup array and all
-- of the distance values in it should be unique.
+prop_repIndexListRepresents :: Property
prop_repIndexListRepresents = forAll smallBoardGen $ \bs ->
let cl@(CL xs) = repIndexList bs
(l, u) = lookupBounds cl
@@ -101,10 +122,15 @@ prop_repIndexListRepresents = forAll smallBoardGen $ \bs ->
-- (one square and one not). This avoids having to continually regenerate the
-- representative index list.
+board1, board2 :: BoardSize
board1 = BoardSize 8 8 2
board2 = BoardSize 8 9 2
+
+repList1, repList2 :: CoveringIndexList
repList1 = repIndexList board1
repList2 = repIndexList board2
+
+fTable1, fTable2, rTable1, rTable2, sTable1, sTable2 :: LookupTable
fTable1 = fileTable repList1
fTable2 = fileTable repList2
rTable1 = rankTable repList1
@@ -112,19 +138,34 @@ rTable2 = rankTable repList2
sTable1 = squareTable repList1
sTable2 = squareTable repList2
+type SquareCmpFunc = Square -> Square -> Int
+
+fileCheckFunc, rankCheckFunc, squareCheckFunc :: SquareCmpFunc
fileCheckFunc (Square s1) (Square s2) = abs $ fst s1 - fst s2
rankCheckFunc (Square s1) (Square s2) = abs $ snd s1 - snd s2
squareCheckFunc sq1 sq2 = max (fileCheckFunc sq1 sq2) (rankCheckFunc sq1 sq2)
+checkLookup :: LookupTable -> SquareCmpFunc -> BoardSize -> Property
checkLookup lt cmp b = forAll (genTwoSquares b) $ \(sq1, sq2) ->
- let idx1 = squareToIndex b sq1
- idx2 = squareToIndex b sq2
+ let idx1 = fromJust $ squareToIndex b sq1
+ idx2 = fromJust $ squareToIndex b sq2
in fetch lt idx1 idx2 == cmp sq1 sq2
+prop_checkFileDistance1 :: Property
prop_checkFileDistance1 = checkLookup fTable1 fileCheckFunc board1
+
+prop_checkFileDistance2 :: Property
prop_checkFileDistance2 = checkLookup fTable2 fileCheckFunc board2
+
+prop_checkRankDistance1 :: Property
prop_checkRankDistance1 = checkLookup rTable1 rankCheckFunc board1
+
+prop_checkRankDistance2 :: Property
prop_checkRankDistance2 = checkLookup rTable2 rankCheckFunc board2
+
+prop_checkSquareDistance1 :: Property
prop_checkSquareDistance1 = checkLookup sTable1 squareCheckFunc board1
+
+prop_checkSquareDistance2 :: Property
prop_checkSquareDistance2 = checkLookup sTable2 squareCheckFunc board2
View
8 src/ChessTools/Test/Suite.hs
@@ -6,19 +6,23 @@
- going to be more appropriate.
-}
-import Test.Framework (defaultMain, testGroup)
+import Test.Framework (defaultMain, testGroup, Test)
import Test.Framework.Providers.QuickCheck2 (testProperty)
import ChessTools.Test.Board
import ChessTools.Test.WesternBoard
+main :: IO ()
main = defaultMain tests
+tests :: [Test]
tests = [
testGroup "Board arrays" [
testProperty "index to square" prop_indexToSquareInverse
, testProperty "square to index" prop_squareToIndexInverse
+ , testProperty "bad square to index" prop_errorSquareToIndex
+ , testProperty "bad index to square" prop_errorIndexToSquare
, testProperty "indices increase" prop_indexIncreasesWithSquare
, testProperty "array size" prop_boardArraySize
]
@@ -34,6 +38,8 @@ tests = [
, testGroup "Western notation" [
testProperty "good algebraic squares" prop_goodAlgebraicSquares
, testProperty "bad algebraic squares" prop_badAlgebraicSquares
+ , testProperty "index to algebraic" prop_indexToAlgebraic
+ , testProperty "bad index to algebraic" prop_errorIndexToAlgebraic
]
]
View
59 src/ChessTools/Test/Utils.hs
@@ -0,0 +1,59 @@
+{- Some QuickCheck generators and other utility functions used in a few test
+ - modules.
+ -}
+
+module ChessTools.Test.Utils (
+ boardSizeGen
+ , genIndex
+ , genBadIndex
+ , genSquare
+) where
+
+import Test.QuickCheck
+
+import ChessTools.Board
+import ChessTools.Board.Internal
+
+
+-- This could be an Arbitrary instance, but it would be an orphan. We don't
+-- want to put the instance in ChessTools.Board.Internal to avoid unnecessary
+-- QuickCheck dependencies, so prefer to use a direct Gen function here.
+boardSizeGen :: Gen BoardSize
+boardSizeGen = sized $ \n -> do
+ let n' = n + 2
+ dx <- choose (2, n')
+ dy <- choose (2, n')
+ vbuf <- choose (0, 4)
+ return $ BoardSize dx dy vbuf
+
+genIndex :: BoardSize -> Gen BIndex
+genIndex bs = do
+ Square (dx, dy) <- genSquare bs
+ return $ BI ((dy + boardVertBuffer bs) * rowLength bs + dx + leftBuf bs)
+
+genBadIndex :: BoardSize -> Gen BIndex
+genBadIndex (BoardSize h v vbuf)
+ | vbuf == 0 = leftBuffer
+ | otherwise = oneof [leftBuffer, above, below]
+ where rl = 2 * h - 1
+ leftBuffer = do
+ x <- choose (0, v - 1)
+ y <- choose (0, h `div` 2 - 1)
+ return $ BI ((vbuf + x) * rl + y)
+
+ above = do
+ x <- choose (0, vbuf - 1)
+ y <- choose (0, rl - 1)
+ return $ BI ((vbuf + v + x) * rl + y)
+
+ below = do
+ x <- choose (0, vbuf - 1)
+ y <- choose (0, rl - 1)
+ return $ BI (x * rl + y)
+
+genSquare :: BoardSize -> Gen Square
+genSquare bs = do
+ sx <- choose (0, boardHorizSize bs - 1)
+ sy <- choose (0, boardVertSize bs - 1)
+ return $ Square (sx, sy)
+
View
49 src/ChessTools/Test/WesternBoard.hs
@@ -2,22 +2,23 @@ module ChessTools.Test.WesternBoard
where
import Data.Char (ord, chr)
+import Data.Maybe (fromJust)
import Test.QuickCheck
import ChessTools.Board.Western
+import ChessTools.Test.Utils
-pairToCoords :: Int -> Int -> [Char]
-pairToCoords f r = chr (f + ord 'a') : chr (r + ord '1') : []
+pairToCoords :: Int -> Int -> String
+pairToCoords f r = chr (f + ord 'a') : [chr (r + ord '1')]
-validAlgebraicSquaresGen :: Gen [Char]
-validAlgebraicSquaresGen = do
+algebraicSquaresGen :: Gen String
+algebraicSquaresGen = do
file <- choose (0, 7)
rank <- choose (0, 7)
return $ pairToCoords file rank
-invalidAlgebraicSquaresGen :: Gen [Char]
-invalidAlgebraicSquaresGen =
- oneof [badFile, badRank, longName]
+badAlgebraicSquaresGen :: Gen String
+badAlgebraicSquaresGen = oneof [badFile, badRank, nameTooLong]
where badFile = do
file <- oneof [choose (-10, -1), choose (8, 12)]
rank <- choose (-3, 10)
@@ -28,19 +29,29 @@ invalidAlgebraicSquaresGen =
rank <- oneof [choose (-10, -1), choose (8, 12)]
return $ pairToCoords file rank
- longName = do
- x <- choose ('a', 'z')
- c <- validAlgebraicSquaresGen
- return $ c ++ [x]
+ nameTooLong = do
+ c <- algebraicSquaresGen
+ return $ c ++ "X"
-prop_goodAlgebraicSquares = forAll validAlgebraicSquaresGen $ \s ->
- case algebraicToIndex s of
- Nothing -> False
- _ -> True
+prop_goodAlgebraicSquares :: Property
+prop_goodAlgebraicSquares = forAll algebraicSquaresGen $ \s ->
+ algebraicToIndex s /= Nothing
-prop_badAlgebraicSquares = forAll invalidAlgebraicSquaresGen $ \s ->
- case algebraicToIndex s of
- Nothing -> True
- _ -> False
+prop_badAlgebraicSquares :: Property
+prop_badAlgebraicSquares = forAll badAlgebraicSquaresGen $ \s ->
+ algebraicToIndex s == Nothing
+
+prop_indexToAlgebraic :: Property
+prop_indexToAlgebraic = forAll (genIndex westernBoardSize) $ \idx ->
+ let s = indexToAlgebraic idx
+ (f:r:[]) = fromJust s
+ in s /= Nothing &&
+ length (fromJust s) == 2 &&
+ 'a' <= f && f <= 'h' &&
+ '1' <= r && r <= '8'
+
+prop_errorIndexToAlgebraic :: Property
+prop_errorIndexToAlgebraic = forAll (genBadIndex westernBoardSize) $ \idx ->
+ indexToAlgebraic idx == Nothing

No commit comments for this range

Something went wrong with that request. Please try again.