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, 98 insertions, 0 deletions

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'