Place doors on the level
Pick a random subset of cells on the level that have a wall on two opposite sides and are clear on the other two sides, and place closed, unlocked doors on those cells.
This commit is contained in:
parent
e76567b9e7
commit
dcf44f29f5
4 changed files with 62 additions and 17 deletions
|
@ -90,11 +90,7 @@ initLevel = do
|
|||
generateLevel SCaveAutomata CaveAutomata.defaultParams
|
||||
$ Dimensions 80 80
|
||||
|
||||
entities <>= (SomeEntity <$> level ^. levelWalls)
|
||||
entities <>= (SomeEntity <$> level ^. levelItems)
|
||||
entities <>= (SomeEntity <$> level ^. levelCreatures)
|
||||
entities <>= (SomeEntity <$> level ^. levelTutorialMessage)
|
||||
|
||||
entities <>= levelToEntityMap level
|
||||
characterPosition .= level ^. levelCharacterPosition
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -7,6 +7,7 @@ module Xanthous.Entities.Environment
|
|||
, Door(..)
|
||||
, open
|
||||
, locked
|
||||
, unlockedDoor
|
||||
-- * Messages
|
||||
, GroundMessage(..)
|
||||
) where
|
||||
|
@ -88,6 +89,13 @@ instance Entity Door where
|
|||
description _ = "a door"
|
||||
entityChar _ = "d"
|
||||
|
||||
-- | A closed, unlocked door
|
||||
unlockedDoor :: Door
|
||||
unlockedDoor = Door
|
||||
{ _open = False
|
||||
, _locked = False
|
||||
}
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
newtype GroundMessage = GroundMessage Text
|
||||
|
|
|
@ -13,9 +13,11 @@ module Xanthous.Generators
|
|||
, levelWalls
|
||||
, levelItems
|
||||
, levelCreatures
|
||||
, levelDoors
|
||||
, levelCharacterPosition
|
||||
, levelTutorialMessage
|
||||
, generateLevel
|
||||
, levelToEntityMap
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Prelude hiding (Level)
|
||||
|
@ -34,6 +36,7 @@ import qualified Xanthous.Data.EntityMap as EntityMap
|
|||
import Xanthous.Entities.Environment
|
||||
import Xanthous.Entities.Item (Item)
|
||||
import Xanthous.Entities.Creature (Creature)
|
||||
import Xanthous.Game.State (SomeEntity(..))
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
data Generator
|
||||
|
@ -109,6 +112,7 @@ cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells
|
|||
|
||||
data Level = Level
|
||||
{ _levelWalls :: !(EntityMap Wall)
|
||||
, _levelDoors :: !(EntityMap Door)
|
||||
, _levelItems :: !(EntityMap Item)
|
||||
, _levelCreatures :: !(EntityMap Creature)
|
||||
, _levelTutorialMessage :: !(EntityMap GroundMessage)
|
||||
|
@ -116,13 +120,27 @@ data Level = Level
|
|||
}
|
||||
makeLenses ''Level
|
||||
|
||||
generateLevel :: MonadRandom m => SGenerator gen -> Params gen -> Dimensions -> m Level
|
||||
generateLevel
|
||||
:: MonadRandom m
|
||||
=> SGenerator gen
|
||||
-> Params gen
|
||||
-> Dimensions
|
||||
-> m Level
|
||||
generateLevel gen ps dims = do
|
||||
rand <- mkStdGen <$> getRandom
|
||||
let cells = generate gen ps dims rand
|
||||
_levelWalls = cellsToWalls cells
|
||||
_levelItems <- randomItems cells
|
||||
_levelCreatures <- randomCreatures cells
|
||||
_levelDoors <- randomDoors cells
|
||||
_levelCharacterPosition <- chooseCharacterPosition cells
|
||||
_levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition
|
||||
pure Level {..}
|
||||
|
||||
levelToEntityMap :: Level -> EntityMap SomeEntity
|
||||
levelToEntityMap level
|
||||
= (SomeEntity <$> level ^. levelWalls)
|
||||
<> (SomeEntity <$> level ^. levelDoors)
|
||||
<> (SomeEntity <$> level ^. levelItems)
|
||||
<> (SomeEntity <$> level ^. levelCreatures)
|
||||
<> (SomeEntity <$> level ^. levelTutorialMessage)
|
||||
|
|
|
@ -3,6 +3,7 @@ module Xanthous.Generators.LevelContents
|
|||
( chooseCharacterPosition
|
||||
, randomItems
|
||||
, randomCreatures
|
||||
, randomDoors
|
||||
, tutorialMessage
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -10,6 +11,7 @@ import Xanthous.Prelude
|
|||
--------------------------------------------------------------------------------
|
||||
import Control.Monad.Random
|
||||
import Data.Array.IArray (amap, bounds, rangeSize, (!))
|
||||
import qualified Data.Array.IArray as Arr
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Generators.Util
|
||||
import Xanthous.Random
|
||||
|
@ -20,7 +22,8 @@ import qualified Xanthous.Entities.Item as Item
|
|||
import Xanthous.Entities.Item (Item)
|
||||
import qualified Xanthous.Entities.Creature as Creature
|
||||
import Xanthous.Entities.Creature (Creature)
|
||||
import Xanthous.Entities.Environment (GroundMessage(..))
|
||||
import Xanthous.Entities.Environment
|
||||
(GroundMessage(..), Door(..), unlockedDoor)
|
||||
import Xanthous.Messages (message_)
|
||||
import Xanthous.Util.Graphics (circle)
|
||||
--------------------------------------------------------------------------------
|
||||
|
@ -31,6 +34,25 @@ chooseCharacterPosition = randomPosition
|
|||
randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
|
||||
randomItems = randomEntities Item.newWithType (0.0004, 0.001)
|
||||
|
||||
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
|
||||
doors = zip doorPositions $ repeat unlockedDoor
|
||||
pure $ _EntityMap # doors
|
||||
where
|
||||
candidateCells = filter doorable $ Arr.indices cells
|
||||
subsetRange = (0.8 :: Double, 1.0)
|
||||
doorable (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)
|
||||
]
|
||||
|
||||
randomCreatures :: MonadRandom m => Cells -> m (EntityMap Creature)
|
||||
randomCreatures = randomEntities Creature.newWithType (0.0007, 0.003)
|
||||
|
||||
|
@ -73,14 +95,15 @@ randomEntities newWithType sizeRange cells =
|
|||
pure $ _EntityMap # entities
|
||||
|
||||
randomPosition :: MonadRandom m => Cells -> m Position
|
||||
randomPosition cells = fmap positionFromPair . choose $ impureNonNull candidates
|
||||
where
|
||||
-- cells ends up with true = wall, we want true = can put an item here
|
||||
placeableCells = amap not cells
|
||||
randomPosition = fmap positionFromPair . choose . impureNonNull . cellCandidates
|
||||
|
||||
-- cellCandidates :: Cells -> Cells
|
||||
cellCandidates :: Cells -> Set (Word, Word)
|
||||
cellCandidates
|
||||
-- find the largest contiguous region of cells in the cave.
|
||||
candidates
|
||||
= maximumBy (compare `on` length)
|
||||
$ fromMaybe (error "No regions generated! this should never happen.")
|
||||
$ fromNullable
|
||||
$ regions placeableCells
|
||||
. fromMaybe (error "No regions generated! this should never happen.")
|
||||
. fromNullable
|
||||
. regions
|
||||
-- cells ends up with true = wall, we want true = can put an item here
|
||||
. amap not
|
||||
|
|
Loading…
Reference in a new issue