diff options
| -rw-r--r-- | src/Xanthous/Data.hs | 41 | ||||
| -rw-r--r-- | src/Xanthous/Generators/LevelContents.hs | 40 | ||||
| -rw-r--r-- | test/Xanthous/DataSpec.hs | 36 |
3 files changed, 91 insertions, 26 deletions
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs index 5e451695825f..1874b45e9047 100644 --- a/src/Xanthous/Data.hs +++ b/src/Xanthous/Data.hs @@ -79,6 +79,8 @@ module Xanthous.Data , edges , neighborDirections , neighborPositions + , arrayNeighbors + , rotations -- * , Hitpoints(..) @@ -88,11 +90,13 @@ import Xanthous.Prelude hiding (Left, Down, Right, (.=)) -------------------------------------------------------------------------------- import Linear.V2 hiding (_x, _y) import qualified Linear.V2 as L +import Linear.V4 hiding (_x, _y) import Test.QuickCheck (Arbitrary, CoArbitrary, Function) import Test.QuickCheck.Arbitrary.Generic import Data.Group import Brick (Location(Location), Edges(..)) import Data.Monoid (Product(..), Sum(..)) +import Data.Array.IArray import Data.Aeson.Generic.DerivingVia import Data.Aeson ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject) @@ -280,7 +284,7 @@ instance Opposite Direction where opposite DownRight = UpLeft opposite Here = Here -move :: Direction -> Position -> Position +move :: Num a => Direction -> Position' a -> Position' a move Up = y -~ 1 move Down = y +~ 1 move Left = x -~ 1 @@ -375,7 +379,8 @@ data Neighbors a = Neighbors , _bottomRight :: a } deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) - deriving anyclass (NFData) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary (Neighbors a) makeFieldsNoPrefix ''Neighbors instance Applicative Neighbors where @@ -420,9 +425,39 @@ neighborDirections = Neighbors , _bottomRight = DownRight } -neighborPositions :: Position -> Neighbors Position +neighborPositions :: Num a => Position' a -> Neighbors (Position' a) neighborPositions pos = (`move` pos) <$> neighborDirections +arrayNeighbors + :: (IArray a e, Ix i, Num i) + => a (i, i) e + -> (i, i) + -> Neighbors (Maybe e) +arrayNeighbors arr center = arrLookup <$> neighborPositions (_Position # center) + where + arrLookup (view _Position -> pos) + | inRange (bounds arr) pos = Just $ arr ! pos + | otherwise = Nothing + +-- | Returns a list of all 4 90-degree rotations of the given neighbors +rotations :: Neighbors a -> V4 (Neighbors a) +rotations orig@(Neighbors tl t tr l r bl b br) = V4 + orig -- tl t tr + -- l r + -- bl b br + + (Neighbors bl l tl b t br r tr) -- bl l tl + -- b t + -- br r tr + + (Neighbors br b bl r l tr t tl) -- br b bl + -- r l + -- tr t tl + + (Neighbors tr r br t b tl l bl) -- tr r br + -- t b + -- tl l bl + -------------------------------------------------------------------------------- newtype Per a b = Rate Double diff --git a/src/Xanthous/Generators/LevelContents.hs b/src/Xanthous/Generators/LevelContents.hs index 748afa96da72..117860405ac3 100644 --- a/src/Xanthous/Generators/LevelContents.hs +++ b/src/Xanthous/Generators/LevelContents.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} -------------------------------------------------------------------------------- module Xanthous.Generators.LevelContents ( chooseCharacterPosition @@ -8,15 +9,19 @@ module Xanthous.Generators.LevelContents , tutorialMessage ) where -------------------------------------------------------------------------------- -import Xanthous.Prelude +import Xanthous.Prelude hiding (any, toList) -------------------------------------------------------------------------------- import Control.Monad.Random import Data.Array.IArray (amap, bounds, rangeSize, (!)) import qualified Data.Array.IArray as Arr +import Data.Foldable (any, toList) -------------------------------------------------------------------------------- import Xanthous.Generators.Util import Xanthous.Random -import Xanthous.Data (Position, _Position, positionFromPair) +import Xanthous.Data ( Position, _Position, positionFromPair + , rotations, arrayNeighbors, Neighbors(..) + , neighborPositions + ) import Xanthous.Data.EntityMap (EntityMap, _EntityMap) import Xanthous.Entities.Raws (rawsWithType, RawType) import qualified Xanthous.Entities.Item as Item @@ -44,22 +49,31 @@ randomDoors :: MonadRandom m => Cells -> m (EntityMap Door) randomDoors cells = do doorRatio <- getRandomR subsetRange let numDoors = floor $ doorRatio * fromIntegral (length candidateCells) - doorPositions = positionFromPair <$> take numDoors candidateCells + doorPositions = + removeAdjacent . fmap positionFromPair . take numDoors $ candidateCells doors = zip doorPositions $ repeat unlockedDoor pure $ _EntityMap # doors where + removeAdjacent = + foldr (\pos acc -> + if pos `elem` (acc >>= toList . neighborPositions) + then acc + else pos : acc + ) [] candidateCells = filter doorable $ Arr.indices cells subsetRange = (0.8 :: Double, 1.0) - doorable (x, y) = - not (fromMaybe True $ cells ^? ix (x, y)) - && - ( fromMaybe True $ cells ^? ix (x - 1, y) -- left - , fromMaybe True $ cells ^? ix (x, y - 1) -- top - , fromMaybe True $ cells ^? ix (x + 1, y) -- right - , fromMaybe True $ cells ^? ix (x, y + 1) -- bottom - ) `elem` [ (True, False, True, False) - , (False, True, False, True) - ] + doorable pos = + not (fromMaybe True $ cells ^? ix pos) + && any (teeish . fmap (fromMaybe True)) + (rotations $ arrayNeighbors cells pos) + -- only generate doors at the *ends* of hallways, eg (where O is walkable, + -- X is a wall, and D is a door): + -- + -- O O O + -- X D X + -- O + teeish (fmap not -> (Neighbors tl t tr l r _ b _ )) = + and [tl, t, tr, b] && (and . fmap not) [l, r] randomCreatures :: MonadRandom m => Cells -> m (EntityMap Creature) randomCreatures = randomEntities Creature.newWithType (0.0007, 0.003) diff --git a/test/Xanthous/DataSpec.hs b/test/Xanthous/DataSpec.hs index a2fcdbba15e0..91dc6cea1ba5 100644 --- a/test/Xanthous/DataSpec.hs +++ b/test/Xanthous/DataSpec.hs @@ -1,9 +1,11 @@ -------------------------------------------------------------------------------- module Xanthous.DataSpec (main, test) where -------------------------------------------------------------------------------- -import Test.Prelude hiding (Right, Left, Down) -import Xanthous.Data +import Test.Prelude hiding (Right, Left, Down, toList, all) import Data.Group +import Data.Foldable (toList, all) +-------------------------------------------------------------------------------- +import Xanthous.Data -------------------------------------------------------------------------------- main :: IO () @@ -44,14 +46,14 @@ test = testGroup "Xanthous.Data" , testProperty "asPosition isUnit" $ \dir -> dir /= Here ==> isUnit (asPosition dir) , testGroup "Move" - [ testCase "Up" $ move Up mempty @?= Position 0 (-1) - , testCase "Down" $ move Down mempty @?= Position 0 1 - , testCase "Left" $ move Left mempty @?= Position (-1) 0 - , testCase "Right" $ move Right mempty @?= Position 1 0 - , testCase "UpLeft" $ move UpLeft mempty @?= Position (-1) (-1) - , testCase "UpRight" $ move UpRight mempty @?= Position 1 (-1) - , testCase "DownLeft" $ move DownLeft mempty @?= Position (-1) 1 - , testCase "DownRight" $ move DownRight mempty @?= Position 1 1 + [ testCase "Up" $ move Up mempty @?= Position @Int 0 (-1) + , testCase "Down" $ move Down mempty @?= Position @Int 0 1 + , testCase "Left" $ move Left mempty @?= Position @Int (-1) 0 + , testCase "Right" $ move Right mempty @?= Position @Int 1 0 + , testCase "UpLeft" $ move UpLeft mempty @?= Position @Int (-1) (-1) + , testCase "UpRight" $ move UpRight mempty @?= Position @Int 1 (-1) + , testCase "DownLeft" $ move DownLeft mempty @?= Position @Int (-1) 1 + , testCase "DownRight" $ move DownRight mempty @?= Position @Int 1 1 ] ] @@ -79,4 +81,18 @@ test = testGroup "Xanthous.Data" (Box (V2 4 2) dims) ] ] + + , testGroup "Neighbors" + [ testGroup "rotations" + [ testProperty "always has the same members" + $ \(neighs :: Neighbors Int) -> + all (\ns -> sort (toList ns) == sort (toList neighs)) + $ rotations neighs + , testProperty "all rotations have the same rotations" + $ \(neighs :: Neighbors Int) -> + let rots = rotations neighs + in all (\ns -> sort (toList $ rotations ns) == sort (toList rots)) + rots + ] + ] ] |