Add support for multiple levels

Add a data structure, based on the zipper comonad, which provides
support for multiple levels, each of which is its own entity map. The
current level is provided by coreturn, which the `entities` lens has
been updated to use. Nothing currently supports going up or down levels
yet - that's coming next.

3 files changed, 24 insertions, 12 deletions

diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs
index a4e0255ca8c2..3be711099c23 100644
--- a/src/Xanthous/Game/Arbitrary.hs
+++ b/src/Xanthous/Game/Arbitrary.hs
@@ -5,15 +5,17 @@
 --------------------------------------------------------------------------------
 module Xanthous.Game.Arbitrary where
 --------------------------------------------------------------------------------
-import           Xanthous.Prelude
+import           Xanthous.Prelude hiding (levels, foldMap)
 --------------------------------------------------------------------------------
 import           Test.QuickCheck
 import           System.Random
+import           Data.Foldable (foldMap)
 --------------------------------------------------------------------------------
-import           Xanthous.Game.State
+import           Xanthous.Data.Levels
+import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Entities.Entities ()
 import           Xanthous.Entities.Character
-import qualified Xanthous.Data.EntityMap as EntityMap
+import           Xanthous.Game.State
 --------------------------------------------------------------------------------
 
 instance Arbitrary GameState where
@@ -21,9 +23,13 @@ instance Arbitrary GameState where
     chr <- arbitrary @Character
     charPos <- arbitrary
     _messageHistory <- arbitrary
-    (_characterEntityID, _entities) <- arbitrary <&>
-      EntityMap.insertAtReturningID charPos (SomeEntity chr)
-    _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities
+    levels <- arbitrary
+    let (_characterEntityID, currentLevel) =
+          EntityMap.insertAtReturningID charPos (SomeEntity chr)
+          $ extract levels
+        _levels = levels & current .~ currentLevel
+    _revealedPositions <- fmap setFromList . sublistOf
+                         $ foldMap EntityMap.positions levels
     _randomGen <- mkStdGen <$> arbitrary
     let _promptState = NoPrompt -- TODO
     _activePanel <- arbitrary
diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs
index f7f4648dd5ed..010fcb7022b5 100644
--- a/src/Xanthous/Game/Lenses.hs
+++ b/src/Xanthous/Game/Lenses.hs
@@ -25,6 +25,7 @@ import           Control.Monad.Random (getRandom)
 --------------------------------------------------------------------------------
 import           Xanthous.Game.State
 import           Xanthous.Data
+import           Xanthous.Data.Levels
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Data.EntityMap.Graphics (visiblePositions)
 import           Xanthous.Entities.Character (Character, mkCharacter)
@@ -38,11 +39,12 @@ initialStateFromSeed :: Int -> GameState
 initialStateFromSeed seed =
   let _randomGen = mkStdGen seed
       chr = mkCharacter
-      (_characterEntityID, _entities)
+      (_characterEntityID, level)
         = EntityMap.insertAtReturningID
           (Position 0 0)
           (SomeEntity chr)
           mempty
+      _levels = oneLevel level
       _messageHistory = mempty
       _revealedPositions = mempty
       _promptState = NoPrompt
@@ -108,4 +110,4 @@ entitiesCollision
 entitiesCollision = join . maximumMay . fmap entityCollision
 
 collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
-collisionAt pos = uses (entities . EntityMap.atPosition pos) entitiesCollision
+collisionAt p = uses (entities . EntityMap.atPosition p) entitiesCollision
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index 171f381e6b74..7587618c968b 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -58,7 +58,7 @@ module Xanthous.Game.State
   , allRevealed
   ) where
 --------------------------------------------------------------------------------
-import           Xanthous.Prelude
+import           Xanthous.Prelude hiding (levels)
 --------------------------------------------------------------------------------
 import           Data.List.NonEmpty ( NonEmpty((:|)))
 import qualified Data.List.NonEmpty as NonEmpty
@@ -80,6 +80,7 @@ import qualified Graphics.Vty.Image as Vty
 --------------------------------------------------------------------------------
 import           Xanthous.Util (KnownBool(..))
 import           Xanthous.Data
+import           Xanthous.Data.Levels
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import           Xanthous.Data.EntityChar
 import           Xanthous.Data.VectorBag
@@ -359,8 +360,8 @@ instance Draw SomeEntity where
   drawPriority (SomeEntity ent) = drawPriority ent
 
 instance Brain SomeEntity where
-  step ticks (Positioned pos (SomeEntity ent)) =
-    fmap SomeEntity <$> step ticks (Positioned pos ent)
+  step ticks (Positioned p (SomeEntity ent)) =
+    fmap SomeEntity <$> step ticks (Positioned p ent)
 
 downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a
 downcastEntity (SomeEntity e) = cast e
@@ -413,7 +414,7 @@ instance Arbitrary DebugState where
   arbitrary = genericArbitrary
 
 data GameState = GameState
-  { _entities          :: !(EntityMap SomeEntity)
+  { _levels            :: !(Levels (EntityMap SomeEntity))
   , _revealedPositions :: !(Set Position)
   , _characterEntityID :: !EntityID
   , _messageHistory    :: !MessageHistory
@@ -433,6 +434,9 @@ data GameState = GameState
            GameState
 makeLenses ''GameState
 
+entities :: Lens' GameState (EntityMap SomeEntity)
+entities = levels . current
+
 instance Eq GameState where
   (==) = (==) `on` \gs ->
     ( gs ^. entities