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:
		
							parent
							
								
									0f79a06733
								
							
						
					
					
						commit
						b6f170c02c
					
				
					 3 changed files with 91 additions and 26 deletions
				
			
		|  | @ -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 | ||||||
|  |  | ||||||
|  | @ -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) | ||||||
|  |  | ||||||
|  | @ -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 | ||||||
|  |       ] | ||||||
|  |     ] | ||||||
|   ] |   ] | ||||||
|  |  | ||||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue