From abea2dcfac0e094bf4ce0d378763af7816b04501 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 28 Sep 2019 15:01:21 -0400 Subject: Add debug command to reveal the game Add a (debug) command to reveal all tiles on the game regardless of the character's vision, which'll make it easier to debug creature's behavior while they're not visible. --- src/Xanthous/App.hs | 7 +++++++ src/Xanthous/Command.hs | 4 ++++ src/Xanthous/Game.hs | 5 +++++ src/Xanthous/Game/Arbitrary.hs | 1 + src/Xanthous/Game/Draw.hs | 19 +++++++++++-------- src/Xanthous/Game/State.hs | 23 +++++++++++++++++++++-- src/Xanthous/messages.yaml | 3 +++ 7 files changed, 52 insertions(+), 10 deletions(-) (limited to 'src/Xanthous') diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 8d9ea54f0f7c..cff4a4d611e3 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -155,6 +155,13 @@ handleCommand Open = do handleCommand Wait = stepGame >> continue +handleCommand ToggleRevealAll = do + val <- debugState . allRevealed <%= not + say ["debug", "toggleRevealAll"] $ object [ "revealAll" A..= val ] + continue + +-------------------------------------------------------------------------------- + handlePromptEvent :: Text -- ^ Prompt message -> Prompt AppM diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs index c2dbfe37efa6..4bf0e2893908 100644 --- a/src/Xanthous/Command.hs +++ b/src/Xanthous/Command.hs @@ -17,6 +17,9 @@ data Command | Open | Wait + -- | TODO replace with `:` commands + | ToggleRevealAll + commandFromKey :: Key -> [Modifier] -> Maybe Command commandFromKey (KChar 'q') [] = Just Quit commandFromKey (KChar '.') [] = Just Wait @@ -24,6 +27,7 @@ commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage commandFromKey (KChar ',') [] = Just PickUp commandFromKey (KChar 'o') [] = Just Open +commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll commandFromKey _ _ = Nothing -------------------------------------------------------------------------------- diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs index 278e3d8ff4cc..ffbeddb29d1a 100644 --- a/src/Xanthous/Game.hs +++ b/src/Xanthous/Game.hs @@ -21,6 +21,11 @@ module Xanthous.Game -- * App monad , AppT(..) + + -- * Debug State + , DebugState(..) + , debugState + , allRevealed ) where -------------------------------------------------------------------------------- import Xanthous.Game.State diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs index 5ab2301e7083..5bba77d5a174 100644 --- a/src/Xanthous/Game/Arbitrary.hs +++ b/src/Xanthous/Game/Arbitrary.hs @@ -24,4 +24,5 @@ instance Arbitrary GameState where _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities _randomGen <- mkStdGen <$> arbitrary let _promptState = NoPrompt -- TODO + _debugState <- arbitrary pure $ GameState {..} diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index ff9240a5e1bf..b3e27f86a693 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -23,6 +23,7 @@ import Xanthous.Game , messageHistory , GamePromptState(..) , promptState + , debugState, allRevealed ) import Xanthous.Game.Prompt import Xanthous.Resource (Name) @@ -46,14 +47,11 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps _)) = _ -> undefined drawEntities - :: Set Position - -- ^ Positions the character has seen - -- FIXME: this will break down as soon as creatures can walk around on their - -- own, since we don't want to render things walking around when the - -- character can't see them + :: (Position -> Bool) + -- ^ Can we render a given position? -> EntityMap SomeEntity -- ^ all entities -> Widget Name -drawEntities visiblePositions allEnts +drawEntities canRenderPos allEnts = vBox rows where entityPositions = EntityMap.positions allEnts @@ -62,7 +60,7 @@ drawEntities visiblePositions allEnts rows = mkRow <$> [0..maxY] mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX] renderEntityAt pos - | pos `member` visiblePositions + | canRenderPos pos = let neighbors = EntityMap.neighbors pos allEnts in maybe (str " ") (drawWithNeighbors neighbors) $ allEnts ^? atPosition pos . folded @@ -73,7 +71,12 @@ drawMap game = viewport Resource.MapViewport Both . showCursor Resource.Character (game ^. characterPosition . loc) $ drawEntities - (game ^. revealedPositions) + (\pos -> + (game ^. debugState . allRevealed) + || (pos `member` (game ^. revealedPositions))) + -- FIXME: this will break down as soon as creatures can walk around on their + -- own, since we don't want to render things walking around when the + -- character can't see them (game ^. entities) drawGame :: GameState -> [Widget Name] diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 9b81abe35247..00785bf12440 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -32,6 +32,11 @@ module Xanthous.Game.State , downcastEntity , _SomeEntity , entityIs + + -- * Debug State + , DebugState(..) + , debugState + , allRevealed ) where -------------------------------------------------------------------------------- import Xanthous.Prelude @@ -158,10 +163,10 @@ instance Entity SomeEntity where blocksVision (SomeEntity ent) = blocksVision ent description (SomeEntity ent) = description ent -downcastEntity :: forall a. (Entity a, Typeable a) => SomeEntity -> Maybe a +downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a downcastEntity (SomeEntity e) = cast e -entityIs :: forall a. (Entity a, Typeable a) => SomeEntity -> Bool +entityIs :: forall (a :: Type). (Typeable a) => SomeEntity -> Bool entityIs = isJust . downcastEntity @a _SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a @@ -169,6 +174,15 @@ _SomeEntity = prism' SomeEntity downcastEntity -------------------------------------------------------------------------------- +data DebugState = DebugState + { _allRevealed :: !Bool + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + +instance Arbitrary DebugState where + arbitrary = genericArbitrary + data GameState = GameState { _entities :: !(EntityMap SomeEntity) , _revealedPositions :: !(Set Position) @@ -176,6 +190,7 @@ data GameState = GameState , _messageHistory :: !MessageHistory , _randomGen :: !StdGen , _promptState :: !(GamePromptState AppM) + , _debugState :: DebugState } deriving stock (Show) makeLenses ''GameState @@ -198,3 +213,7 @@ instance (Monad m) => MonadRandom (AppT m) where getRandom = randomGen %%= random getRandomRs rng = uses randomGen $ randomRs rng getRandoms = uses randomGen randoms + +-------------------------------------------------------------------------------- + +makeLenses ''DebugState diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml index 7590db2e2050..ba6d49150aee 100644 --- a/src/Xanthous/messages.yaml +++ b/src/Xanthous/messages.yaml @@ -24,3 +24,6 @@ combat: killed: - You kill the {{creature.creatureType.name}}! - You've killed the {{creature.creatureType.name}}! + +debug: + toggleRevealAll: revealAll now set to {{revealAll}} -- cgit 1.4.1