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/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 ++ 5 files changed, 125 insertions(+), 53 deletions(-) create mode 100644 users/grfn/xanthous/src/Xanthous/Game/Memo.hs (limited to 'users/grfn/xanthous/src/Xanthous/Game') 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) -- cgit 1.4.1