diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 1db75bb58..2fd821af1 100644 --- a/src/Xanthous/App.hs +++ b/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,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 diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs index d5bb5cd9e..7db694575 100644 --- a/src/Xanthous/Command.hs +++ b/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 diff --git a/src/Xanthous/Data/Levels.hs b/src/Xanthous/Data/Levels.hs index bc5eff9ba..5fc3f9334 100644 --- a/src/Xanthous/Data/Levels.hs +++ b/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 () diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs index dee8d83c3..993714c84 100644 --- a/src/Xanthous/Entities/Environment.hs +++ b/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 diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs index 094858618..a8d096f02 100644 --- a/src/Xanthous/Game.hs +++ b/src/Xanthous/Game.hs @@ -1,5 +1,6 @@ module Xanthous.Game ( GameState(..) + , levels , entities , revealedPositions , messageHistory diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs index 3be711099..d6f4784d5 100644 --- a/src/Xanthous/Game/Arbitrary.hs +++ b/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 diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 7587618c9..36a2c2c17 100644 --- a/src/Xanthous/Game/State.hs +++ b/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 diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs index 8c0372ed5..9b2b90e30 100644 --- a/src/Xanthous/Generators.hs +++ b/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) diff --git a/src/Xanthous/Generators/LevelContents.hs b/src/Xanthous/Generators/LevelContents.hs index 96d64a693..748afa96d 100644 --- a/src/Xanthous/Generators/LevelContents.hs +++ b/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 diff --git a/src/Xanthous/Prelude.hs b/src/Xanthous/Prelude.hs index 2f50635e7..9a4ca0149 100644 --- a/src/Xanthous/Prelude.hs +++ b/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 -------------------------------------------------------------------------------- diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml index 1a4159b0a..23cc102f5 100644 --- a/src/Xanthous/messages.yaml +++ b/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." diff --git a/test/Xanthous/Data/LevelsSpec.hs b/test/Xanthous/Data/LevelsSpec.hs index eb7425390..49d3719b1 100644 --- a/test/Xanthous/Data/LevelsSpec.hs +++ b/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 --------------------------------------------------------------------------------