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.

src/Xanthous/App.hs

@@ -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,13 +31,16 @@ 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)
 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

src/Xanthous/Command.hs

@@ -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

src/Xanthous/Data/Levels.hs

@@ -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 ()

src/Xanthous/Entities/Environment.hs

@@ -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

src/Xanthous/Game.hs

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

src/Xanthous/Game/Arbitrary.hs

@@ -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

src/Xanthous/Game/State.hs

@@ -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

src/Xanthous/Generators.hs

@@ -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)

src/Xanthous/Generators/LevelContents.hs

@@ -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

src/Xanthous/Prelude.hs

@@ -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
 --------------------------------------------------------------------------------

src/Xanthous/messages.yaml

@@ -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."

test/Xanthous/Data/LevelsSpec.hs

@@ -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
 --------------------------------------------------------------------------------