feat(xanthous): Memoize characterVisiblePositions

Memoize the return value of characterVisiblePositions to a new,
semi-abstracted "memo" field on the GameState, recalcuclated if the
character position ever changes. I'm 90% sure that the perf issues we
were encountering were actually caused by characterVisiblePositions
getting called once for *every tile* on draw, but this slightly larger
change also makes the game perform relatively-usably again.

Since this is only recalculated if the character position changes, if we
ever get non-transparent entities moving around without the characters
influence (maybe something building or knocking down walls?) we'll have
an issue there where the vision won't be updated as a result of those
changes if they happen while the character is taking a non-moving action
- but we can cross that bridge when we come to it.

Change-Id: I3fc745ddf0014d6f164f735ad7e5080da779b92a
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3185
Reviewed-by: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI
This commit is contained in:
Griffin Smith 2021-06-12 14:41:24 -04:00 committed by grfn
parent 80d501d553
commit c19e3dae5f
14 changed files with 284 additions and 87 deletions

View file

@ -40,7 +40,6 @@ dependencies:
- file-embed - file-embed
- filepath - filepath
- generic-arbitrary - generic-arbitrary
- generic-monoid
- generic-lens - generic-lens
- groups - groups
- hgeometry - hgeometry
@ -68,6 +67,7 @@ dependencies:
- splitmix - splitmix
- streams - streams
- stache - stache
- semigroups
- semigroupoids - semigroupoids
- tomland - tomland
- transformers - transformers

View file

@ -2,13 +2,13 @@
, checkers, classy-prelude, comonad, comonad-extras, constraints , checkers, classy-prelude, comonad, comonad-extras, constraints
, containers, criterion, data-default, deepseq, directory, fgl , containers, criterion, data-default, deepseq, directory, fgl
, fgl-arbitrary, file-embed, filepath, generic-arbitrary , fgl-arbitrary, file-embed, filepath, generic-arbitrary
, generic-lens, generic-monoid, groups, hgeometry , generic-lens, groups, hgeometry, hgeometry-combinatorial, hpack
, hgeometry-combinatorial, hpack, JuicyPixels, lens , JuicyPixels, lens, lens-properties, lib, lifted-async, linear
, lens-properties, lib, lifted-async, linear, megaparsec, mmorph , megaparsec, mmorph, monad-control, MonadRandom, mtl
, monad-control, MonadRandom, mtl, optparse-applicative, parallel , optparse-applicative, parallel, parser-combinators, pointed
, parser-combinators, pointed, QuickCheck, quickcheck-instances , QuickCheck, quickcheck-instances, quickcheck-text, random
, quickcheck-text, random, random-extras, random-fu, random-source , random-extras, random-fu, random-source, Rasterific
, Rasterific, raw-strings-qq, reflection, semigroupoids, splitmix , raw-strings-qq, reflection, semigroupoids, semigroups, splitmix
, stache, streams, tasty, tasty-hunit, tasty-quickcheck, text , stache, streams, tasty, tasty-hunit, tasty-quickcheck, text
, text-zipper, tomland, transformers, vector, vty, witherable, yaml , text-zipper, tomland, transformers, vector, vty, witherable, yaml
, zlib , zlib
@ -23,54 +23,55 @@ mkDerivation {
aeson array async base bifunctors brick checkers classy-prelude aeson array async base bifunctors brick checkers classy-prelude
comonad comonad-extras constraints containers criterion comonad comonad-extras constraints containers criterion
data-default deepseq directory fgl fgl-arbitrary file-embed data-default deepseq directory fgl fgl-arbitrary file-embed
filepath generic-arbitrary generic-lens generic-monoid groups filepath generic-arbitrary generic-lens groups hgeometry
hgeometry hgeometry-combinatorial JuicyPixels lens lifted-async hgeometry-combinatorial JuicyPixels lens lifted-async linear
linear megaparsec mmorph monad-control MonadRandom mtl megaparsec mmorph monad-control MonadRandom mtl
optparse-applicative parallel parser-combinators pointed QuickCheck optparse-applicative parallel parser-combinators pointed QuickCheck
quickcheck-instances quickcheck-text random random-extras random-fu quickcheck-instances quickcheck-text random random-extras random-fu
random-source Rasterific raw-strings-qq reflection semigroupoids random-source Rasterific raw-strings-qq reflection semigroupoids
splitmix stache streams text text-zipper tomland transformers semigroups splitmix stache streams text text-zipper tomland
vector vty witherable yaml zlib transformers vector vty witherable yaml zlib
]; ];
libraryToolDepends = [ hpack ]; libraryToolDepends = [ hpack ];
executableHaskellDepends = [ executableHaskellDepends = [
aeson array async base bifunctors brick checkers classy-prelude aeson array async base bifunctors brick checkers classy-prelude
comonad comonad-extras constraints containers criterion comonad comonad-extras constraints containers criterion
data-default deepseq directory fgl fgl-arbitrary file-embed data-default deepseq directory fgl fgl-arbitrary file-embed
filepath generic-arbitrary generic-lens generic-monoid groups filepath generic-arbitrary generic-lens groups hgeometry
hgeometry hgeometry-combinatorial JuicyPixels lens lifted-async hgeometry-combinatorial JuicyPixels lens lifted-async linear
linear megaparsec mmorph monad-control MonadRandom mtl megaparsec mmorph monad-control MonadRandom mtl
optparse-applicative parallel parser-combinators pointed QuickCheck optparse-applicative parallel parser-combinators pointed QuickCheck
quickcheck-instances quickcheck-text random random-extras random-fu quickcheck-instances quickcheck-text random random-extras random-fu
random-source Rasterific raw-strings-qq reflection semigroupoids random-source Rasterific raw-strings-qq reflection semigroupoids
splitmix stache streams text text-zipper tomland transformers semigroups splitmix stache streams text text-zipper tomland
vector vty witherable yaml zlib transformers vector vty witherable yaml zlib
]; ];
testHaskellDepends = [ testHaskellDepends = [
aeson array async base bifunctors brick checkers classy-prelude aeson array async base bifunctors brick checkers classy-prelude
comonad comonad-extras constraints containers criterion comonad comonad-extras constraints containers criterion
data-default deepseq directory fgl fgl-arbitrary file-embed data-default deepseq directory fgl fgl-arbitrary file-embed
filepath generic-arbitrary generic-lens generic-monoid groups filepath generic-arbitrary generic-lens groups hgeometry
hgeometry hgeometry-combinatorial JuicyPixels lens lens-properties hgeometry-combinatorial JuicyPixels lens lens-properties
lifted-async linear megaparsec mmorph monad-control MonadRandom mtl lifted-async linear megaparsec mmorph monad-control MonadRandom mtl
optparse-applicative parallel parser-combinators pointed QuickCheck optparse-applicative parallel parser-combinators pointed QuickCheck
quickcheck-instances quickcheck-text random random-extras random-fu quickcheck-instances quickcheck-text random random-extras random-fu
random-source Rasterific raw-strings-qq reflection semigroupoids random-source Rasterific raw-strings-qq reflection semigroupoids
splitmix stache streams tasty tasty-hunit tasty-quickcheck text semigroups splitmix stache streams tasty tasty-hunit
text-zipper tomland transformers vector vty witherable yaml zlib tasty-quickcheck text text-zipper tomland transformers vector vty
witherable yaml zlib
]; ];
benchmarkHaskellDepends = [ benchmarkHaskellDepends = [
aeson array async base bifunctors brick checkers classy-prelude aeson array async base bifunctors brick checkers classy-prelude
comonad comonad-extras constraints containers criterion comonad comonad-extras constraints containers criterion
data-default deepseq directory fgl fgl-arbitrary file-embed data-default deepseq directory fgl fgl-arbitrary file-embed
filepath generic-arbitrary generic-lens generic-monoid groups filepath generic-arbitrary generic-lens groups hgeometry
hgeometry hgeometry-combinatorial JuicyPixels lens lifted-async hgeometry-combinatorial JuicyPixels lens lifted-async linear
linear megaparsec mmorph monad-control MonadRandom mtl megaparsec mmorph monad-control MonadRandom mtl
optparse-applicative parallel parser-combinators pointed QuickCheck optparse-applicative parallel parser-combinators pointed QuickCheck
quickcheck-instances quickcheck-text random random-extras random-fu quickcheck-instances quickcheck-text random random-extras random-fu
random-source Rasterific raw-strings-qq reflection semigroupoids random-source Rasterific raw-strings-qq reflection semigroupoids
splitmix stache streams text text-zipper tomland transformers semigroups splitmix stache streams text text-zipper tomland
vector vty witherable yaml zlib transformers vector vty witherable yaml zlib
]; ];
prePatch = "hpack"; prePatch = "hpack";
homepage = "https://github.com/glittershark/xanthous#readme"; homepage = "https://github.com/glittershark/xanthous#readme";

View file

@ -16,5 +16,6 @@ in
hp2pretty hp2pretty
hlint hlint
haskell-language-server haskell-language-server
cabal2nix
]; ];
} }

View file

@ -216,9 +216,7 @@ handleCommand Close = do
handleCommand Look = do handleCommand Look = do
prompt_ @'PointOnMap ["look", "prompt"] Cancellable prompt_ @'PointOnMap ["look", "prompt"] Cancellable
$ \(PointOnMapResult pos) -> $ \(PointOnMapResult pos) -> revealedEntitiesAtPosition pos >>= \case
gets (revealedEntitiesAtPosition pos)
>>= \case
Empty -> say_ ["look", "nothing"] Empty -> say_ ["look", "nothing"]
ents -> describeEntities ents ents -> describeEntities ents
continue continue

View file

@ -0,0 +1,98 @@
--------------------------------------------------------------------------------
-- | Memoized values
--------------------------------------------------------------------------------
module Xanthous.Data.Memo
( Memoized(UnMemoized)
, memoizeWith
, getMemoized
, runMemoized
, fillWith
, fillWithM
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Data.Aeson (FromJSON, ToJSON)
import Test.QuickCheck (Arbitrary (arbitrary), oneof, CoArbitrary, Function)
import Test.QuickCheck.Checkers (EqProp)
import Xanthous.Util (EqEqProp(EqEqProp))
import Control.Monad.State.Class (MonadState)
--------------------------------------------------------------------------------
-- | A memoized value, keyed by a key
--
-- If key is different than what is stored here, then val is invalid
data Memoized key val = Memoized key val | UnMemoized
deriving stock (Show, Eq, Generic)
deriving anyclass (Hashable, FromJSON, ToJSON, NFData, CoArbitrary, Function)
deriving EqProp via EqEqProp (Memoized key val)
instance (Arbitrary k, Arbitrary v) => Arbitrary (Memoized k v) where
arbitrary = oneof [ pure UnMemoized
, Memoized <$> arbitrary <*> arbitrary
]
-- | Construct a memoized value with the given key
memoizeWith :: forall key val. key -> val -> Memoized key val
memoizeWith = Memoized
{-# INLINE memoizeWith #-}
-- | Retrieve a memoized value providing the key. If the value is unmemoized or
-- the keys do not match, returns Nothing.
--
-- >>> getMemoized 1 (memoizeWith @Int @Int 1 2)
-- Just 2
--
-- >>> getMemoized 2 (memoizeWith @Int @Int 1 2)
-- Nothing
--
-- >>> getMemoized 1 (UnMemoized :: Memoized Int Int)
-- Nothing
getMemoized :: Eq key => key -> Memoized key val -> Maybe val
getMemoized key (Memoized key' v)
| key == key' = Just v
| otherwise = Nothing
getMemoized _ UnMemoized = Nothing
{-# INLINE getMemoized #-}
-- | Get a memoized value using an applicative action to obtain the key
runMemoized
:: (Eq key, Applicative m)
=> Memoized key val
-> m key
-> m (Maybe val)
runMemoized m mk = getMemoized <$> mk <*> pure m
-- | In a monadic state containing a 'MemoState', look up the current memoized
-- target of some lens keyed by k, filling it with v if not present and
-- returning either the new or old value
fillWith
:: forall m s k v.
(MonadState s m, Eq k)
=> Lens' s (Memoized k v)
-> k
-> v
-> m v
fillWith l k v' = do
uses l (getMemoized k) >>= \case
Just v -> pure v
Nothing -> do
l .= memoizeWith k v'
pure v'
-- | In a monadic state, look up the current memoized target of some lens keyed
-- by k, filling it with the result of some monadic action v if not present and
-- returning either the new or old value
fillWithM
:: forall m s k v.
(MonadState s m, Eq k)
=> Lens' s (Memoized k v)
-> k
-> m v
-> m v
fillWithM l k mv = do
uses l (getMemoized k) >>= \case
Just v -> pure v
Nothing -> do
v' <- mv
l .= memoizeWith k v'
pure v'

View file

@ -42,6 +42,7 @@ instance Arbitrary GameState where
_activePanel <- arbitrary _activePanel <- arbitrary
_debugState <- arbitrary _debugState <- arbitrary
let _autocommand = NoAutocommand let _autocommand = NoAutocommand
_memo <- arbitrary
pure $ GameState {..} pure $ GameState {..}

View file

@ -23,6 +23,8 @@ import Xanthous.Game
) )
import Xanthous.Game.Prompt import Xanthous.Game.Prompt
import Xanthous.Orphans () import Xanthous.Orphans ()
import Control.Monad.State.Lazy (evalState)
import Control.Monad.State.Class ( get, MonadState, gets )
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
@ -53,29 +55,28 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
str ("[" <> pure chr <> "] ") <+> txtWrap m str ("[" <> pure chr <> "] ") <+> txtWrap m
drawEntities drawEntities
:: GameState :: forall m. MonadState GameState m
-> Widget ResourceName => m (Widget ResourceName)
drawEntities game = vBox rows drawEntities = do
where allEnts <- use entities
allEnts = game ^. entities let entityPositions = EntityMap.positions allEnts
entityPositions = EntityMap.positions allEnts maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions rows = traverse mkRow [0..maxY]
rows = mkRow <$> [0..maxY] mkRow rowY = hBox <$> traverse (renderEntityAt . flip Position rowY) [0..maxX]
mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX] renderEntityAt pos
renderEntityAt pos = renderTopEntity pos <$> revealedEntitiesAtPosition pos
= renderTopEntity pos $ revealedEntitiesAtPosition pos game renderTopEntity pos ents
renderTopEntity pos ents = let neighbors = EntityMap.neighbors pos allEnts
= let neighbors = EntityMap.neighbors pos allEnts in maybe (str " ") (drawWithNeighbors neighbors)
in maybe (str " ") (drawWithNeighbors neighbors) $ maximumBy (compare `on` drawPriority)
$ maximumBy (compare `on` drawPriority) <$> fromNullable ents
<$> fromNullable ents vBox <$> rows
drawMap :: GameState -> Widget ResourceName drawMap :: MonadState GameState m => m (Widget ResourceName)
drawMap game drawMap = do
= viewport Resource.MapViewport Both cursorPos <- gets cursorPosition
. cursorPosition game viewport Resource.MapViewport Both . cursorPos <$> drawEntities
$ drawEntities game
bullet :: Char bullet :: Char
bullet = '•' bullet = '•'
@ -129,15 +130,18 @@ drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints
<+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp) <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp)
drawGame :: GameState -> [Widget ResourceName] drawGame :: GameState -> [Widget ResourceName]
drawGame game drawGame = evalState $ do
= pure game <- get
. withBorderStyle unicode drawnMap <- drawMap
$ case game ^. promptState of pure
NoPrompt -> drawMessages (game ^. messageHistory) . pure
_ -> emptyWidget . withBorderStyle unicode
<=> drawPromptState (game ^. promptState) $ case game ^. promptState of
<=> NoPrompt -> drawMessages (game ^. messageHistory)
(maybe emptyWidget (drawPanel game) (game ^. activePanel) _ -> emptyWidget
<+> border (drawMap game) <=> drawPromptState (game ^. promptState)
) <=>
<=> drawCharacterInfo (game ^. character) (maybe emptyWidget (drawPanel game) (game ^. activePanel)
<+> border drawnMap
)
<=> drawCharacterInfo (game ^. character)

View file

@ -27,6 +27,7 @@ import Control.Monad.State
import Control.Monad.Random (getRandom) import Control.Monad.Random (getRandom)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Game.State import Xanthous.Game.State
import qualified Xanthous.Game.Memo as Memo
import Xanthous.Data import Xanthous.Data
import Xanthous.Data.Levels import Xanthous.Data.Levels
import qualified Xanthous.Data.EntityMap as EntityMap import qualified Xanthous.Data.EntityMap as EntityMap
@ -35,6 +36,8 @@ import Xanthous.Data.EntityMap.Graphics
import Xanthous.Data.VectorBag import Xanthous.Data.VectorBag
import Xanthous.Entities.Character (Character, mkCharacter) import Xanthous.Entities.Character (Character, mkCharacter)
import {-# SOURCE #-} Xanthous.Entities.Entities () import {-# SOURCE #-} Xanthous.Entities.Entities ()
import Xanthous.Game.Memo (emptyMemoState)
import Xanthous.Data.Memo (fillWithM)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
getInitialState :: IO GameState getInitialState :: IO GameState
@ -60,9 +63,9 @@ initialStateFromSeed seed =
{ _allRevealed = False { _allRevealed = False
} }
_autocommand = NoAutocommand _autocommand = NoAutocommand
_memo = emptyMemoState
in GameState {..} in GameState {..}
positionedCharacter :: Lens' GameState (Positioned Character) positionedCharacter :: Lens' GameState (Positioned Character)
positionedCharacter = lens getPositionedCharacter setPositionedCharacter positionedCharacter = lens getPositionedCharacter setPositionedCharacter
where where
@ -96,13 +99,17 @@ visionRadius = 12 -- TODO make this dynamic
-- | Update the revealed entities at the character's position based on their -- | Update the revealed entities at the character's position based on their
-- vision -- vision
updateCharacterVision :: GameState -> GameState updateCharacterVision :: GameState -> GameState
updateCharacterVision game updateCharacterVision = execState $ do
= game & revealedPositions <>~ characterVisiblePositions game positions <- characterVisiblePositions
revealedPositions <>= positions
characterVisiblePositions :: GameState -> Set Position characterVisiblePositions :: MonadState GameState m => m (Set Position)
characterVisiblePositions game = characterVisiblePositions = do
let charPos = game ^. characterPosition charPos <- use characterPosition
in visiblePositions charPos visionRadius $ game ^. entities fillWithM
(memo . Memo.characterVisiblePositions)
charPos
(uses entities $ visiblePositions charPos visionRadius)
characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity
characterVisibleEntities game = characterVisibleEntities game =
@ -137,14 +144,18 @@ entitiesAtCharacter = lens getter setter
-- Concretely, this is either entities that are *currently* visible to the -- Concretely, this is either entities that are *currently* visible to the
-- character, or entities, that are immobile and that the character has seen -- character, or entities, that are immobile and that the character has seen
-- before -- before
revealedEntitiesAtPosition :: Position -> GameState -> (VectorBag SomeEntity) revealedEntitiesAtPosition
revealedEntitiesAtPosition p gs :: MonadState GameState m
| p `member` characterVisiblePositions gs => Position
= entitiesAtPosition -> m (VectorBag SomeEntity)
| p `member` (gs ^. revealedPositions) revealedEntitiesAtPosition p = do
= immobileEntitiesAtPosition cvps <- characterVisiblePositions
| otherwise entitiesAtPosition <- use $ entities . EntityMap.atPosition p
= mempty revealed <- use revealedPositions
where let immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition
entitiesAtPosition = gs ^. entities . EntityMap.atPosition p pure $ if | p `member` cvps
immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition -> entitiesAtPosition
| p `member` revealed
-> immobileEntitiesAtPosition
| otherwise
-> mempty

View file

@ -0,0 +1,52 @@
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- | Memoized versions of calculations
--------------------------------------------------------------------------------
module Xanthous.Game.Memo
( MemoState
, emptyMemoState
, clear
-- ** Memo lenses
, characterVisiblePositions
-- * Memoized values
, Memoized(UnMemoized)
, memoizeWith
, getMemoized
, runMemoized
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Data.Aeson (ToJSON, FromJSON)
import Data.Aeson.Generic.DerivingVia
import Test.QuickCheck (CoArbitrary, Function, Arbitrary)
--------------------------------------------------------------------------------
import Xanthous.Data (Position)
import Xanthous.Data.Memo
import Xanthous.Util.QuickCheck (GenericArbitrary(GenericArbitrary))
--------------------------------------------------------------------------------
-- | Memoized calculations on the game state
data MemoState = MemoState
{ -- | Memoized version of 'Xanthous.Game.Lenses.characterVisiblePositions',
-- memoized with the position of the character
_characterVisiblePositions :: Memoized Position (Set Position)
}
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving Arbitrary via GenericArbitrary MemoState
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
MemoState
makeLenses ''MemoState
emptyMemoState :: MemoState
emptyMemoState = MemoState { _characterVisiblePositions = UnMemoized }
{-# INLINE emptyMemoState #-}
clear :: Lens' MemoState (Memoized k v) -> MemoState -> MemoState
clear = flip set UnMemoized
{-# INLINE clear #-}
{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}

View file

@ -16,6 +16,7 @@ module Xanthous.Game.State
, promptState , promptState
, characterEntityID , characterEntityID
, autocommand , autocommand
, memo
, GamePromptState(..) , GamePromptState(..)
-- * Game Level -- * Game Level
@ -107,6 +108,7 @@ import Xanthous.Data.Entities
import Xanthous.Orphans () import Xanthous.Orphans ()
import Xanthous.Game.Prompt import Xanthous.Game.Prompt
import Xanthous.Game.Env import Xanthous.Game.Env
import Xanthous.Game.Memo (MemoState)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data MessageHistory data MessageHistory
@ -502,6 +504,8 @@ data GameState = GameState
, _promptState :: !(GamePromptState AppM) , _promptState :: !(GamePromptState AppM)
, _debugState :: !DebugState , _debugState :: !DebugState
, _autocommand :: !AutocommandState , _autocommand :: !AutocommandState
, _memo :: MemoState
} }
deriving stock (Show, Generic) deriving stock (Show, Generic)
deriving anyclass (NFData) deriving anyclass (NFData)

View file

@ -21,6 +21,7 @@ module Xanthous.Prelude
import ClassyPrelude hiding import ClassyPrelude hiding
( return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say ( return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say
, catMaybes, filter, mapMaybe, hashNub, ordNub , catMaybes, filter, mapMaybe, hashNub, ordNub
, Memoized, runMemoized
) )
import Data.Kind import Data.Kind
import GHC.TypeLits hiding (Text) import GHC.TypeLits hiding (Text)

View file

@ -6,6 +6,7 @@ import qualified Xanthous.Data.EntityCharSpec
import qualified Xanthous.Data.EntityMap.GraphicsSpec import qualified Xanthous.Data.EntityMap.GraphicsSpec
import qualified Xanthous.Data.EntityMapSpec import qualified Xanthous.Data.EntityMapSpec
import qualified Xanthous.Data.LevelsSpec import qualified Xanthous.Data.LevelsSpec
import qualified Xanthous.Data.MemoSpec
import qualified Xanthous.Data.NestedMapSpec import qualified Xanthous.Data.NestedMapSpec
import qualified Xanthous.DataSpec import qualified Xanthous.DataSpec
import qualified Xanthous.Entities.RawsSpec import qualified Xanthous.Entities.RawsSpec
@ -30,6 +31,7 @@ test = testGroup "Xanthous"
, Xanthous.Data.EntityMap.GraphicsSpec.test , Xanthous.Data.EntityMap.GraphicsSpec.test
, Xanthous.Data.EntityMapSpec.test , Xanthous.Data.EntityMapSpec.test
, Xanthous.Data.LevelsSpec.test , Xanthous.Data.LevelsSpec.test
, Xanthous.Data.MemoSpec.test
, Xanthous.Data.NestedMapSpec.test , Xanthous.Data.NestedMapSpec.test
, Xanthous.DataSpec.test , Xanthous.DataSpec.test
, Xanthous.Entities.RawsSpec.test , Xanthous.Entities.RawsSpec.test

View file

@ -0,0 +1,19 @@
--------------------------------------------------------------------------------
module Xanthous.Data.MemoSpec (main, test) where
--------------------------------------------------------------------------------
import Test.Prelude
import Test.QuickCheck.Instances.Text ()
--------------------------------------------------------------------------------
import Xanthous.Data.Memo
--------------------------------------------------------------------------------
main :: IO ()
main = defaultMain test
test :: TestTree
test = testGroup "Xanthous.Data.MemoSpec"
[ testGroup "getMemoized"
[ testProperty "when key matches" $ \k v ->
getMemoized @Int @Int k (memoizeWith k v) === Just v
]
]

View file

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: b46f24dcf24decf8e16be6f62943648aaafc9272d923945f97d5c26a370ad235 -- hash: f642cb264ff0785d5883884fa8db14adb92ce3d897cfc22e69555089dbc8dfd2
name: xanthous name: xanthous
version: 0.1.0.0 version: 0.1.0.0
@ -44,6 +44,7 @@ library
Xanthous.Data.EntityMap Xanthous.Data.EntityMap
Xanthous.Data.EntityMap.Graphics Xanthous.Data.EntityMap.Graphics
Xanthous.Data.Levels Xanthous.Data.Levels
Xanthous.Data.Memo
Xanthous.Data.NestedMap Xanthous.Data.NestedMap
Xanthous.Data.VectorBag Xanthous.Data.VectorBag
Xanthous.Entities.Character Xanthous.Entities.Character
@ -61,6 +62,7 @@ library
Xanthous.Game.Draw Xanthous.Game.Draw
Xanthous.Game.Env Xanthous.Game.Env
Xanthous.Game.Lenses Xanthous.Game.Lenses
Xanthous.Game.Memo
Xanthous.Game.Prompt Xanthous.Game.Prompt
Xanthous.Game.State Xanthous.Game.State
Xanthous.Generators Xanthous.Generators
@ -142,7 +144,6 @@ library
, filepath , filepath
, generic-arbitrary , generic-arbitrary
, generic-lens , generic-lens
, generic-monoid
, groups , groups
, hgeometry , hgeometry
, hgeometry-combinatorial , hgeometry-combinatorial
@ -166,6 +167,7 @@ library
, raw-strings-qq , raw-strings-qq
, reflection , reflection
, semigroupoids , semigroupoids
, semigroups
, splitmix , splitmix
, stache , stache
, streams , streams
@ -198,6 +200,7 @@ executable xanthous
Xanthous.Data.EntityMap Xanthous.Data.EntityMap
Xanthous.Data.EntityMap.Graphics Xanthous.Data.EntityMap.Graphics
Xanthous.Data.Levels Xanthous.Data.Levels
Xanthous.Data.Memo
Xanthous.Data.NestedMap Xanthous.Data.NestedMap
Xanthous.Data.VectorBag Xanthous.Data.VectorBag
Xanthous.Entities.Character Xanthous.Entities.Character
@ -215,6 +218,7 @@ executable xanthous
Xanthous.Game.Draw Xanthous.Game.Draw
Xanthous.Game.Env Xanthous.Game.Env
Xanthous.Game.Lenses Xanthous.Game.Lenses
Xanthous.Game.Memo
Xanthous.Game.Prompt Xanthous.Game.Prompt
Xanthous.Game.State Xanthous.Game.State
Xanthous.Generators Xanthous.Generators
@ -295,7 +299,6 @@ executable xanthous
, filepath , filepath
, generic-arbitrary , generic-arbitrary
, generic-lens , generic-lens
, generic-monoid
, groups , groups
, hgeometry , hgeometry
, hgeometry-combinatorial , hgeometry-combinatorial
@ -319,6 +322,7 @@ executable xanthous
, raw-strings-qq , raw-strings-qq
, reflection , reflection
, semigroupoids , semigroupoids
, semigroups
, splitmix , splitmix
, stache , stache
, streams , streams
@ -344,6 +348,7 @@ test-suite test
Xanthous.Data.EntityMap.GraphicsSpec Xanthous.Data.EntityMap.GraphicsSpec
Xanthous.Data.EntityMapSpec Xanthous.Data.EntityMapSpec
Xanthous.Data.LevelsSpec Xanthous.Data.LevelsSpec
Xanthous.Data.MemoSpec
Xanthous.Data.NestedMapSpec Xanthous.Data.NestedMapSpec
Xanthous.DataSpec Xanthous.DataSpec
Xanthous.Entities.RawsSpec Xanthous.Entities.RawsSpec
@ -415,7 +420,6 @@ test-suite test
, filepath , filepath
, generic-arbitrary , generic-arbitrary
, generic-lens , generic-lens
, generic-monoid
, groups , groups
, hgeometry , hgeometry
, hgeometry-combinatorial , hgeometry-combinatorial
@ -440,6 +444,7 @@ test-suite test
, raw-strings-qq , raw-strings-qq
, reflection , reflection
, semigroupoids , semigroupoids
, semigroups
, splitmix , splitmix
, stache , stache
, streams , streams
@ -523,7 +528,6 @@ benchmark benchmark
, filepath , filepath
, generic-arbitrary , generic-arbitrary
, generic-lens , generic-lens
, generic-monoid
, groups , groups
, hgeometry , hgeometry
, hgeometry-combinatorial , hgeometry-combinatorial
@ -547,6 +551,7 @@ benchmark benchmark
, raw-strings-qq , raw-strings-qq
, reflection , reflection
, semigroupoids , semigroupoids
, semigroups
, splitmix , splitmix
, stache , stache
, streams , streams