Add staircases, and moving between levels

Currently we just pick randomly between the cave and dungeon level
generators. There's a lot of bugs here, but it's *sorta* working, so I'm
leaving it as is.
This commit is contained in:
Griffin Smith 2020-01-05 12:55:15 -05:00
parent 6b0bab0e85
commit 0f79a06733
12 changed files with 125 additions and 17 deletions

View file

@ -14,6 +14,7 @@ import Control.Monad.Random (MonadRandom)
import Control.Monad.State.Class (modify) import Control.Monad.State.Class (modify)
import Data.Aeson (object, ToJSON) import Data.Aeson (object, ToJSON)
import qualified Data.Aeson as A import qualified Data.Aeson as A
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Vector as V import qualified Data.Vector as V
import System.Exit import System.Exit
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
@ -30,6 +31,8 @@ import Xanthous.Data
) )
import Xanthous.Data.EntityMap (EntityMap) import Xanthous.Data.EntityMap (EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Data.Levels (prevLevel, nextLevel)
import qualified Xanthous.Data.Levels as Levels
import Xanthous.Game import Xanthous.Game
import Xanthous.Game.State import Xanthous.Game.State
import Xanthous.Game.Draw (drawGame) import Xanthous.Game.Draw (drawGame)
@ -37,6 +40,7 @@ import Xanthous.Game.Prompt
import Xanthous.Monad import Xanthous.Monad
import Xanthous.Resource (Name, Panel(..)) import Xanthous.Resource (Name, Panel(..))
import qualified Xanthous.Messages as Messages import qualified Xanthous.Messages as Messages
import Xanthous.Random
import Xanthous.Util (removeVectorIndex) import Xanthous.Util (removeVectorIndex)
import Xanthous.Util.Inflection (toSentence) import Xanthous.Util.Inflection (toSentence)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -47,13 +51,14 @@ import qualified Xanthous.Entities.Item as Item
import Xanthous.Entities.Creature (Creature) import Xanthous.Entities.Creature (Creature)
import qualified Xanthous.Entities.Creature as Creature import qualified Xanthous.Entities.Creature as Creature
import Xanthous.Entities.Environment import Xanthous.Entities.Environment
(Door, open, locked, GroundMessage(..)) (Door, open, locked, GroundMessage(..), Staircase(..))
import Xanthous.Entities.RawTypes import Xanthous.Entities.RawTypes
( edible, eatMessage, hitpointsHealed ( edible, eatMessage, hitpointsHealed
, attackMessage , attackMessage
) )
import Xanthous.Generators import Xanthous.Generators
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import qualified Xanthous.Generators.Dungeon as Dungeon
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
type App = Brick.App GameState () Name type App = Brick.App GameState () Name
@ -87,10 +92,7 @@ startEvent = do
initLevel :: AppM () initLevel :: AppM ()
initLevel = do initLevel = do
level <- level <- genLevel 0
generateLevel SCaveAutomata CaveAutomata.defaultParams
$ Dimensions 80 80
entities <>= levelToEntityMap level entities <>= levelToEntityMap level
characterPosition .= level ^. levelCharacterPosition characterPosition .= level ^. levelCharacterPosition
@ -273,6 +275,40 @@ handleCommand Save = do
writeFile (unpack filename) $ toStrict src writeFile (unpack filename) $ toStrict src
exitSuccess exitSuccess
handleCommand GoUp = do
charPos <- use characterPosition
hasStairs <- uses (entities . EntityMap.atPosition charPos)
$ elem (SomeEntity UpStaircase)
if hasStairs
then uses levels prevLevel >>= \case
Just levs' -> levels .= levs'
Nothing ->
-- TODO in nethack, this leaves the game. Maybe something similar here?
say_ ["cant", "goUp"]
else say_ ["cant", "goUp"]
continue
handleCommand GoDown = do
charPos <- use characterPosition
hasStairs <- uses (entities . EntityMap.atPosition charPos)
$ elem (SomeEntity DownStaircase)
if hasStairs
then do
levs <- use levels
let newLevelNum = Levels.pos levs + 1
levs' <- nextLevel (levelToEntityMap <$> genLevel newLevelNum) levs
cEID <- use characterEntityID
pCharacter <- use $ entities . at cEID
entities . at cEID .= Nothing
levels .= levs'
entities . at cEID .= pCharacter
else say_ ["cant", "goDown"]
continue
--
handleCommand ToggleRevealAll = do handleCommand ToggleRevealAll = do
val <- debugState . allRevealed <%= not val <- debugState . allRevealed <%= not
@ -551,3 +587,17 @@ showPanel panel = do
prompt_ @'Continue ["generic", "continue"] Uncancellable prompt_ @'Continue ["generic", "continue"] Uncancellable
. const . const
$ activePanel .= Nothing $ activePanel .= Nothing
--------------------------------------------------------------------------------
genLevel
:: Int -- ^ level number
-> AppM Level
genLevel _num = do
let dims = Dimensions 80 80
generator <- choose $ CaveAutomata :| [Dungeon]
level <- case generator of
CaveAutomata -> generateLevel SCaveAutomata CaveAutomata.defaultParams dims
Dungeon -> generateLevel SDungeon Dungeon.defaultParams dims
characterPosition .= level ^. levelCharacterPosition
pure $!! level

View file

@ -23,6 +23,8 @@ data Command
| Read | Read
| ShowInventory | ShowInventory
| Wield | Wield
| GoUp
| GoDown
-- | TODO replace with `:` commands -- | TODO replace with `:` commands
| ToggleRevealAll | ToggleRevealAll
@ -41,6 +43,8 @@ commandFromKey (KChar 'S') [] = Just Save
commandFromKey (KChar 'r') [] = Just Read commandFromKey (KChar 'r') [] = Just Read
commandFromKey (KChar 'i') [] = Just ShowInventory commandFromKey (KChar 'i') [] = Just ShowInventory
commandFromKey (KChar 'w') [] = Just Wield commandFromKey (KChar 'w') [] = Just Wield
commandFromKey (KChar '<') [] = Just GoUp
commandFromKey (KChar '>') [] = Just GoDown
-- DEBUG COMMANDS -- -- DEBUG COMMANDS --
commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll

View file

@ -14,7 +14,7 @@ module Xanthous.Data.Levels
, ComonadStore(..) , ComonadStore(..)
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude hiding ((<.>), Empty, foldMap, levels) import Xanthous.Prelude hiding ((<.>), Empty, foldMap)
import Xanthous.Util (between, EqProp, EqEqProp(..)) import Xanthous.Util (between, EqProp, EqEqProp(..))
import Xanthous.Util.Comonad (current) import Xanthous.Util.Comonad (current)
import Xanthous.Orphans () import Xanthous.Orphans ()

View file

@ -3,13 +3,18 @@ module Xanthous.Entities.Environment
( (
-- * Walls -- * Walls
Wall(..) Wall(..)
-- * Doors -- * Doors
, Door(..) , Door(..)
, open , open
, locked , locked
, unlockedDoor , unlockedDoor
-- * Messages -- * Messages
, GroundMessage(..) , GroundMessage(..)
-- * Stairs
, Staircase(..)
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude
@ -122,3 +127,28 @@ instance Entity GroundMessage where
description = const "a message on the ground. Press r. to read it." description = const "a message on the ground. Press r. to read it."
entityChar = const "" entityChar = const ""
entityCollision = const Nothing entityCollision = const Nothing
--------------------------------------------------------------------------------
data Staircase = UpStaircase | DownStaircase
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary Staircase
deriving (ToJSON, FromJSON)
via WithOptions '[ 'TagSingleConstructors 'True
, 'SumEnc 'ObjWithSingleField
]
Staircase
instance Brain Staircase where step = brainVia Brainless
instance Draw Staircase where
draw UpStaircase = str "<"
draw DownStaircase = str ">"
instance Entity Staircase where
blocksVision = const False
description UpStaircase = "a staircase leading upwards"
description DownStaircase = "a staircase leading downwards"
entityChar UpStaircase = "<"
entityChar DownStaircase = ">"
entityCollision = const Nothing

View file

@ -1,5 +1,6 @@
module Xanthous.Game module Xanthous.Game
( GameState(..) ( GameState(..)
, levels
, entities , entities
, revealedPositions , revealedPositions
, messageHistory , messageHistory

View file

@ -5,7 +5,7 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.Game.Arbitrary where module Xanthous.Game.Arbitrary where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude hiding (levels, foldMap) import Xanthous.Prelude hiding (foldMap)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Test.QuickCheck import Test.QuickCheck
import System.Random import System.Random
@ -23,13 +23,13 @@ instance Arbitrary GameState where
chr <- arbitrary @Character chr <- arbitrary @Character
charPos <- arbitrary charPos <- arbitrary
_messageHistory <- arbitrary _messageHistory <- arbitrary
levels <- arbitrary levs <- arbitrary
let (_characterEntityID, currentLevel) = let (_characterEntityID, currentLevel) =
EntityMap.insertAtReturningID charPos (SomeEntity chr) EntityMap.insertAtReturningID charPos (SomeEntity chr)
$ extract levels $ extract levs
_levels = levels & current .~ currentLevel _levels = levs & current .~ currentLevel
_revealedPositions <- fmap setFromList . sublistOf _revealedPositions <- fmap setFromList . sublistOf
$ foldMap EntityMap.positions levels $ foldMap EntityMap.positions levs
_randomGen <- mkStdGen <$> arbitrary _randomGen <- mkStdGen <$> arbitrary
let _promptState = NoPrompt -- TODO let _promptState = NoPrompt -- TODO
_activePanel <- arbitrary _activePanel <- arbitrary

View file

@ -7,6 +7,7 @@
module Xanthous.Game.State module Xanthous.Game.State
( GameState(..) ( GameState(..)
, entities , entities
, levels
, revealedPositions , revealedPositions
, messageHistory , messageHistory
, randomGen , randomGen
@ -58,7 +59,7 @@ module Xanthous.Game.State
, allRevealed , allRevealed
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude hiding (levels) import Xanthous.Prelude
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Data.List.NonEmpty ( NonEmpty((:|))) import Data.List.NonEmpty ( NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty

View file

@ -4,6 +4,7 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.Generators module Xanthous.Generators
( generate ( generate
, Generator(..)
, SGenerator(..) , SGenerator(..)
, GeneratorInput , GeneratorInput
, generateFromInput , generateFromInput
@ -20,7 +21,7 @@ module Xanthous.Generators
, levelToEntityMap , levelToEntityMap
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude hiding (Level) import Xanthous.Prelude
import Data.Array.Unboxed import Data.Array.Unboxed
import System.Random (RandomGen) import System.Random (RandomGen)
import qualified Options.Applicative as Opt import qualified Options.Applicative as Opt
@ -31,7 +32,7 @@ import qualified Xanthous.Generators.Dungeon as Dungeon
import Xanthous.Generators.Util import Xanthous.Generators.Util
import Xanthous.Generators.LevelContents import Xanthous.Generators.LevelContents
import Xanthous.Data (Dimensions, Position'(Position), Position) import Xanthous.Data (Dimensions, Position'(Position), Position)
import Xanthous.Data.EntityMap (EntityMap) import Xanthous.Data.EntityMap (EntityMap, _EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities.Environment import Xanthous.Entities.Environment
import Xanthous.Entities.Item (Item) import Xanthous.Entities.Item (Item)
@ -116,8 +117,11 @@ data Level = Level
, _levelItems :: !(EntityMap Item) , _levelItems :: !(EntityMap Item)
, _levelCreatures :: !(EntityMap Creature) , _levelCreatures :: !(EntityMap Creature)
, _levelTutorialMessage :: !(EntityMap GroundMessage) , _levelTutorialMessage :: !(EntityMap GroundMessage)
, _levelStaircases :: !(EntityMap Staircase)
, _levelCharacterPosition :: !Position , _levelCharacterPosition :: !Position
} }
deriving stock (Generic)
deriving anyclass (NFData)
makeLenses ''Level makeLenses ''Level
generateLevel generateLevel
@ -134,6 +138,9 @@ generateLevel gen ps dims = do
_levelCreatures <- randomCreatures cells _levelCreatures <- randomCreatures cells
_levelDoors <- randomDoors cells _levelDoors <- randomDoors cells
_levelCharacterPosition <- chooseCharacterPosition cells _levelCharacterPosition <- chooseCharacterPosition cells
let upStaircase = _EntityMap # [(_levelCharacterPosition, UpStaircase)]
downStaircase <- placeDownStaircase cells
let _levelStaircases = upStaircase <> downStaircase
_levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition _levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition
pure Level {..} pure Level {..}
@ -144,3 +151,4 @@ levelToEntityMap level
<> (SomeEntity <$> level ^. levelItems) <> (SomeEntity <$> level ^. levelItems)
<> (SomeEntity <$> level ^. levelCreatures) <> (SomeEntity <$> level ^. levelCreatures)
<> (SomeEntity <$> level ^. levelTutorialMessage) <> (SomeEntity <$> level ^. levelTutorialMessage)
<> (SomeEntity <$> level ^. levelStaircases)

View file

@ -4,6 +4,7 @@ module Xanthous.Generators.LevelContents
, randomItems , randomItems
, randomCreatures , randomCreatures
, randomDoors , randomDoors
, placeDownStaircase
, tutorialMessage , tutorialMessage
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -23,7 +24,7 @@ import Xanthous.Entities.Item (Item)
import qualified Xanthous.Entities.Creature as Creature import qualified Xanthous.Entities.Creature as Creature
import Xanthous.Entities.Creature (Creature) import Xanthous.Entities.Creature (Creature)
import Xanthous.Entities.Environment import Xanthous.Entities.Environment
(GroundMessage(..), Door(..), unlockedDoor) (GroundMessage(..), Door(..), unlockedDoor, Staircase(..))
import Xanthous.Messages (message_) import Xanthous.Messages (message_)
import Xanthous.Util.Graphics (circle) import Xanthous.Util.Graphics (circle)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -34,6 +35,11 @@ chooseCharacterPosition = randomPosition
randomItems :: MonadRandom m => Cells -> m (EntityMap Item) randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
randomItems = randomEntities Item.newWithType (0.0004, 0.001) randomItems = randomEntities Item.newWithType (0.0004, 0.001)
placeDownStaircase :: MonadRandom m => Cells -> m (EntityMap Staircase)
placeDownStaircase cells = do
pos <- randomPosition cells
pure $ _EntityMap # [(pos, DownStaircase)]
randomDoors :: MonadRandom m => Cells -> m (EntityMap Door) randomDoors :: MonadRandom m => Cells -> m (EntityMap Door)
randomDoors cells = do randomDoors cells = do
doorRatio <- getRandomR subsetRange doorRatio <- getRandomR subsetRange

View file

@ -19,7 +19,7 @@ import ClassyPrelude hiding
(return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say) (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say)
import Data.Kind import Data.Kind
import GHC.TypeLits hiding (Text) import GHC.TypeLits hiding (Text)
import Control.Lens import Control.Lens hiding (levels, Level)
import Data.Void import Data.Void
import Control.Comonad import Control.Comonad
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

View file

@ -23,6 +23,14 @@ pickUp:
pickUp: You pick up the {{item.itemType.name}} pickUp: You pick up the {{item.itemType.name}}
nothingToPickUp: "There's nothing here to pick up" nothingToPickUp: "There's nothing here to pick up"
cant:
goUp:
- You can't go up here
- There's nothing here that would let you go up
goDown:
- You can't go down here
- There's nothing here that would let you go down
open: open:
prompt: Direction to open (hjklybnu.)? prompt: Direction to open (hjklybnu.)?
success: "You open the door." success: "You open the door."

View file

@ -1,7 +1,7 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.Data.LevelsSpec (main, test) where module Xanthous.Data.LevelsSpec (main, test) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Test.Prelude hiding (levels) import Test.Prelude
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import qualified Data.Aeson as JSON import qualified Data.Aeson as JSON
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------