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.

3 files changed, 33 insertions, 10 deletions

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