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…
	
	Add table
		Add a link
		
	
		Reference in a new issue