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 Data.Aeson (object, ToJSON)
import qualified Data.Aeson as A
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Vector as V
import System.Exit
import System.Directory (doesFileExist)
@ -30,6 +31,8 @@ import Xanthous.Data
)
import Xanthous.Data.EntityMap (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.State
import Xanthous.Game.Draw (drawGame)
@ -37,6 +40,7 @@ import Xanthous.Game.Prompt
import Xanthous.Monad
import Xanthous.Resource (Name, Panel(..))
import qualified Xanthous.Messages as Messages
import Xanthous.Random
import Xanthous.Util (removeVectorIndex)
import Xanthous.Util.Inflection (toSentence)
--------------------------------------------------------------------------------
@ -47,13 +51,14 @@ import qualified Xanthous.Entities.Item as Item
import Xanthous.Entities.Creature (Creature)
import qualified Xanthous.Entities.Creature as Creature
import Xanthous.Entities.Environment
(Door, open, locked, GroundMessage(..))
(Door, open, locked, GroundMessage(..), Staircase(..))
import Xanthous.Entities.RawTypes
( edible, eatMessage, hitpointsHealed
, attackMessage
)
import Xanthous.Generators
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import qualified Xanthous.Generators.Dungeon as Dungeon
--------------------------------------------------------------------------------
type App = Brick.App GameState () Name
@ -87,10 +92,7 @@ startEvent = do
initLevel :: AppM ()
initLevel = do
level <-
generateLevel SCaveAutomata CaveAutomata.defaultParams
$ Dimensions 80 80
level <- genLevel 0
entities <>= levelToEntityMap level
characterPosition .= level ^. levelCharacterPosition
@ -273,6 +275,40 @@ handleCommand Save = do
writeFile (unpack filename) $ toStrict src
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
val <- debugState . allRevealed <%= not
@ -551,3 +587,17 @@ showPanel panel = do
prompt_ @'Continue ["generic", "continue"] Uncancellable
. const
$ 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
| ShowInventory
| Wield
| GoUp
| GoDown
-- | TODO replace with `:` commands
| ToggleRevealAll
@ -41,6 +43,8 @@ commandFromKey (KChar 'S') [] = Just Save
commandFromKey (KChar 'r') [] = Just Read
commandFromKey (KChar 'i') [] = Just ShowInventory
commandFromKey (KChar 'w') [] = Just Wield
commandFromKey (KChar '<') [] = Just GoUp
commandFromKey (KChar '>') [] = Just GoDown
-- DEBUG COMMANDS --
commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll

View file

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

View file

@ -3,13 +3,18 @@ module Xanthous.Entities.Environment
(
-- * Walls
Wall(..)
-- * Doors
, Door(..)
, open
, locked
, unlockedDoor
-- * Messages
, GroundMessage(..)
-- * Stairs
, Staircase(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
@ -122,3 +127,28 @@ instance Entity GroundMessage where
description = const "a message on the ground. Press r. to read it."
entityChar = const ""
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
( GameState(..)
, levels
, entities
, revealedPositions
, messageHistory

View file

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

View file

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

View file

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

View file

@ -4,6 +4,7 @@ module Xanthous.Generators.LevelContents
, randomItems
, randomCreatures
, randomDoors
, placeDownStaircase
, tutorialMessage
) where
--------------------------------------------------------------------------------
@ -23,7 +24,7 @@ import Xanthous.Entities.Item (Item)
import qualified Xanthous.Entities.Creature as Creature
import Xanthous.Entities.Creature (Creature)
import Xanthous.Entities.Environment
(GroundMessage(..), Door(..), unlockedDoor)
(GroundMessage(..), Door(..), unlockedDoor, Staircase(..))
import Xanthous.Messages (message_)
import Xanthous.Util.Graphics (circle)
--------------------------------------------------------------------------------
@ -34,6 +35,11 @@ chooseCharacterPosition = randomPosition
randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
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 cells = do
doorRatio <- getRandomR subsetRange

View file

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

View file

@ -23,6 +23,14 @@ pickUp:
pickUp: You pick up the {{item.itemType.name}}
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:
prompt: Direction to open (hjklybnu.)?
success: "You open the door."

View file

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