halma 0.1.0.0 → 0.1.0.1
raw patch · 3 files changed
+153/−2 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- halma.cabal +9/−2
- test/Game/Halma/Board/Tests.hs +137/−0
- test/Game/Halma/Rules/Tests.hs +7/−0
halma.cabal view
@@ -1,5 +1,5 @@ name: halma-version: 0.1.0.0+version: 0.1.0.1 synopsis: Library implementing Halma rules description: Rules and `diagrams`-based renderer for the board game Halma on a hexagonal grid. homepage: https://github.com/timjb/halma@@ -12,6 +12,11 @@ build-type: Simple cabal-version: >= 1.10 +source-repository head+ type: git+ location: https://github.com/timjb/halma.git++ library ghc-options: -Wall exposed-modules: Game.Halma.Board,@@ -30,6 +35,8 @@ Hs-source-dirs: test type: exitcode-stdio-1.0 main-is: Main.hs+ other-modules: Game.Halma.Board.Tests,+ Game.Halma.Rules.Tests default-language: Haskell2010 Build-depends: halma, grid,@@ -42,7 +49,7 @@ test-framework-quickcheck2 >= 0.3.0 && < 0.4 Executable halma- Ghc-options: -threaded -O2 -Wall+ Ghc-options: -threaded -Wall build-depends: halma, base >= 4.7 && < 5, diagrams-gtk >= 1.0.1.3 && < 1.1,
+ test/Game/Halma/Board/Tests.hs view
@@ -0,0 +1,137 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}++module Game.Halma.Board.Tests (tests) where++import Test.HUnit hiding (Test)+import Test.QuickCheck hiding (Result)+import Test.Framework+import Test.Framework.Providers.HUnit (testCase)+import Test.Framework.Providers.QuickCheck2 (testProperty)++import Data.List (permutations, sortBy)+import Data.Maybe (isJust, fromJust)+import Data.Function (on)+import Control.Monad (forM_)+import qualified Data.Map.Strict as M++import Math.Geometry.Grid+import qualified Math.Geometry.Grid.HexagonalInternal as HI+import Game.Halma.Board++testRowsInDirection :: Assertion+testRowsInDirection =+ forM_ [minBound..maxBound] $ \halmaDir -> do+ let fieldsAtRow i = filter ((== i) . rowsInDirection halmaDir) (indices SmallGrid)+ expected = let xs = [0,1,2,3,4,13,12,11,10] in xs ++ [9] ++ reverse xs+ expected @=? map (length . fieldsAtRow) [-9..9]+ 8 @=? rowsInDirection halmaDir (corner SmallGrid halmaDir)+ (-8) @=? rowsInDirection halmaDir (corner SmallGrid (oppositeDirection halmaDir))++-- | Cutoff equality comparison+(@=?*) :: (Eq a, Show a) => [a] -> [a] -> Assertion+expected @=?* actual = expected @=? take (length expected) actual++testDistancesFromCenter :: Assertion+testDistancesFromCenter = do+ [1,6,12,18,24,24,18,12,6,0,0,0] @=?* actual SmallGrid+ [1,6,12,18,24,30,30,24,18,12,6,0,0,0] @=?* actual LargeGrid+ where center = (0, 0)+ distCenter hg = distance hg center+ fieldsAtDistance hg d = filter ((== d) . distCenter hg) (indices hg)+ actual hg = map (length . fieldsAtDistance hg) [0,1..]++testBoundaryLength :: Assertion+testBoundaryLength = do+ 48 @=? length (boundary SmallGrid)+ 60 @=? length (boundary LargeGrid)++testDirectionTo :: Assertion+testDirectionTo = do+ let c = corner SmallGrid+ [HI.Northeast] @=? directionTo SmallGrid (c South) (c Southeast)+ [HI.Northeast] @=? directionTo SmallGrid (c South) (c Northeast)+ assertOneOf+ (directionTo SmallGrid (c South) (c North))+ (permutations [HI.Northeast, HI.Northwest])++assertOneOf :: (Eq a, Show a) => a -> [a] -> Assertion+assertOneOf actual validResults = assertBool msg (actual `elem` validResults)+ where msg = "Expected '" ++ show actual ++ "' to be one of '" ++ show validResults ++ "'"++numbersCorrect :: HalmaGrid size -> [Maybe Team] -> Bool+numbersCorrect halmaGrid = go 15 15 (numberOfFields halmaGrid - 2*15)+ where go :: Int -> Int -> Int -> [Maybe Team] -> Bool+ go 0 0 0 [] = True+ go !n !s !e (Just North : rs) = go (n-1) s e rs+ go !n !s !e (Just South : rs) = go n (s-1) e rs+ go !n !s !e (Nothing : rs) = go n s (e-1) rs+ go _ _ _ _ = False++testInitialBoard :: Assertion+testInitialBoard = ass SmallGrid >> ass LargeGrid+ where+ ass hg = assertBool "Expected 15 pieces of team north and south" $ numbersCorrect hg (pieces hg)+ pieces hg = map (\p -> lookupHalmaBoard p (initialBoard hg twoPlayers)) (indices hg)+ twoPlayers :: Team -> Bool+ twoPlayers North = True+ twoPlayers South = True+ twoPlayers _ = False++arbitraryPerm :: [a] -> Gen [a]+arbitraryPerm xs =+ fmap (map fst . sortBy (compare `on` snd) . zip xs)+ (vectorOf (length xs) arbitrary :: Gen [Double])++genBoard :: HalmaGrid size -> Gen (HalmaBoard size)+genBoard halmaGrid = do+ pieces <- arbitraryPerm (indices halmaGrid)+ let (northTeam, restPieces) = splitAt 15 pieces+ southTeam = take 15 restPieces+ return $ fromJust $ fromMap halmaGrid $ M.fromList $+ map (flip (,) North) northTeam +++ map (flip (,) South) southTeam++instance Arbitrary (HalmaBoard 'S) where+ arbitrary = genBoard SmallGrid++instance Arbitrary (HalmaBoard 'L) where+ arbitrary = genBoard LargeGrid++genHalmaGridPos :: HalmaGrid size -> Gen (Int, Int)+genHalmaGridPos halmaGrid = elements (indices halmaGrid)++prop_fromMap :: HalmaBoard size -> Bool+prop_fromMap halmaBoard = fromMap (getGrid halmaBoard) (toMap halmaBoard) == Just halmaBoard++prop_moveNumbersInvariant :: HalmaBoard size -> Gen Bool+prop_moveNumbersInvariant halmaBoard = do+ let halmaGrid = getGrid halmaBoard+ startPos <- genHalmaGridPos halmaGrid+ endPos <- genHalmaGridPos halmaGrid+ case movePiece startPos endPos halmaBoard of+ Left _err ->+ -- may only fail when there is no piece on the start position or a piece+ -- on the end position+ return $ lookupHalmaBoard startPos halmaBoard == Nothing || isJust (lookupHalmaBoard endPos halmaBoard)+ Right halmaBoard' -> do+ let pieces = map (\p -> lookupHalmaBoard p halmaBoard') (indices halmaGrid)+ return $ lookupHalmaBoard endPos halmaBoard' == lookupHalmaBoard startPos halmaBoard &&+ lookupHalmaBoard endPos halmaBoard == lookupHalmaBoard startPos halmaBoard' &&+ numbersCorrect halmaGrid pieces+++tests :: Test+tests = testGroup "Game.Halma.Board.Tests"+ [ testCase "testRowsInDirection" testRowsInDirection+ , testCase "testDistancesFromCenter" testDistancesFromCenter+ , testCase "testBoundaryLength" testBoundaryLength+ , testCase "testDirectionTo" testDirectionTo+ , testCase "testInitialBoard" testInitialBoard+ , testProperty "prop_fromMap(S)" (prop_fromMap :: HalmaBoard 'S -> Bool)+ , testProperty "prop_fromMap(L)" (prop_fromMap :: HalmaBoard 'L -> Bool)+ , testProperty "prop_moveNumbersInvariant(S)" (prop_moveNumbersInvariant :: HalmaBoard 'S -> Gen Bool)+ , testProperty "prop_moveNumbersInvariant(L)" (prop_moveNumbersInvariant :: HalmaBoard 'L -> Gen Bool)+ ]
+ test/Game/Halma/Rules/Tests.hs view
@@ -0,0 +1,7 @@+module Game.Halma.Rules.Tests (tests) where++import Test.Framework++-- TODO+tests :: Test+tests = testGroup "Game.Halma.Rules.Tests" []