Generate more reasonable doors

Generate doors at more reasonable positions, by:

- Only generating doors at the *ends* of hallways, where there's a
  tee-shaped opening
- Never generating two doors adjacent to each other
This commit is contained in:
Griffin Smith 2020-01-08 23:01:22 -05:00
parent 0f79a06733
commit b6f170c02c
3 changed files with 91 additions and 26 deletions

View file

@ -79,6 +79,8 @@ module Xanthous.Data
, edges , edges
, neighborDirections , neighborDirections
, neighborPositions , neighborPositions
, arrayNeighbors
, rotations
-- * -- *
, Hitpoints(..) , Hitpoints(..)
@ -88,11 +90,13 @@ import Xanthous.Prelude hiding (Left, Down, Right, (.=))
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Linear.V2 hiding (_x, _y) import Linear.V2 hiding (_x, _y)
import qualified Linear.V2 as L import qualified Linear.V2 as L
import Linear.V4 hiding (_x, _y)
import Test.QuickCheck (Arbitrary, CoArbitrary, Function) import Test.QuickCheck (Arbitrary, CoArbitrary, Function)
import Test.QuickCheck.Arbitrary.Generic import Test.QuickCheck.Arbitrary.Generic
import Data.Group import Data.Group
import Brick (Location(Location), Edges(..)) import Brick (Location(Location), Edges(..))
import Data.Monoid (Product(..), Sum(..)) import Data.Monoid (Product(..), Sum(..))
import Data.Array.IArray
import Data.Aeson.Generic.DerivingVia import Data.Aeson.Generic.DerivingVia
import Data.Aeson import Data.Aeson
( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject) ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject)
@ -280,7 +284,7 @@ instance Opposite Direction where
opposite DownRight = UpLeft opposite DownRight = UpLeft
opposite Here = Here opposite Here = Here
move :: Direction -> Position -> Position move :: Num a => Direction -> Position' a -> Position' a
move Up = y -~ 1 move Up = y -~ 1
move Down = y +~ 1 move Down = y +~ 1
move Left = x -~ 1 move Left = x -~ 1
@ -375,7 +379,8 @@ data Neighbors a = Neighbors
, _bottomRight :: a , _bottomRight :: a
} }
deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) 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 makeFieldsNoPrefix ''Neighbors
instance Applicative Neighbors where instance Applicative Neighbors where
@ -420,9 +425,39 @@ neighborDirections = Neighbors
, _bottomRight = DownRight , _bottomRight = DownRight
} }
neighborPositions :: Position -> Neighbors Position neighborPositions :: Num a => Position' a -> Neighbors (Position' a)
neighborPositions pos = (`move` pos) <$> neighborDirections 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 newtype Per a b = Rate Double

View file

@ -1,3 +1,4 @@
{-# LANGUAGE ViewPatterns #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.Generators.LevelContents module Xanthous.Generators.LevelContents
( chooseCharacterPosition ( chooseCharacterPosition
@ -8,15 +9,19 @@ module Xanthous.Generators.LevelContents
, tutorialMessage , tutorialMessage
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude hiding (any, toList)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Control.Monad.Random import Control.Monad.Random
import Data.Array.IArray (amap, bounds, rangeSize, (!)) import Data.Array.IArray (amap, bounds, rangeSize, (!))
import qualified Data.Array.IArray as Arr import qualified Data.Array.IArray as Arr
import Data.Foldable (any, toList)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Generators.Util import Xanthous.Generators.Util
import Xanthous.Random 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.Data.EntityMap (EntityMap, _EntityMap)
import Xanthous.Entities.Raws (rawsWithType, RawType) import Xanthous.Entities.Raws (rawsWithType, RawType)
import qualified Xanthous.Entities.Item as Item import qualified Xanthous.Entities.Item as Item
@ -44,22 +49,31 @@ randomDoors :: MonadRandom m => Cells -> m (EntityMap Door)
randomDoors cells = do randomDoors cells = do
doorRatio <- getRandomR subsetRange doorRatio <- getRandomR subsetRange
let numDoors = floor $ doorRatio * fromIntegral (length candidateCells) let numDoors = floor $ doorRatio * fromIntegral (length candidateCells)
doorPositions = positionFromPair <$> take numDoors candidateCells doorPositions =
removeAdjacent . fmap positionFromPair . take numDoors $ candidateCells
doors = zip doorPositions $ repeat unlockedDoor doors = zip doorPositions $ repeat unlockedDoor
pure $ _EntityMap # doors pure $ _EntityMap # doors
where where
removeAdjacent =
foldr (\pos acc ->
if pos `elem` (acc >>= toList . neighborPositions)
then acc
else pos : acc
) []
candidateCells = filter doorable $ Arr.indices cells candidateCells = filter doorable $ Arr.indices cells
subsetRange = (0.8 :: Double, 1.0) subsetRange = (0.8 :: Double, 1.0)
doorable (x, y) = doorable pos =
not (fromMaybe True $ cells ^? ix (x, y)) not (fromMaybe True $ cells ^? ix pos)
&& && any (teeish . fmap (fromMaybe True))
( fromMaybe True $ cells ^? ix (x - 1, y) -- left (rotations $ arrayNeighbors cells pos)
, fromMaybe True $ cells ^? ix (x, y - 1) -- top -- only generate doors at the *ends* of hallways, eg (where O is walkable,
, fromMaybe True $ cells ^? ix (x + 1, y) -- right -- X is a wall, and D is a door):
, fromMaybe True $ cells ^? ix (x, y + 1) -- bottom --
) `elem` [ (True, False, True, False) -- O O O
, (False, True, False, True) -- 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 :: MonadRandom m => Cells -> m (EntityMap Creature)
randomCreatures = randomEntities Creature.newWithType (0.0007, 0.003) randomCreatures = randomEntities Creature.newWithType (0.0007, 0.003)

View file

@ -1,9 +1,11 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.DataSpec (main, test) where module Xanthous.DataSpec (main, test) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Test.Prelude hiding (Right, Left, Down) import Test.Prelude hiding (Right, Left, Down, toList, all)
import Xanthous.Data
import Data.Group import Data.Group
import Data.Foldable (toList, all)
--------------------------------------------------------------------------------
import Xanthous.Data
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
main :: IO () main :: IO ()
@ -44,14 +46,14 @@ test = testGroup "Xanthous.Data"
, testProperty "asPosition isUnit" $ \dir -> , testProperty "asPosition isUnit" $ \dir ->
dir /= Here ==> isUnit (asPosition dir) dir /= Here ==> isUnit (asPosition dir)
, testGroup "Move" , testGroup "Move"
[ testCase "Up" $ move Up mempty @?= Position 0 (-1) [ testCase "Up" $ move Up mempty @?= Position @Int 0 (-1)
, testCase "Down" $ move Down mempty @?= Position 0 1 , testCase "Down" $ move Down mempty @?= Position @Int 0 1
, testCase "Left" $ move Left mempty @?= Position (-1) 0 , testCase "Left" $ move Left mempty @?= Position @Int (-1) 0
, testCase "Right" $ move Right mempty @?= Position 1 0 , testCase "Right" $ move Right mempty @?= Position @Int 1 0
, testCase "UpLeft" $ move UpLeft mempty @?= Position (-1) (-1) , testCase "UpLeft" $ move UpLeft mempty @?= Position @Int (-1) (-1)
, testCase "UpRight" $ move UpRight mempty @?= Position 1 (-1) , testCase "UpRight" $ move UpRight mempty @?= Position @Int 1 (-1)
, testCase "DownLeft" $ move DownLeft mempty @?= Position (-1) 1 , testCase "DownLeft" $ move DownLeft mempty @?= Position @Int (-1) 1
, testCase "DownRight" $ move DownRight mempty @?= Position 1 1 , testCase "DownRight" $ move DownRight mempty @?= Position @Int 1 1
] ]
] ]
@ -79,4 +81,18 @@ test = testGroup "Xanthous.Data"
(Box (V2 4 2) dims) (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
]
]
] ]