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

1 files changed, 30 insertions, 19 deletions

diff --git a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs
index 6242b855f1..d93d30aba8 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