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";
|
||||
};
|
||||
|
||||
comonad-extras = appendPatch (markUnbroken super.comonad-extras)
|
||||
[ ./build/update-comonad-extras.patch ];
|
||||
}
|
||||
|
|
|
@ -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
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
|
||||
--------------------------------------------------------------------------------
|
||||
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
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.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
|
||||
|
|
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
|
||||
--
|
||||
-- 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
|
||||
|
|
Loading…
Reference in a new issue