From c19e3dae5f6087c7e446c6be620c370d9957cf7c Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 12 Jun 2021 14:41:24 -0400 Subject: 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 Tested-by: BuildkiteCI --- users/grfn/xanthous/package.yaml | 2 +- users/grfn/xanthous/pkg.nix | 53 ++++++------ users/grfn/xanthous/shell.nix | 1 + users/grfn/xanthous/src/Xanthous/App.hs | 4 +- users/grfn/xanthous/src/Xanthous/Data/Memo.hs | 98 ++++++++++++++++++++++ users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs | 1 + users/grfn/xanthous/src/Xanthous/Game/Draw.hs | 72 ++++++++-------- users/grfn/xanthous/src/Xanthous/Game/Lenses.hs | 49 ++++++----- users/grfn/xanthous/src/Xanthous/Game/Memo.hs | 52 ++++++++++++ users/grfn/xanthous/src/Xanthous/Game/State.hs | 4 + users/grfn/xanthous/src/Xanthous/Prelude.hs | 1 + users/grfn/xanthous/test/Spec.hs | 2 + users/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs | 19 +++++ users/grfn/xanthous/xanthous.cabal | 15 ++-- 14 files changed, 285 insertions(+), 88 deletions(-) create mode 100644 users/grfn/xanthous/src/Xanthous/Data/Memo.hs create mode 100644 users/grfn/xanthous/src/Xanthous/Game/Memo.hs create mode 100644 users/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs (limited to 'users/grfn/xanthous') diff --git a/users/grfn/xanthous/package.yaml b/users/grfn/xanthous/package.yaml index e8cda59692a4..4f01759e9732 100644 --- a/users/grfn/xanthous/package.yaml +++ b/users/grfn/xanthous/package.yaml @@ -40,7 +40,6 @@ dependencies: - file-embed - filepath - generic-arbitrary -- generic-monoid - generic-lens - groups - hgeometry @@ -68,6 +67,7 @@ dependencies: - splitmix - streams - stache +- semigroups - semigroupoids - tomland - transformers diff --git a/users/grfn/xanthous/pkg.nix b/users/grfn/xanthous/pkg.nix index da5a5ba17ed7..ccc0c3fcd451 100644 --- a/users/grfn/xanthous/pkg.nix +++ b/users/grfn/xanthous/pkg.nix @@ -2,13 +2,13 @@ , checkers, classy-prelude, comonad, comonad-extras, constraints , containers, criterion, data-default, deepseq, directory, fgl , fgl-arbitrary, file-embed, filepath, generic-arbitrary -, generic-lens, generic-monoid, groups, hgeometry -, hgeometry-combinatorial, hpack, JuicyPixels, lens -, lens-properties, lib, lifted-async, linear, megaparsec, mmorph -, monad-control, MonadRandom, mtl, optparse-applicative, parallel -, parser-combinators, pointed, QuickCheck, quickcheck-instances -, quickcheck-text, random, random-extras, random-fu, random-source -, Rasterific, raw-strings-qq, reflection, semigroupoids, splitmix +, generic-lens, groups, hgeometry, hgeometry-combinatorial, hpack +, JuicyPixels, lens, lens-properties, lib, lifted-async, linear +, megaparsec, mmorph, monad-control, MonadRandom, mtl +, optparse-applicative, parallel, parser-combinators, pointed +, QuickCheck, quickcheck-instances, quickcheck-text, random +, random-extras, random-fu, random-source, Rasterific +, raw-strings-qq, reflection, semigroupoids, semigroups, splitmix , stache, streams, tasty, tasty-hunit, tasty-quickcheck, text , text-zipper, tomland, transformers, vector, vty, witherable, yaml , zlib @@ -23,54 +23,55 @@ mkDerivation { aeson array async base bifunctors brick checkers classy-prelude comonad comonad-extras constraints containers criterion data-default deepseq directory fgl fgl-arbitrary file-embed - filepath generic-arbitrary generic-lens generic-monoid groups - hgeometry hgeometry-combinatorial JuicyPixels lens lifted-async - linear megaparsec mmorph monad-control MonadRandom mtl + filepath generic-arbitrary generic-lens groups hgeometry + hgeometry-combinatorial JuicyPixels lens lifted-async linear + megaparsec mmorph monad-control MonadRandom mtl optparse-applicative parallel parser-combinators pointed QuickCheck quickcheck-instances quickcheck-text random random-extras random-fu random-source Rasterific raw-strings-qq reflection semigroupoids - splitmix stache streams text text-zipper tomland transformers - vector vty witherable yaml zlib + semigroups splitmix stache streams text text-zipper tomland + transformers vector vty witherable yaml zlib ]; libraryToolDepends = [ hpack ]; executableHaskellDepends = [ aeson array async base bifunctors brick checkers classy-prelude comonad comonad-extras constraints containers criterion data-default deepseq directory fgl fgl-arbitrary file-embed - filepath generic-arbitrary generic-lens generic-monoid groups - hgeometry hgeometry-combinatorial JuicyPixels lens lifted-async - linear megaparsec mmorph monad-control MonadRandom mtl + filepath generic-arbitrary generic-lens groups hgeometry + hgeometry-combinatorial JuicyPixels lens lifted-async linear + megaparsec mmorph monad-control MonadRandom mtl optparse-applicative parallel parser-combinators pointed QuickCheck quickcheck-instances quickcheck-text random random-extras random-fu random-source Rasterific raw-strings-qq reflection semigroupoids - splitmix stache streams text text-zipper tomland transformers - vector vty witherable yaml zlib + semigroups splitmix stache streams text text-zipper tomland + transformers vector vty witherable yaml zlib ]; testHaskellDepends = [ aeson array async base bifunctors brick checkers classy-prelude comonad comonad-extras constraints containers criterion data-default deepseq directory fgl fgl-arbitrary file-embed - filepath generic-arbitrary generic-lens generic-monoid groups - hgeometry hgeometry-combinatorial JuicyPixels lens lens-properties + filepath generic-arbitrary generic-lens groups hgeometry + hgeometry-combinatorial JuicyPixels lens lens-properties lifted-async linear megaparsec mmorph monad-control MonadRandom mtl optparse-applicative parallel parser-combinators pointed QuickCheck quickcheck-instances quickcheck-text random random-extras random-fu random-source Rasterific raw-strings-qq reflection semigroupoids - splitmix stache streams tasty tasty-hunit tasty-quickcheck text - text-zipper tomland transformers vector vty witherable yaml zlib + semigroups splitmix stache streams tasty tasty-hunit + tasty-quickcheck text text-zipper tomland transformers vector vty + witherable yaml zlib ]; benchmarkHaskellDepends = [ aeson array async base bifunctors brick checkers classy-prelude comonad comonad-extras constraints containers criterion data-default deepseq directory fgl fgl-arbitrary file-embed - filepath generic-arbitrary generic-lens generic-monoid groups - hgeometry hgeometry-combinatorial JuicyPixels lens lifted-async - linear megaparsec mmorph monad-control MonadRandom mtl + filepath generic-arbitrary generic-lens groups hgeometry + hgeometry-combinatorial JuicyPixels lens lifted-async linear + megaparsec mmorph monad-control MonadRandom mtl optparse-applicative parallel parser-combinators pointed QuickCheck quickcheck-instances quickcheck-text random random-extras random-fu random-source Rasterific raw-strings-qq reflection semigroupoids - splitmix stache streams text text-zipper tomland transformers - vector vty witherable yaml zlib + semigroups splitmix stache streams text text-zipper tomland + transformers vector vty witherable yaml zlib ]; prePatch = "hpack"; homepage = "https://github.com/glittershark/xanthous#readme"; diff --git a/users/grfn/xanthous/shell.nix b/users/grfn/xanthous/shell.nix index 2695ff8d28cd..f771b2d3172f 100644 --- a/users/grfn/xanthous/shell.nix +++ b/users/grfn/xanthous/shell.nix @@ -16,5 +16,6 @@ in hp2pretty hlint haskell-language-server + cabal2nix ]; } diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs index 9091961b725c..f96662689e50 100644 --- a/users/grfn/xanthous/src/Xanthous/App.hs +++ b/users/grfn/xanthous/src/Xanthous/App.hs @@ -216,9 +216,7 @@ handleCommand Close = do handleCommand Look = do prompt_ @'PointOnMap ["look", "prompt"] Cancellable - $ \(PointOnMapResult pos) -> - gets (revealedEntitiesAtPosition pos) - >>= \case + $ \(PointOnMapResult pos) -> revealedEntitiesAtPosition pos >>= \case Empty -> say_ ["look", "nothing"] ents -> describeEntities ents continue diff --git a/users/grfn/xanthous/src/Xanthous/Data/Memo.hs b/users/grfn/xanthous/src/Xanthous/Data/Memo.hs new file mode 100644 index 000000000000..2b2ee0f96028 --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Data/Memo.hs @@ -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' diff --git a/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs index 1b15ad4ffa64..bb9b64b0b303 100644 --- a/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs +++ b/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs @@ -42,6 +42,7 @@ instance Arbitrary GameState where _activePanel <- arbitrary _debugState <- arbitrary let _autocommand = NoAutocommand + _memo <- arbitrary pure $ GameState {..} diff --git a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs index 2375ae8c557e..14d2dcd22cd5 100644 --- a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs +++ b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs @@ -23,6 +23,8 @@ import Xanthous.Game ) import Xanthous.Game.Prompt import Xanthous.Orphans () +import Control.Monad.State.Lazy (evalState) +import Control.Monad.State.Class ( get, MonadState, gets ) -------------------------------------------------------------------------------- cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName @@ -53,29 +55,28 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) = str ("[" <> pure chr <> "] ") <+> txtWrap m drawEntities - :: GameState - -> Widget ResourceName -drawEntities game = vBox rows - where - allEnts = game ^. entities - entityPositions = EntityMap.positions allEnts - maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions - maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions - rows = mkRow <$> [0..maxY] - mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX] - renderEntityAt pos - = renderTopEntity pos $ revealedEntitiesAtPosition pos game - renderTopEntity pos ents - = let neighbors = EntityMap.neighbors pos allEnts - in maybe (str " ") (drawWithNeighbors neighbors) - $ maximumBy (compare `on` drawPriority) - <$> fromNullable ents + :: forall m. MonadState GameState m + => m (Widget ResourceName) +drawEntities = do + allEnts <- use entities + let entityPositions = EntityMap.positions allEnts + maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions + maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions + rows = traverse mkRow [0..maxY] + mkRow rowY = hBox <$> traverse (renderEntityAt . flip Position rowY) [0..maxX] + renderEntityAt pos + = renderTopEntity pos <$> revealedEntitiesAtPosition pos + renderTopEntity pos ents + = let neighbors = EntityMap.neighbors pos allEnts + in maybe (str " ") (drawWithNeighbors neighbors) + $ maximumBy (compare `on` drawPriority) + <$> fromNullable ents + vBox <$> rows -drawMap :: GameState -> Widget ResourceName -drawMap game - = viewport Resource.MapViewport Both - . cursorPosition game - $ drawEntities game +drawMap :: MonadState GameState m => m (Widget ResourceName) +drawMap = do + cursorPos <- gets cursorPosition + viewport Resource.MapViewport Both . cursorPos <$> drawEntities bullet :: Char bullet = '•' @@ -129,15 +130,18 @@ drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp) drawGame :: GameState -> [Widget ResourceName] -drawGame game - = pure - . withBorderStyle unicode - $ case game ^. promptState of - NoPrompt -> drawMessages (game ^. messageHistory) - _ -> emptyWidget - <=> drawPromptState (game ^. promptState) - <=> - (maybe emptyWidget (drawPanel game) (game ^. activePanel) - <+> border (drawMap game) - ) - <=> drawCharacterInfo (game ^. character) +drawGame = evalState $ do + game <- get + drawnMap <- drawMap + pure + . pure + . withBorderStyle unicode + $ case game ^. promptState of + NoPrompt -> drawMessages (game ^. messageHistory) + _ -> emptyWidget + <=> drawPromptState (game ^. promptState) + <=> + (maybe emptyWidget (drawPanel game) (game ^. activePanel) + <+> border drawnMap + ) + <=> drawCharacterInfo (game ^. character) diff --git a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs index 6242b855f1cc..d93d30aba876 100644 --- a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs +++ b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs @@ -27,6 +27,7 @@ import Control.Monad.State import Control.Monad.Random (getRandom) -------------------------------------------------------------------------------- import Xanthous.Game.State +import qualified Xanthous.Game.Memo as Memo import Xanthous.Data import Xanthous.Data.Levels import qualified Xanthous.Data.EntityMap as EntityMap @@ -35,6 +36,8 @@ import Xanthous.Data.EntityMap.Graphics import Xanthous.Data.VectorBag import Xanthous.Entities.Character (Character, mkCharacter) import {-# SOURCE #-} Xanthous.Entities.Entities () +import Xanthous.Game.Memo (emptyMemoState) +import Xanthous.Data.Memo (fillWithM) -------------------------------------------------------------------------------- getInitialState :: IO GameState @@ -60,9 +63,9 @@ initialStateFromSeed seed = { _allRevealed = False } _autocommand = NoAutocommand + _memo = emptyMemoState in GameState {..} - positionedCharacter :: Lens' GameState (Positioned Character) positionedCharacter = lens getPositionedCharacter setPositionedCharacter where @@ -96,13 +99,17 @@ visionRadius = 12 -- TODO make this dynamic -- | Update the revealed entities at the character's position based on their -- vision updateCharacterVision :: GameState -> GameState -updateCharacterVision game - = game & revealedPositions <>~ characterVisiblePositions game - -characterVisiblePositions :: GameState -> Set Position -characterVisiblePositions game = - let charPos = game ^. characterPosition - in visiblePositions charPos visionRadius $ game ^. entities +updateCharacterVision = execState $ do + positions <- characterVisiblePositions + revealedPositions <>= positions + +characterVisiblePositions :: MonadState GameState m => m (Set Position) +characterVisiblePositions = do + charPos <- use characterPosition + fillWithM + (memo . Memo.characterVisiblePositions) + charPos + (uses entities $ visiblePositions charPos visionRadius) characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity characterVisibleEntities game = @@ -137,14 +144,18 @@ entitiesAtCharacter = lens getter setter -- Concretely, this is either entities that are *currently* visible to the -- character, or entities, that are immobile and that the character has seen -- before -revealedEntitiesAtPosition :: Position -> GameState -> (VectorBag SomeEntity) -revealedEntitiesAtPosition p gs - | p `member` characterVisiblePositions gs - = entitiesAtPosition - | p `member` (gs ^. revealedPositions) - = immobileEntitiesAtPosition - | otherwise - = mempty - where - entitiesAtPosition = gs ^. entities . EntityMap.atPosition p - immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition +revealedEntitiesAtPosition + :: MonadState GameState m + => Position + -> m (VectorBag SomeEntity) +revealedEntitiesAtPosition p = do + cvps <- characterVisiblePositions + entitiesAtPosition <- use $ entities . EntityMap.atPosition p + revealed <- use revealedPositions + let immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition + pure $ if | p `member` cvps + -> entitiesAtPosition + | p `member` revealed + -> immobileEntitiesAtPosition + | otherwise + -> mempty diff --git a/users/grfn/xanthous/src/Xanthous/Game/Memo.hs b/users/grfn/xanthous/src/Xanthous/Game/Memo.hs new file mode 100644 index 000000000000..9e483a8d4af7 --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Game/Memo.hs @@ -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) #-} diff --git a/users/grfn/xanthous/src/Xanthous/Game/State.hs b/users/grfn/xanthous/src/Xanthous/Game/State.hs index f614cad47339..cdaf23edcd48 100644 --- a/users/grfn/xanthous/src/Xanthous/Game/State.hs +++ b/users/grfn/xanthous/src/Xanthous/Game/State.hs @@ -16,6 +16,7 @@ module Xanthous.Game.State , promptState , characterEntityID , autocommand + , memo , GamePromptState(..) -- * Game Level @@ -107,6 +108,7 @@ import Xanthous.Data.Entities import Xanthous.Orphans () import Xanthous.Game.Prompt import Xanthous.Game.Env +import Xanthous.Game.Memo (MemoState) -------------------------------------------------------------------------------- data MessageHistory @@ -502,6 +504,8 @@ data GameState = GameState , _promptState :: !(GamePromptState AppM) , _debugState :: !DebugState , _autocommand :: !AutocommandState + + , _memo :: MemoState } deriving stock (Show, Generic) deriving anyclass (NFData) diff --git a/users/grfn/xanthous/src/Xanthous/Prelude.hs b/users/grfn/xanthous/src/Xanthous/Prelude.hs index 4d79b026f14a..2cb4299303ba 100644 --- a/users/grfn/xanthous/src/Xanthous/Prelude.hs +++ b/users/grfn/xanthous/src/Xanthous/Prelude.hs @@ -21,6 +21,7 @@ module Xanthous.Prelude import ClassyPrelude hiding ( return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say , catMaybes, filter, mapMaybe, hashNub, ordNub + , Memoized, runMemoized ) import Data.Kind import GHC.TypeLits hiding (Text) diff --git a/users/grfn/xanthous/test/Spec.hs b/users/grfn/xanthous/test/Spec.hs index f15c393ac917..36bac640b18e 100644 --- a/users/grfn/xanthous/test/Spec.hs +++ b/users/grfn/xanthous/test/Spec.hs @@ -6,6 +6,7 @@ import qualified Xanthous.Data.EntityCharSpec import qualified Xanthous.Data.EntityMap.GraphicsSpec import qualified Xanthous.Data.EntityMapSpec import qualified Xanthous.Data.LevelsSpec +import qualified Xanthous.Data.MemoSpec import qualified Xanthous.Data.NestedMapSpec import qualified Xanthous.DataSpec import qualified Xanthous.Entities.RawsSpec @@ -30,6 +31,7 @@ test = testGroup "Xanthous" , Xanthous.Data.EntityMap.GraphicsSpec.test , Xanthous.Data.EntityMapSpec.test , Xanthous.Data.LevelsSpec.test + , Xanthous.Data.MemoSpec.test , Xanthous.Data.NestedMapSpec.test , Xanthous.DataSpec.test , Xanthous.Entities.RawsSpec.test diff --git a/users/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs b/users/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs new file mode 100644 index 000000000000..ad81f1984d8f --- /dev/null +++ b/users/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs @@ -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 + ] + ] diff --git a/users/grfn/xanthous/xanthous.cabal b/users/grfn/xanthous/xanthous.cabal index 9648933b768b..3afbf8db77e2 100644 --- a/users/grfn/xanthous/xanthous.cabal +++ b/users/grfn/xanthous/xanthous.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: b46f24dcf24decf8e16be6f62943648aaafc9272d923945f97d5c26a370ad235 +-- hash: f642cb264ff0785d5883884fa8db14adb92ce3d897cfc22e69555089dbc8dfd2 name: xanthous version: 0.1.0.0 @@ -44,6 +44,7 @@ library Xanthous.Data.EntityMap Xanthous.Data.EntityMap.Graphics Xanthous.Data.Levels + Xanthous.Data.Memo Xanthous.Data.NestedMap Xanthous.Data.VectorBag Xanthous.Entities.Character @@ -61,6 +62,7 @@ library Xanthous.Game.Draw Xanthous.Game.Env Xanthous.Game.Lenses + Xanthous.Game.Memo Xanthous.Game.Prompt Xanthous.Game.State Xanthous.Generators @@ -142,7 +144,6 @@ library , filepath , generic-arbitrary , generic-lens - , generic-monoid , groups , hgeometry , hgeometry-combinatorial @@ -166,6 +167,7 @@ library , raw-strings-qq , reflection , semigroupoids + , semigroups , splitmix , stache , streams @@ -198,6 +200,7 @@ executable xanthous Xanthous.Data.EntityMap Xanthous.Data.EntityMap.Graphics Xanthous.Data.Levels + Xanthous.Data.Memo Xanthous.Data.NestedMap Xanthous.Data.VectorBag Xanthous.Entities.Character @@ -215,6 +218,7 @@ executable xanthous Xanthous.Game.Draw Xanthous.Game.Env Xanthous.Game.Lenses + Xanthous.Game.Memo Xanthous.Game.Prompt Xanthous.Game.State Xanthous.Generators @@ -295,7 +299,6 @@ executable xanthous , filepath , generic-arbitrary , generic-lens - , generic-monoid , groups , hgeometry , hgeometry-combinatorial @@ -319,6 +322,7 @@ executable xanthous , raw-strings-qq , reflection , semigroupoids + , semigroups , splitmix , stache , streams @@ -344,6 +348,7 @@ test-suite test Xanthous.Data.EntityMap.GraphicsSpec Xanthous.Data.EntityMapSpec Xanthous.Data.LevelsSpec + Xanthous.Data.MemoSpec Xanthous.Data.NestedMapSpec Xanthous.DataSpec Xanthous.Entities.RawsSpec @@ -415,7 +420,6 @@ test-suite test , filepath , generic-arbitrary , generic-lens - , generic-monoid , groups , hgeometry , hgeometry-combinatorial @@ -440,6 +444,7 @@ test-suite test , raw-strings-qq , reflection , semigroupoids + , semigroups , splitmix , stache , streams @@ -523,7 +528,6 @@ benchmark benchmark , filepath , generic-arbitrary , generic-lens - , generic-monoid , groups , hgeometry , hgeometry-combinatorial @@ -547,6 +551,7 @@ benchmark benchmark , raw-strings-qq , reflection , semigroupoids + , semigroups , splitmix , stache , streams -- cgit 1.4.1