fix(gs/xanthous): Fix numAliveNeighbors{,M} on the edge

numAliveNeighbors was doing bounds checks too aggressively, resulting in
always returning 8 for points on the edge, meaning walls weren't getting
properly created for those points, making edges of the map open to walk
through.

Change-Id: Iada6be46ce7cc77ce99a320b7310008898b89273
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3805
Reviewed-by: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI
This commit is contained in:
Griffin Smith 2021-11-06 13:20:26 -04:00 committed by grfn
parent eeafd0fa0e
commit b68414c66b
2 changed files with 70 additions and 11 deletions

View file

@ -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

View file

@ -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 $