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.

7 files changed, 52 insertions, 10 deletions

diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 8d9ea54f0f..cff4a4d611 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 c2dbfe37ef..4bf0e28939 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 278e3d8ff4..ffbeddb29d 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 5ab2301e70..5bba77d5a1 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 ff9240a5e1..b3e27f86a6 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 9b81abe352..00785bf124 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 7590db2e20..ba6d49150a 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}}