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.
This commit is contained in:
parent
1a0f618a82
commit
abea2dcfac
7 changed files with 52 additions and 10 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -21,6 +21,11 @@ module Xanthous.Game
|
|||
|
||||
-- * App monad
|
||||
, AppT(..)
|
||||
|
||||
-- * Debug State
|
||||
, DebugState(..)
|
||||
, debugState
|
||||
, allRevealed
|
||||
) where
|
||||
--------------------------------------------------------------------------------
|
||||
import Xanthous.Game.State
|
||||
|
|
|
@ -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 {..}
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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}}
|
||||
|
|
Loading…
Reference in a new issue