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.

src/Xanthous/Data/Levels.hs

@@ -0,0 +1,170 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Data.Levels
+  ( Levels
+  , allLevels
+  , nextLevel
+  , prevLevel
+  , mkLevels1
+  , mkLevels
+  , oneLevel
+  , current
+  , ComonadStore(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding ((<.>), Empty, foldMap, levels)
+import           Xanthous.Util (between, EqProp, EqEqProp(..))
+import           Xanthous.Util.Comonad (current)
+import           Xanthous.Orphans ()
+--------------------------------------------------------------------------------
+import           Control.Comonad.Store
+import           Control.Comonad.Store.Zipper
+import           Data.Aeson (ToJSON(..), FromJSON(..))
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Functor.Apply
+import           Data.Foldable (foldMap)
+import           Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NE
+import           Data.Maybe (fromJust)
+import           Data.Sequence (Seq((:<|), Empty))
+import           Data.Semigroup.Foldable.Class
+import           Data.Text (replace)
+import           Test.QuickCheck
+--------------------------------------------------------------------------------
+
+-- | Collection of levels plus a pointer to the current level
+--
+-- Navigation is via the 'Comonad' instance. We can get the current level with
+-- 'extract':
+--
+--     extract @Levels :: Levels level -> level
+--
+-- For access to and modification of the level, use
+-- 'Xanthous.Util.Comonad.current'
+newtype Levels a = Levels { levelZipper :: Zipper Seq a }
+    deriving stock (Generic)
+    deriving (Functor, Comonad, Foldable) via (Zipper Seq)
+    deriving (ComonadStore Int) via (Zipper Seq)
+
+type instance Element (Levels a) = a
+instance MonoFoldable (Levels a)
+instance MonoFunctor (Levels a)
+instance MonoTraversable (Levels a)
+
+instance Traversable Levels where
+  traverse f (Levels z) = Levels <$> traverse f z
+
+instance Foldable1 Levels
+
+instance Traversable1 Levels where
+  traverse1 f (Levels z) = seek (pos z) . partialMkLevels <$> go (unzipper z)
+    where
+      go Empty = error "empty seq, unreachable"
+      go (x :<| xs) = (<|) <$> f x <.> go xs
+
+-- | Always takes the position of the latter element
+instance Semigroup (Levels a) where
+  levs₁ <> levs₂
+    = seek (pos levs₂)
+    . partialMkLevels
+    $ allLevels levs₁ <> allLevels levs₂
+
+-- | Make Levels from a Seq. Throws an error if the seq is not empty
+partialMkLevels :: Seq a -> Levels a
+partialMkLevels = Levels . fromJust . zipper
+
+-- | Make Levels from a possibly-empty structure
+mkLevels :: Foldable1 f => f level -> Maybe (Levels level)
+mkLevels = fmap Levels . zipper . foldMap pure
+
+-- | Make Levels from a non-empty structure
+mkLevels1 :: Foldable1 f => f level -> Levels level
+mkLevels1 = fromJust . mkLevels
+
+oneLevel :: a -> Levels a
+oneLevel = mkLevels1 . Identity
+
+-- | Get a sequence of all the levels
+allLevels :: Levels a -> Seq a
+allLevels = unzipper . levelZipper
+
+-- | Step to the next level, generating a new level if necessary using the given
+-- applicative action
+nextLevel
+  :: Applicative m
+  => m level -- ^ Generate a new level, if necessary
+  -> Levels level
+  -> m (Levels level)
+nextLevel genLevel levs
+  | pos levs + 1 < size (levelZipper levs)
+  = pure $ seeks succ levs
+  | otherwise
+  = genLevel <&> \level ->
+      seek (pos levs + 1) . partialMkLevels $ level <| allLevels levs
+
+-- | Go to the previous level. Returns Nothing if 'pos' is 0
+prevLevel :: Levels level -> Maybe (Levels level)
+prevLevel levs | pos levs == 0 = Nothing
+               | otherwise = Just $ seeks pred levs
+
+--------------------------------------------------------------------------------
+
+-- | alternate, slower representation of Levels we can Iso into to perform
+-- various operations
+data AltLevels a = AltLevels
+  { _levels :: NonEmpty a
+  , _currentLevel :: Int -- ^ invariant: is within the bounds of _levels
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           (AltLevels a)
+makeLenses ''AltLevels
+
+alt :: Iso (Levels a) (Levels b) (AltLevels a) (AltLevels b)
+alt = iso hither yon
+  where
+    hither levs = AltLevels (NE.fromList . toList $ allLevels levs) (pos levs)
+    yon (AltLevels levs curr) = seek curr $ mkLevels1 levs
+
+instance Eq a => Eq (Levels a) where
+  (==) = (==) `on` view alt
+
+deriving via EqEqProp (Levels a) instance Eq a => EqProp (Levels a)
+
+instance Show a => Show (Levels a) where
+  show = unpack . replace "AltLevels" "Levels" . pack . show . view alt
+
+instance NFData a => NFData (Levels a) where
+  rnf = rnf . view alt
+
+instance ToJSON a => ToJSON (Levels a) where
+  toJSON = toJSON . view alt
+
+instance FromJSON a => FromJSON (Levels a) where
+  parseJSON = fmap (review alt) . parseJSON
+
+instance Arbitrary a => Arbitrary (AltLevels a) where
+  arbitrary = do
+    _levels <- arbitrary
+    _currentLevel <- choose (0, length _levels - 1)
+    pure AltLevels {..}
+  shrink als = do
+    _levels <- shrink $ als ^. levels
+    _currentLevel <- filter (between 0 $ length _levels - 1)
+                    $ shrink $ als ^. currentLevel
+    pure AltLevels {..}
+
+
+instance Arbitrary a => Arbitrary (Levels a) where
+  arbitrary = review alt <$> arbitrary
+  shrink = fmap (review alt) . shrink . view alt
+
+instance CoArbitrary a => CoArbitrary (Levels a) where
+  coarbitrary = coarbitrary . view alt
+
+instance Function a => Function (Levels a) where
+  function = functionMap (view alt) (review alt)

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

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

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

src/Xanthous/Util/Comonad.hs

@@ -0,0 +1,24 @@
+--------------------------------------------------------------------------------
+module Xanthous.Util.Comonad
+  ( -- * Store comonad utils
+    replace
+  , current
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Control.Comonad.Store.Class
+--------------------------------------------------------------------------------
+
+-- | Replace the current position of a store comonad with a new value by
+-- comparing positions
+replace :: (Eq i, ComonadStore i w) => w a -> a -> w a
+replace w x = w =>> \w' -> if pos w' == pos w then x else extract w'
+{-# INLINE replace #-}
+
+-- | Lens into the current position of a store comonad.
+--
+--     current = lens extract replace
+current :: (Eq i, ComonadStore i w) => Lens' (w a) a
+current = lens extract replace
+{-# INLINE current #-}