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

8 files changed, 225 insertions, 56 deletions

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)