diff options
| -rw-r--r-- | src/Xanthous/App.hs | 6 | ||||
| -rw-r--r-- | src/Xanthous/Entities/Environment.hs | 8 | ||||
| -rw-r--r-- | src/Xanthous/Generators.hs | 20 | ||||
| -rw-r--r-- | src/Xanthous/Generators/LevelContents.hs | 45 |
4 files changed, 62 insertions, 17 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 2bdf6142f9fd..5fb70bd075b6 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs index 0690e47e5441..c34f2e0634d6 100644 --- a/src/Xanthous/Entities/Environment.hs +++ b/src/Xanthous/Entities/Environment.hs @@ -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 diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs index 592bf73c0007..8c0372ed538c 100644 --- a/src/Xanthous/Generators.hs +++ b/src/Xanthous/Generators.hs @@ -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) diff --git a/src/Xanthous/Generators/LevelContents.hs b/src/Xanthous/Generators/LevelContents.hs index 91a7d38019c8..aaeb4a77fdda 100644 --- a/src/Xanthous/Generators/LevelContents.hs +++ b/src/Xanthous/Generators/LevelContents.hs @@ -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 - -- 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 +-- cellCandidates :: Cells -> Cells +cellCandidates :: Cells -> Set (Word, Word) +cellCandidates + -- find the largest contiguous region of cells in the cave. + = maximumBy (compare `on` length) + . 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 |