feat(xanthous): Memoize characterVisiblePositions r/2653

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

14 files changed, 285 insertions, 88 deletions

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