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:
parent
6b0bab0e85
commit
0f79a06733
12 changed files with 125 additions and 17 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
module Xanthous.Game
|
||||
( GameState(..)
|
||||
, levels
|
||||
, entities
|
||||
, revealedPositions
|
||||
, messageHistory
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
Loading…
Reference in a new issue