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.
This commit is contained in:
Griffin Smith 2020-01-04 23:48:51 -05:00
parent e669b54f0c
commit 6b0bab0e85
11 changed files with 397 additions and 14 deletions

View file

@ -0,0 +1,92 @@
diff --git a/comonad-extras.cabal b/comonad-extras.cabal
index fc3745a..77a2f0d 100644
--- a/comonad-extras.cabal
+++ b/comonad-extras.cabal
@@ -1,7 +1,7 @@
name: comonad-extras
category: Control, Comonads
-version: 4.0
+version: 5.0
x-revision: 1
license: BSD3
cabal-version: >= 1.6
license-file: LICENSE
@@ -34,8 +34,8 @@ library
build-depends:
array >= 0.3 && < 0.6,
- base >= 4 && < 4.7,
- containers >= 0.4 && < 0.6,
- comonad >= 4 && < 5,
+ base >= 4 && < 5,
+ containers >= 0.6 && < 0.7,
+ comonad >= 5 && < 6,
distributive >= 0.3.2 && < 1,
- semigroupoids >= 4 && < 5,
- transformers >= 0.2 && < 0.4
+ semigroupoids >= 5 && < 6,
+ transformers >= 0.5 && < 0.6
exposed-modules:
Control.Comonad.Store.Zipper
diff --git a/src/Control/Comonad/Store/Pointer.hs b/src/Control/Comonad/Store/Pointer.hs
index 5044a1e..8d4c62d 100644
--- a/src/Control/Comonad/Store/Pointer.hs
+++ b/src/Control/Comonad/Store/Pointer.hs
@@ -41,7 +41,6 @@ module Control.Comonad.Store.Pointer
, module Control.Comonad.Store.Class
) where
-import Control.Applicative
import Control.Comonad
import Control.Comonad.Hoist.Class
import Control.Comonad.Trans.Class
@@ -51,27 +50,8 @@ import Control.Comonad.Env.Class
import Data.Functor.Identity
import Data.Functor.Extend
import Data.Array
-
#ifdef __GLASGOW_HASKELL__
import Data.Typeable
-instance (Typeable i, Typeable1 w) => Typeable1 (PointerT i w) where
- typeOf1 diwa = mkTyConApp storeTTyCon [typeOf (i diwa), typeOf1 (w diwa)]
- where
- i :: PointerT i w a -> i
- i = undefined
- w :: PointerT i w a -> w a
- w = undefined
-
-instance (Typeable i, Typeable1 w, Typeable a) => Typeable (PointerT i w a) where
- typeOf = typeOfDefault
-
-storeTTyCon :: TyCon
-#if __GLASGOW_HASKELL__ < 704
-storeTTyCon = mkTyCon "Control.Comonad.Trans.Store.Pointer.PointerT"
-#else
-storeTTyCon = mkTyCon3 "comonad-extras" "Control.Comonad.Trans.Store.Pointer" "PointerT"
-#endif
-{-# NOINLINE storeTTyCon #-}
#endif
type Pointer i = PointerT i Identity
@@ -83,6 +63,9 @@ runPointer :: Pointer i a -> (Array i a, i)
runPointer (PointerT (Identity f) i) = (f, i)
data PointerT i w a = PointerT (w (Array i a)) i
+#ifdef __GLASGOW_HASKELL__
+ deriving Typeable
+#endif
runPointerT :: PointerT i w a -> (w (Array i a), i)
runPointerT (PointerT g i) = (g, i)
diff --git a/src/Control/Comonad/Store/Zipper.hs b/src/Control/Comonad/Store/Zipper.hs
index 3b70c86..decc378 100644
--- a/src/Control/Comonad/Store/Zipper.hs
+++ b/src/Control/Comonad/Store/Zipper.hs
@@ -15,7 +15,6 @@
module Control.Comonad.Store.Zipper
( Zipper, zipper, zipper1, unzipper, size) where
-import Control.Applicative
import Control.Comonad (Comonad(..))
import Data.Functor.Extend
import Data.Foldable

View file

@ -29,4 +29,7 @@ in self: super: with pkgs.haskell.lib; rec {
};
version = "0.12.0";
};
comonad-extras = appendPatch (markUnbroken super.comonad-extras)
[ ./build/update-comonad-extras.patch ];
}

View file

@ -26,6 +26,7 @@ dependencies:
- checkers
- classy-prelude
- comonad
- comonad-extras
- constraints
- containers
- data-default
@ -48,6 +49,7 @@ dependencies:
- MonadRandom
- mtl
- optparse-applicative
- pointed
- random
- random-fu
- random-extras
@ -59,6 +61,7 @@ dependencies:
- stache
- semigroupoids
- tomland
- text
- text-zipper
- vector
- vty

170
src/Xanthous/Data/Levels.hs Normal file
View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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 #-}

View file

@ -1,7 +1,10 @@
import Test.Prelude
--------------------------------------------------------------------------------
import Test.Prelude
--------------------------------------------------------------------------------
import qualified Xanthous.Data.EntityCharSpec
import qualified Xanthous.Data.EntityMapSpec
import qualified Xanthous.Data.EntityMap.GraphicsSpec
import qualified Xanthous.Data.LevelsSpec
import qualified Xanthous.DataSpec
import qualified Xanthous.Entities.RawsSpec
import qualified Xanthous.GameSpec
@ -12,6 +15,7 @@ import qualified Xanthous.Util.GraphicsSpec
import qualified Xanthous.Util.GraphSpec
import qualified Xanthous.Util.InflectionSpec
import qualified Xanthous.UtilSpec
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMain test
@ -21,6 +25,7 @@ test = testGroup "Xanthous"
[ Xanthous.Data.EntityCharSpec.test
, Xanthous.Data.EntityMapSpec.test
, Xanthous.Data.EntityMap.GraphicsSpec.test
, Xanthous.Data.LevelsSpec.test
, Xanthous.Entities.RawsSpec.test
, Xanthous.GameSpec.test
, Xanthous.Generators.UtilSpec.test

View file

@ -0,0 +1,60 @@
--------------------------------------------------------------------------------
module Xanthous.Data.LevelsSpec (main, test) where
--------------------------------------------------------------------------------
import Test.Prelude hiding (levels)
--------------------------------------------------------------------------------
import qualified Data.Aeson as JSON
--------------------------------------------------------------------------------
import Xanthous.Util (between)
import Xanthous.Data.Levels
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMain test
test :: TestTree
test = testGroup "Xanthous.Data.Levels"
[ testGroup "current"
[ testProperty "view is extract" $ \(levels :: Levels Int) ->
levels ^. current === extract levels
, testProperty "set replaces current" $ \(levels :: Levels Int) new ->
extract (set current new levels) === new
, testProperty "set extract is id" $ \(levels :: Levels Int) ->
set current (extract levels) levels === levels
, testProperty "set y ∘ set x ≡ set y" $ \(levels :: Levels Int) x y ->
set current y (set current x levels) === set current y levels
]
, localOption (QuickCheckTests 20)
$ testBatch $ semigroup @(Levels Int) (error "unused", 1 :: Int)
, testGroup "next/prev"
[ testGroup "nextLevel"
[ testProperty "seeks forwards" $ \(levels :: Levels Int) genned ->
(pos . runIdentity . nextLevel (Identity genned) $ levels)
=== pos levels + 1
, testProperty "maintains the invariant" $ \(levels :: Levels Int) genned ->
let levels' = runIdentity . nextLevel (Identity genned) $ levels
in between 0 (length levels') $ pos levels'
, testProperty "extract is total" $ \(levels :: Levels Int) genned ->
let levels' = runIdentity . nextLevel (Identity genned) $ levels
in total $ extract levels'
]
, testGroup "prevLevel"
[ testProperty "seeks backwards" $ \(levels :: Levels Int) ->
case prevLevel levels of
Nothing -> property Discard
Just levels' -> pos levels' === pos levels - 1
, testProperty "maintains the invariant" $ \(levels :: Levels Int) ->
case prevLevel levels of
Nothing -> property Discard
Just levels' -> property $ between 0 (length levels') $ pos levels'
, testProperty "extract is total" $ \(levels :: Levels Int) ->
case prevLevel levels of
Nothing -> property Discard
Just levels' -> total $ extract levels'
]
]
, testGroup "JSON"
[ testProperty "toJSON/parseJSON round-trip" $ \(levels :: Levels Int) ->
JSON.decode (JSON.encode levels) === Just levels
]
]

View file

@ -4,7 +4,7 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
-- hash: 36af39a9e3b4e97923c1b363d7d84e2c99f126efd908778d0d048d0c472f2723
-- hash: eb0a7cd56cc2ea885be582c8ea7113a5f50f96a8d1b12ed27ca1a0271a45ad03
name: xanthous
version: 0.1.0.0
@ -37,6 +37,7 @@ library
Xanthous.Data.EntityChar
Xanthous.Data.EntityMap
Xanthous.Data.EntityMap.Graphics
Xanthous.Data.Levels
Xanthous.Data.VectorBag
Xanthous.Entities.Character
Xanthous.Entities.Creature
@ -65,6 +66,7 @@ library
Xanthous.Random
Xanthous.Resource
Xanthous.Util
Xanthous.Util.Comonad
Xanthous.Util.Graph
Xanthous.Util.Graphics
Xanthous.Util.Inflection
@ -89,6 +91,7 @@ library
, checkers
, classy-prelude
, comonad
, comonad-extras
, constraints
, containers
, data-default
@ -109,6 +112,7 @@ library
, megaparsec
, mtl
, optparse-applicative
, pointed
, quickcheck-instances
, quickcheck-text
, random
@ -120,6 +124,7 @@ library
, semigroupoids
, stache
, streams
, text
, text-zipper
, tomland
, vector
@ -139,6 +144,7 @@ executable xanthous
Xanthous.Data.EntityChar
Xanthous.Data.EntityMap
Xanthous.Data.EntityMap.Graphics
Xanthous.Data.Levels
Xanthous.Data.VectorBag
Xanthous.Entities.Character
Xanthous.Entities.Creature
@ -167,6 +173,7 @@ executable xanthous
Xanthous.Random
Xanthous.Resource
Xanthous.Util
Xanthous.Util.Comonad
Xanthous.Util.Graph
Xanthous.Util.Graphics
Xanthous.Util.Inflection
@ -190,6 +197,7 @@ executable xanthous
, checkers
, classy-prelude
, comonad
, comonad-extras
, constraints
, containers
, data-default
@ -210,6 +218,7 @@ executable xanthous
, megaparsec
, mtl
, optparse-applicative
, pointed
, quickcheck-instances
, quickcheck-text
, random
@ -221,6 +230,7 @@ executable xanthous
, semigroupoids
, stache
, streams
, text
, text-zipper
, tomland
, vector
@ -238,6 +248,7 @@ test-suite test
Xanthous.Data.EntityCharSpec
Xanthous.Data.EntityMap.GraphicsSpec
Xanthous.Data.EntityMapSpec
Xanthous.Data.LevelsSpec
Xanthous.DataSpec
Xanthous.Entities.RawsSpec
Xanthous.GameSpec
@ -265,6 +276,7 @@ test-suite test
, checkers
, classy-prelude
, comonad
, comonad-extras
, constraints
, containers
, data-default
@ -286,6 +298,7 @@ test-suite test
, megaparsec
, mtl
, optparse-applicative
, pointed
, quickcheck-instances
, quickcheck-text
, random
@ -300,6 +313,7 @@ test-suite test
, tasty
, tasty-hunit
, tasty-quickcheck
, text
, text-zipper
, tomland
, vector