Store revealed positions on the level itself

This was a bit of an oversight initially - we should be storing the
positions that the character has seen *on the level*, rather than on the
entire game state, for obvious reasons. This introduces a GameLevel
record, which has this field, the entities, and also the up staircase
position, which we can *also* use to position the character after going
down to a level we've already visited.

5 files changed, 61 insertions, 19 deletions

diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 577466328101..1f7714da1d57 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -1,5 +1,6 @@
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ViewPatterns         #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE RecordWildCards      #-}
 --------------------------------------------------------------------------------
 module Xanthous.App (makeApp) where
 --------------------------------------------------------------------------------
@@ -298,7 +299,7 @@ handleCommand GoDown = do
   then do
     levs <- use levels
     let newLevelNum = Levels.pos levs + 1
-    levs' <- nextLevel (levelToEntityMap <$> genLevel newLevelNum) levs
+    levs' <- nextLevel (levelToGameLevel <$> genLevel newLevelNum) levs
     cEID <- use characterEntityID
     pCharacter <- entities . at cEID <<.= Nothing
     levels .= levs'
@@ -600,3 +601,10 @@ genLevel _num = do
     Dungeon -> generateLevel SDungeon Dungeon.defaultParams dims
   characterPosition .= level ^. levelCharacterPosition
   pure $!! level
+
+levelToGameLevel :: Level -> GameLevel
+levelToGameLevel level =
+  let _levelEntities = levelToEntityMap level
+      _upStaircasePosition = level ^. levelCharacterPosition
+      _levelRevealedPositions = mempty
+  in GameLevel {..}
diff --git a/src/Xanthous/Entities/Entities.hs b/src/Xanthous/Entities/Entities.hs
index 1e533a297310..1b9f138fe22f 100644
--- a/src/Xanthous/Entities/Entities.hs
+++ b/src/Xanthous/Entities/Entities.hs
@@ -40,6 +40,8 @@ instance FromJSON SomeEntity where
       "GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data"
       _ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\""
 
+deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameLevel
+  instance FromJSON GameLevel
 deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
   instance FromJSON GameState
 
diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs
index d6f4784d55ff..4a64a12be096 100644
--- a/src/Xanthous/Game/Arbitrary.hs
+++ b/src/Xanthous/Game/Arbitrary.hs
@@ -16,20 +16,26 @@ import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Entities.Entities ()
 import           Xanthous.Entities.Character
 import           Xanthous.Game.State
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
 --------------------------------------------------------------------------------
 
+deriving via GenericArbitrary GameLevel instance Arbitrary GameLevel
+
 instance Arbitrary GameState where
   arbitrary = do
     chr <- arbitrary @Character
-    charPos <- arbitrary
+    _upStaircasePosition <- arbitrary
     _messageHistory <- arbitrary
-    levs <- arbitrary
-    let (_characterEntityID, currentLevel) =
-          EntityMap.insertAtReturningID charPos (SomeEntity chr)
-          $ extract levs
-        _levels = levs & current .~ currentLevel
-    _revealedPositions <- fmap setFromList . sublistOf
-                         $ foldMap EntityMap.positions levs
+    levs <- arbitrary @(Levels GameLevel)
+    _levelRevealedPositions <-
+      fmap setFromList
+      . sublistOf
+      . foldMap (EntityMap.positions . _levelEntities)
+      $ levs
+    let (_characterEntityID, _levelEntities) =
+          EntityMap.insertAtReturningID _upStaircasePosition (SomeEntity chr)
+          $ levs ^. current . levelEntities
+        _levels = levs & current .~ GameLevel {..}
     _randomGen <- mkStdGen <$> arbitrary
     let _promptState = NoPrompt -- TODO
     _activePanel <- arbitrary
@@ -38,6 +44,8 @@ instance Arbitrary GameState where
     pure $ GameState {..}
 
 
+instance CoArbitrary GameLevel
+instance Function GameLevel
 instance CoArbitrary GameState
 instance Function GameState
 deriving newtype instance CoArbitrary (m (a, GameState)) => CoArbitrary (AppT m a)
diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs
index 010fcb7022b5..8f6053a5ecc6 100644
--- a/src/Xanthous/Game/Lenses.hs
+++ b/src/Xanthous/Game/Lenses.hs
@@ -39,14 +39,16 @@ initialStateFromSeed :: Int -> GameState
 initialStateFromSeed seed =
   let _randomGen = mkStdGen seed
       chr = mkCharacter
-      (_characterEntityID, level)
+      _upStaircasePosition = Position 0 0
+      (_characterEntityID, _levelEntities)
         = EntityMap.insertAtReturningID
-          (Position 0 0)
+          _upStaircasePosition
           (SomeEntity chr)
           mempty
+      _levelRevealedPositions = mempty
+      level = GameLevel {..}
       _levels = oneLevel level
       _messageHistory = mempty
-      _revealedPositions = mempty
       _promptState = NoPrompt
       _activePanel = Nothing
       _debugState = DebugState
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index 36a2c2c174e5..e5ee66deac45 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -17,6 +17,12 @@ module Xanthous.Game.State
   , characterEntityID
   , GamePromptState(..)
 
+    -- * Game Level
+  , GameLevel(..)
+  , levelEntities
+  , upStaircasePosition
+  , levelRevealedPositions
+
     -- * Messages
   , MessageHistory(..)
   , HasMessages(..)
@@ -80,6 +86,7 @@ import qualified Graphics.Vty.Attributes as Vty
 import qualified Graphics.Vty.Image as Vty
 --------------------------------------------------------------------------------
 import           Xanthous.Util (KnownBool(..))
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
 import           Xanthous.Data
 import           Xanthous.Data.Levels
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
@@ -98,6 +105,7 @@ data MessageHistory
   }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary MessageHistory
   deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
            MessageHistory
@@ -113,9 +121,6 @@ instance Semigroup MessageHistory where
 instance Monoid MessageHistory where
   mempty = MessageHistory mempty 0 Nothing
 
-instance Arbitrary MessageHistory where
-  arbitrary = genericArbitrary
-
 type instance Element MessageHistory = [Text]
 instance MonoFunctor MessageHistory where
   omap f mh@(MessageHistory _ t _) =
@@ -400,6 +405,19 @@ instance
 
 --------------------------------------------------------------------------------
 
+data GameLevel = GameLevel
+  { _levelEntities :: !(EntityMap SomeEntity)
+  , _upStaircasePosition :: !Position
+  , _levelRevealedPositions :: !(Set Position)
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+  deriving (ToJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           GameLevel
+
+--------------------------------------------------------------------------------
+
 
 data DebugState = DebugState
   { _allRevealed :: !Bool
@@ -415,8 +433,7 @@ instance Arbitrary DebugState where
   arbitrary = genericArbitrary
 
 data GameState = GameState
-  { _levels            :: !(Levels (EntityMap SomeEntity))
-  , _revealedPositions :: !(Set Position)
+  { _levels            :: !(Levels GameLevel)
   , _characterEntityID :: !EntityID
   , _messageHistory    :: !MessageHistory
   , _randomGen         :: !StdGen
@@ -433,10 +450,15 @@ data GameState = GameState
   deriving (ToJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
            GameState
+
+makeLenses ''GameLevel
 makeLenses ''GameState
 
 entities :: Lens' GameState (EntityMap SomeEntity)
-entities = levels . current
+entities = levels . current . levelEntities
+
+revealedPositions :: Lens' GameState (Set Position)
+revealedPositions = levels . current . levelRevealedPositions
 
 instance Eq GameState where
   (==) = (==) `on` \gs ->