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:
parent
e669b54f0c
commit
6b0bab0e85
11 changed files with 397 additions and 14 deletions
92
build/update-comonad-extras.patch
Normal file
92
build/update-comonad-extras.patch
Normal 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
|
|
@ -29,4 +29,7 @@ in self: super: with pkgs.haskell.lib; rec {
|
||||||
};
|
};
|
||||||
version = "0.12.0";
|
version = "0.12.0";
|
||||||
};
|
};
|
||||||
|
|
||||||
|
comonad-extras = appendPatch (markUnbroken super.comonad-extras)
|
||||||
|
[ ./build/update-comonad-extras.patch ];
|
||||||
}
|
}
|
||||||
|
|
|
@ -26,6 +26,7 @@ dependencies:
|
||||||
- checkers
|
- checkers
|
||||||
- classy-prelude
|
- classy-prelude
|
||||||
- comonad
|
- comonad
|
||||||
|
- comonad-extras
|
||||||
- constraints
|
- constraints
|
||||||
- containers
|
- containers
|
||||||
- data-default
|
- data-default
|
||||||
|
@ -48,6 +49,7 @@ dependencies:
|
||||||
- MonadRandom
|
- MonadRandom
|
||||||
- mtl
|
- mtl
|
||||||
- optparse-applicative
|
- optparse-applicative
|
||||||
|
- pointed
|
||||||
- random
|
- random
|
||||||
- random-fu
|
- random-fu
|
||||||
- random-extras
|
- random-extras
|
||||||
|
@ -59,6 +61,7 @@ dependencies:
|
||||||
- stache
|
- stache
|
||||||
- semigroupoids
|
- semigroupoids
|
||||||
- tomland
|
- tomland
|
||||||
|
- text
|
||||||
- text-zipper
|
- text-zipper
|
||||||
- vector
|
- vector
|
||||||
- vty
|
- vty
|
||||||
|
|
170
src/Xanthous/Data/Levels.hs
Normal file
170
src/Xanthous/Data/Levels.hs
Normal 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)
|
|
@ -5,15 +5,17 @@
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
module Xanthous.Game.Arbitrary where
|
module Xanthous.Game.Arbitrary where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Prelude
|
import Xanthous.Prelude hiding (levels, foldMap)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
import System.Random
|
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.Entities ()
|
||||||
import Xanthous.Entities.Character
|
import Xanthous.Entities.Character
|
||||||
import qualified Xanthous.Data.EntityMap as EntityMap
|
import Xanthous.Game.State
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
instance Arbitrary GameState where
|
instance Arbitrary GameState where
|
||||||
|
@ -21,9 +23,13 @@ instance Arbitrary GameState where
|
||||||
chr <- arbitrary @Character
|
chr <- arbitrary @Character
|
||||||
charPos <- arbitrary
|
charPos <- arbitrary
|
||||||
_messageHistory <- arbitrary
|
_messageHistory <- arbitrary
|
||||||
(_characterEntityID, _entities) <- arbitrary <&>
|
levels <- arbitrary
|
||||||
EntityMap.insertAtReturningID charPos (SomeEntity chr)
|
let (_characterEntityID, currentLevel) =
|
||||||
_revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities
|
EntityMap.insertAtReturningID charPos (SomeEntity chr)
|
||||||
|
$ extract levels
|
||||||
|
_levels = levels & current .~ currentLevel
|
||||||
|
_revealedPositions <- fmap setFromList . sublistOf
|
||||||
|
$ foldMap EntityMap.positions levels
|
||||||
_randomGen <- mkStdGen <$> arbitrary
|
_randomGen <- mkStdGen <$> arbitrary
|
||||||
let _promptState = NoPrompt -- TODO
|
let _promptState = NoPrompt -- TODO
|
||||||
_activePanel <- arbitrary
|
_activePanel <- arbitrary
|
||||||
|
|
|
@ -25,6 +25,7 @@ import Control.Monad.Random (getRandom)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Game.State
|
import Xanthous.Game.State
|
||||||
import Xanthous.Data
|
import Xanthous.Data
|
||||||
|
import Xanthous.Data.Levels
|
||||||
import qualified Xanthous.Data.EntityMap as EntityMap
|
import qualified Xanthous.Data.EntityMap as EntityMap
|
||||||
import Xanthous.Data.EntityMap.Graphics (visiblePositions)
|
import Xanthous.Data.EntityMap.Graphics (visiblePositions)
|
||||||
import Xanthous.Entities.Character (Character, mkCharacter)
|
import Xanthous.Entities.Character (Character, mkCharacter)
|
||||||
|
@ -38,11 +39,12 @@ initialStateFromSeed :: Int -> GameState
|
||||||
initialStateFromSeed seed =
|
initialStateFromSeed seed =
|
||||||
let _randomGen = mkStdGen seed
|
let _randomGen = mkStdGen seed
|
||||||
chr = mkCharacter
|
chr = mkCharacter
|
||||||
(_characterEntityID, _entities)
|
(_characterEntityID, level)
|
||||||
= EntityMap.insertAtReturningID
|
= EntityMap.insertAtReturningID
|
||||||
(Position 0 0)
|
(Position 0 0)
|
||||||
(SomeEntity chr)
|
(SomeEntity chr)
|
||||||
mempty
|
mempty
|
||||||
|
_levels = oneLevel level
|
||||||
_messageHistory = mempty
|
_messageHistory = mempty
|
||||||
_revealedPositions = mempty
|
_revealedPositions = mempty
|
||||||
_promptState = NoPrompt
|
_promptState = NoPrompt
|
||||||
|
@ -108,4 +110,4 @@ entitiesCollision
|
||||||
entitiesCollision = join . maximumMay . fmap entityCollision
|
entitiesCollision = join . maximumMay . fmap entityCollision
|
||||||
|
|
||||||
collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
|
collisionAt :: MonadState GameState m => Position -> m (Maybe Collision)
|
||||||
collisionAt pos = uses (entities . EntityMap.atPosition pos) entitiesCollision
|
collisionAt p = uses (entities . EntityMap.atPosition p) entitiesCollision
|
||||||
|
|
|
@ -58,7 +58,7 @@ module Xanthous.Game.State
|
||||||
, allRevealed
|
, allRevealed
|
||||||
) where
|
) where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Prelude
|
import Xanthous.Prelude hiding (levels)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Data.List.NonEmpty ( NonEmpty((:|)))
|
import Data.List.NonEmpty ( NonEmpty((:|)))
|
||||||
import qualified Data.List.NonEmpty as 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.Util (KnownBool(..))
|
||||||
import Xanthous.Data
|
import Xanthous.Data
|
||||||
|
import Xanthous.Data.Levels
|
||||||
import Xanthous.Data.EntityMap (EntityMap, EntityID)
|
import Xanthous.Data.EntityMap (EntityMap, EntityID)
|
||||||
import Xanthous.Data.EntityChar
|
import Xanthous.Data.EntityChar
|
||||||
import Xanthous.Data.VectorBag
|
import Xanthous.Data.VectorBag
|
||||||
|
@ -359,8 +360,8 @@ instance Draw SomeEntity where
|
||||||
drawPriority (SomeEntity ent) = drawPriority ent
|
drawPriority (SomeEntity ent) = drawPriority ent
|
||||||
|
|
||||||
instance Brain SomeEntity where
|
instance Brain SomeEntity where
|
||||||
step ticks (Positioned pos (SomeEntity ent)) =
|
step ticks (Positioned p (SomeEntity ent)) =
|
||||||
fmap SomeEntity <$> step ticks (Positioned pos ent)
|
fmap SomeEntity <$> step ticks (Positioned p ent)
|
||||||
|
|
||||||
downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a
|
downcastEntity :: forall (a :: Type). (Typeable a) => SomeEntity -> Maybe a
|
||||||
downcastEntity (SomeEntity e) = cast e
|
downcastEntity (SomeEntity e) = cast e
|
||||||
|
@ -413,7 +414,7 @@ instance Arbitrary DebugState where
|
||||||
arbitrary = genericArbitrary
|
arbitrary = genericArbitrary
|
||||||
|
|
||||||
data GameState = GameState
|
data GameState = GameState
|
||||||
{ _entities :: !(EntityMap SomeEntity)
|
{ _levels :: !(Levels (EntityMap SomeEntity))
|
||||||
, _revealedPositions :: !(Set Position)
|
, _revealedPositions :: !(Set Position)
|
||||||
, _characterEntityID :: !EntityID
|
, _characterEntityID :: !EntityID
|
||||||
, _messageHistory :: !MessageHistory
|
, _messageHistory :: !MessageHistory
|
||||||
|
@ -433,6 +434,9 @@ data GameState = GameState
|
||||||
GameState
|
GameState
|
||||||
makeLenses ''GameState
|
makeLenses ''GameState
|
||||||
|
|
||||||
|
entities :: Lens' GameState (EntityMap SomeEntity)
|
||||||
|
entities = levels . current
|
||||||
|
|
||||||
instance Eq GameState where
|
instance Eq GameState where
|
||||||
(==) = (==) `on` \gs ->
|
(==) = (==) `on` \gs ->
|
||||||
( gs ^. entities
|
( gs ^. entities
|
||||||
|
|
24
src/Xanthous/Util/Comonad.hs
Normal file
24
src/Xanthous/Util/Comonad.hs
Normal 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 #-}
|
|
@ -1,7 +1,10 @@
|
||||||
import Test.Prelude
|
--------------------------------------------------------------------------------
|
||||||
|
import Test.Prelude
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
import qualified Xanthous.Data.EntityCharSpec
|
import qualified Xanthous.Data.EntityCharSpec
|
||||||
import qualified Xanthous.Data.EntityMapSpec
|
import qualified Xanthous.Data.EntityMapSpec
|
||||||
import qualified Xanthous.Data.EntityMap.GraphicsSpec
|
import qualified Xanthous.Data.EntityMap.GraphicsSpec
|
||||||
|
import qualified Xanthous.Data.LevelsSpec
|
||||||
import qualified Xanthous.DataSpec
|
import qualified Xanthous.DataSpec
|
||||||
import qualified Xanthous.Entities.RawsSpec
|
import qualified Xanthous.Entities.RawsSpec
|
||||||
import qualified Xanthous.GameSpec
|
import qualified Xanthous.GameSpec
|
||||||
|
@ -12,6 +15,7 @@ import qualified Xanthous.Util.GraphicsSpec
|
||||||
import qualified Xanthous.Util.GraphSpec
|
import qualified Xanthous.Util.GraphSpec
|
||||||
import qualified Xanthous.Util.InflectionSpec
|
import qualified Xanthous.Util.InflectionSpec
|
||||||
import qualified Xanthous.UtilSpec
|
import qualified Xanthous.UtilSpec
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = defaultMain test
|
main = defaultMain test
|
||||||
|
@ -21,6 +25,7 @@ test = testGroup "Xanthous"
|
||||||
[ Xanthous.Data.EntityCharSpec.test
|
[ Xanthous.Data.EntityCharSpec.test
|
||||||
, Xanthous.Data.EntityMapSpec.test
|
, Xanthous.Data.EntityMapSpec.test
|
||||||
, Xanthous.Data.EntityMap.GraphicsSpec.test
|
, Xanthous.Data.EntityMap.GraphicsSpec.test
|
||||||
|
, Xanthous.Data.LevelsSpec.test
|
||||||
, Xanthous.Entities.RawsSpec.test
|
, Xanthous.Entities.RawsSpec.test
|
||||||
, Xanthous.GameSpec.test
|
, Xanthous.GameSpec.test
|
||||||
, Xanthous.Generators.UtilSpec.test
|
, Xanthous.Generators.UtilSpec.test
|
||||||
|
|
60
test/Xanthous/Data/LevelsSpec.hs
Normal file
60
test/Xanthous/Data/LevelsSpec.hs
Normal 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
|
||||||
|
]
|
||||||
|
]
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 36af39a9e3b4e97923c1b363d7d84e2c99f126efd908778d0d048d0c472f2723
|
-- hash: eb0a7cd56cc2ea885be582c8ea7113a5f50f96a8d1b12ed27ca1a0271a45ad03
|
||||||
|
|
||||||
name: xanthous
|
name: xanthous
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
@ -37,6 +37,7 @@ library
|
||||||
Xanthous.Data.EntityChar
|
Xanthous.Data.EntityChar
|
||||||
Xanthous.Data.EntityMap
|
Xanthous.Data.EntityMap
|
||||||
Xanthous.Data.EntityMap.Graphics
|
Xanthous.Data.EntityMap.Graphics
|
||||||
|
Xanthous.Data.Levels
|
||||||
Xanthous.Data.VectorBag
|
Xanthous.Data.VectorBag
|
||||||
Xanthous.Entities.Character
|
Xanthous.Entities.Character
|
||||||
Xanthous.Entities.Creature
|
Xanthous.Entities.Creature
|
||||||
|
@ -65,6 +66,7 @@ library
|
||||||
Xanthous.Random
|
Xanthous.Random
|
||||||
Xanthous.Resource
|
Xanthous.Resource
|
||||||
Xanthous.Util
|
Xanthous.Util
|
||||||
|
Xanthous.Util.Comonad
|
||||||
Xanthous.Util.Graph
|
Xanthous.Util.Graph
|
||||||
Xanthous.Util.Graphics
|
Xanthous.Util.Graphics
|
||||||
Xanthous.Util.Inflection
|
Xanthous.Util.Inflection
|
||||||
|
@ -89,6 +91,7 @@ library
|
||||||
, checkers
|
, checkers
|
||||||
, classy-prelude
|
, classy-prelude
|
||||||
, comonad
|
, comonad
|
||||||
|
, comonad-extras
|
||||||
, constraints
|
, constraints
|
||||||
, containers
|
, containers
|
||||||
, data-default
|
, data-default
|
||||||
|
@ -109,6 +112,7 @@ library
|
||||||
, megaparsec
|
, megaparsec
|
||||||
, mtl
|
, mtl
|
||||||
, optparse-applicative
|
, optparse-applicative
|
||||||
|
, pointed
|
||||||
, quickcheck-instances
|
, quickcheck-instances
|
||||||
, quickcheck-text
|
, quickcheck-text
|
||||||
, random
|
, random
|
||||||
|
@ -120,6 +124,7 @@ library
|
||||||
, semigroupoids
|
, semigroupoids
|
||||||
, stache
|
, stache
|
||||||
, streams
|
, streams
|
||||||
|
, text
|
||||||
, text-zipper
|
, text-zipper
|
||||||
, tomland
|
, tomland
|
||||||
, vector
|
, vector
|
||||||
|
@ -139,6 +144,7 @@ executable xanthous
|
||||||
Xanthous.Data.EntityChar
|
Xanthous.Data.EntityChar
|
||||||
Xanthous.Data.EntityMap
|
Xanthous.Data.EntityMap
|
||||||
Xanthous.Data.EntityMap.Graphics
|
Xanthous.Data.EntityMap.Graphics
|
||||||
|
Xanthous.Data.Levels
|
||||||
Xanthous.Data.VectorBag
|
Xanthous.Data.VectorBag
|
||||||
Xanthous.Entities.Character
|
Xanthous.Entities.Character
|
||||||
Xanthous.Entities.Creature
|
Xanthous.Entities.Creature
|
||||||
|
@ -167,6 +173,7 @@ executable xanthous
|
||||||
Xanthous.Random
|
Xanthous.Random
|
||||||
Xanthous.Resource
|
Xanthous.Resource
|
||||||
Xanthous.Util
|
Xanthous.Util
|
||||||
|
Xanthous.Util.Comonad
|
||||||
Xanthous.Util.Graph
|
Xanthous.Util.Graph
|
||||||
Xanthous.Util.Graphics
|
Xanthous.Util.Graphics
|
||||||
Xanthous.Util.Inflection
|
Xanthous.Util.Inflection
|
||||||
|
@ -190,6 +197,7 @@ executable xanthous
|
||||||
, checkers
|
, checkers
|
||||||
, classy-prelude
|
, classy-prelude
|
||||||
, comonad
|
, comonad
|
||||||
|
, comonad-extras
|
||||||
, constraints
|
, constraints
|
||||||
, containers
|
, containers
|
||||||
, data-default
|
, data-default
|
||||||
|
@ -210,6 +218,7 @@ executable xanthous
|
||||||
, megaparsec
|
, megaparsec
|
||||||
, mtl
|
, mtl
|
||||||
, optparse-applicative
|
, optparse-applicative
|
||||||
|
, pointed
|
||||||
, quickcheck-instances
|
, quickcheck-instances
|
||||||
, quickcheck-text
|
, quickcheck-text
|
||||||
, random
|
, random
|
||||||
|
@ -221,6 +230,7 @@ executable xanthous
|
||||||
, semigroupoids
|
, semigroupoids
|
||||||
, stache
|
, stache
|
||||||
, streams
|
, streams
|
||||||
|
, text
|
||||||
, text-zipper
|
, text-zipper
|
||||||
, tomland
|
, tomland
|
||||||
, vector
|
, vector
|
||||||
|
@ -238,6 +248,7 @@ test-suite test
|
||||||
Xanthous.Data.EntityCharSpec
|
Xanthous.Data.EntityCharSpec
|
||||||
Xanthous.Data.EntityMap.GraphicsSpec
|
Xanthous.Data.EntityMap.GraphicsSpec
|
||||||
Xanthous.Data.EntityMapSpec
|
Xanthous.Data.EntityMapSpec
|
||||||
|
Xanthous.Data.LevelsSpec
|
||||||
Xanthous.DataSpec
|
Xanthous.DataSpec
|
||||||
Xanthous.Entities.RawsSpec
|
Xanthous.Entities.RawsSpec
|
||||||
Xanthous.GameSpec
|
Xanthous.GameSpec
|
||||||
|
@ -265,6 +276,7 @@ test-suite test
|
||||||
, checkers
|
, checkers
|
||||||
, classy-prelude
|
, classy-prelude
|
||||||
, comonad
|
, comonad
|
||||||
|
, comonad-extras
|
||||||
, constraints
|
, constraints
|
||||||
, containers
|
, containers
|
||||||
, data-default
|
, data-default
|
||||||
|
@ -286,6 +298,7 @@ test-suite test
|
||||||
, megaparsec
|
, megaparsec
|
||||||
, mtl
|
, mtl
|
||||||
, optparse-applicative
|
, optparse-applicative
|
||||||
|
, pointed
|
||||||
, quickcheck-instances
|
, quickcheck-instances
|
||||||
, quickcheck-text
|
, quickcheck-text
|
||||||
, random
|
, random
|
||||||
|
@ -300,6 +313,7 @@ test-suite test
|
||||||
, tasty
|
, tasty
|
||||||
, tasty-hunit
|
, tasty-hunit
|
||||||
, tasty-quickcheck
|
, tasty-quickcheck
|
||||||
|
, text
|
||||||
, text-zipper
|
, text-zipper
|
||||||
, tomland
|
, tomland
|
||||||
, vector
|
, vector
|
||||||
|
|
Loading…
Add table
Reference in a new issue