diff options
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs | 36 | ||||
| -rw-r--r-- | users/grfn/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs | 45 |
2 files changed, 70 insertions, 11 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs b/users/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs index c64377817939..0008eb965c42 100644 --- a/users/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs +++ b/users/grfn/xanthous/src/Xanthous/Generators/Level/Util.hs @@ -52,13 +52,18 @@ initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s) initializeEmpty dims = lift $ newArray (0, V2 (dims ^. width) (dims ^. height)) False +-- | Returns the number of neighbors of the given point in the given array that +-- are True. +-- +-- Behavior if point is out-of-bounds for the array is undefined, but will not +-- error numAliveNeighborsM :: forall a i m . (MArray a Bool m, Ix i, Integral i) => a (V2 i) Bool -> V2 i -> m Word -numAliveNeighborsM cells (V2 x y) = do +numAliveNeighborsM cells pt@(V2 x y) = do cellBounds <- getBounds cells getSum <$> foldlMapM' (fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds) @@ -66,24 +71,32 @@ numAliveNeighborsM cells (V2 x y) = do where boundedGet :: (V2 i, V2 i) -> (Int, Int) -> m Bool + boundedGet bnds _ + | not (inRange bnds pt) + = pure True boundedGet (V2 minX minY, V2 maxX maxY) (i, j) - | x <= minX - || y <= minY - || x >= maxX - || y >= maxY + | (x <= minX && i < 0) + || (y <= minY && j < 0) + || (x >= maxX && i > 0) + || (y >= maxY && j > 0) = pure True | otherwise = let nx = fromIntegral $ fromIntegral x + i ny = fromIntegral $ fromIntegral y + j in readArray cells $ V2 nx ny +-- | Returns the number of neighbors of the given point in the given array that +-- are True. +-- +-- Behavior if point is out-of-bounds for the array is undefined, but will not +-- error numAliveNeighbors :: forall a i . (IArray a Bool, Ix i, Integral i) => a (V2 i) Bool -> V2 i -> Word -numAliveNeighbors cells (V2 x y) = +numAliveNeighbors cells pt@(V2 x y) = let cellBounds = bounds cells in getSum $ foldMap (Sum . fromIntegral . fromEnum . boundedGet cellBounds) @@ -91,11 +104,14 @@ numAliveNeighbors cells (V2 x y) = where boundedGet :: (V2 i, V2 i) -> (Int, Int) -> Bool + boundedGet bnds _ + | not (inRange bnds pt) + = True boundedGet (V2 minX minY, V2 maxX maxY) (i, j) - | x <= minX - || y <= minY - || x >= maxX - || y >= maxY + | (x <= minX && i < 0) + || (y <= minY && j < 0) + || (x >= maxX && i > 0) + || (y >= maxY && j > 0) = True | otherwise = let nx = fromIntegral $ fromIntegral x + i diff --git a/users/grfn/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs b/users/grfn/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs index 2d70a55e88bc..b53c657f7559 100644 --- a/users/grfn/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs +++ b/users/grfn/xanthous/test/Xanthous/Generators/Level/UtilSpec.hs @@ -6,7 +6,7 @@ import Test.Prelude import System.Random (mkStdGen) import Control.Monad.Random (runRandT) import Data.Array.ST (STUArray, runSTUArray, thaw) -import Data.Array.IArray (bounds) +import Data.Array.IArray (bounds, array) import Data.Array.MArray (newArray, readArray, writeArray) import Data.Array (Array, range, listArray, Ix) import Control.Monad.ST (ST, runST) @@ -15,6 +15,7 @@ import Linear.V2 -------------------------------------------------------------------------------- import Xanthous.Util import Xanthous.Data (width, height) +-------------------------------------------------------------------------------- import Xanthous.Generators.Level.Util -------------------------------------------------------------------------------- @@ -57,6 +58,30 @@ test = testGroup "Xanthous.Generators.Util" numAliveNeighborsM mArr loc res = runST act in counterexample (show res) $ between 0 8 res + , testCase "on the outer x edge" $ + let act :: forall s. ST s Word + act = do + cells <- thaw @_ @_ @_ @(STUArray s) $ array @Array @Bool @(V2 Word) + (V2 0 0, V2 2 2) + [ (V2 0 0, True), (V2 1 0, True), (V2 2 0, True) + , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True) + , (V2 0 2, True), (V2 1 2, True), (V2 2 2, True) + ] + numAliveNeighborsM cells (V2 0 1) + res = runST act + in res @?= 7 + , testCase "on the outer y edge" $ + let act :: forall s. ST s Word + act = do + cells <- thaw @_ @_ @_ @(STUArray s) $ array @Array @Bool @(V2 Word) + (V2 0 0, V2 2 2) + [ (V2 0 0, True), (V2 1 0, True), (V2 2 0, True) + , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True) + , (V2 0 2, True), (V2 1 2, True), (V2 2 2, True) + ] + numAliveNeighborsM cells (V2 1 0) + res = runST act + in res @?= 6 ] , testGroup "numAliveNeighbors" [ testProperty "is equivalient to runST . numAliveNeighborsM . thaw" $ @@ -68,6 +93,24 @@ test = testGroup "Xanthous.Generators.Util" numAliveNeighborsM mArr loc res = runST act in numAliveNeighbors arr loc === res + , testCase "on the outer x edge" $ + let cells = + array @Array @Bool @(V2 Word) + (V2 0 0, V2 2 2) + [ (V2 0 0, True), (V2 1 0, True), (V2 2 0, True) + , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True) + , (V2 0 2, True), (V2 1 2, True), (V2 2 2, True) + ] + in numAliveNeighbors cells (V2 0 1) @?= 7 + , testCase "on the outer y edge" $ + let cells = + array @Array @Bool @(V2 Word) + (V2 0 0, V2 2 2) + [ (V2 0 0, True), (V2 1 0, True), (V2 2 0, True) + , (V2 0 1, False), (V2 1 1, False), (V2 2 1, True) + , (V2 0 2, True), (V2 1 2, True), (V2 2 2, True) + ] + in numAliveNeighbors cells (V2 1 0) @?= 6 ] , testGroup "cloneMArray" [ testCase "clones the array" $ runST $ |