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 <grfn@gws.fyi> Tested-by: BuildkiteCI
This commit is contained in:
parent
80d501d553
commit
c19e3dae5f
14 changed files with 284 additions and 87 deletions
|
@ -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
|
||||
|
|
|
@ -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";
|
||||
|
|
|
@ -16,5 +16,6 @@ in
|
|||
hp2pretty
|
||||
hlint
|
||||
haskell-language-server
|
||||
cabal2nix
|
||||
];
|
||||
}
|
||||
|
|
|
@ -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
|
||||
|
|
98
users/grfn/xanthous/src/Xanthous/Data/Memo.hs
Normal file
98
users/grfn/xanthous/src/Xanthous/Data/Memo.hs
Normal file
|
@ -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'
|
|
@ -42,6 +42,7 @@ instance Arbitrary GameState where
|
|||
_activePanel <- arbitrary
|
||||
_debugState <- arbitrary
|
||||
let _autocommand = NoAutocommand
|
||||
_memo <- arbitrary
|
||||
pure $ GameState {..}
|
||||
|
||||
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
updateCharacterVision = execState $ do
|
||||
positions <- characterVisiblePositions
|
||||
revealedPositions <>= positions
|
||||
|
||||
characterVisiblePositions :: GameState -> Set Position
|
||||
characterVisiblePositions game =
|
||||
let charPos = game ^. characterPosition
|
||||
in visiblePositions charPos visionRadius $ game ^. entities
|
||||
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
|
||||
|
|
52
users/grfn/xanthous/src/Xanthous/Game/Memo.hs
Normal file
52
users/grfn/xanthous/src/Xanthous/Game/Memo.hs
Normal file
|
@ -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) #-}
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
19
users/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs
Normal file
19
users/grfn/xanthous/test/Xanthous/Data/MemoSpec.hs
Normal file
|
@ -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
|
||||
]
|
||||
]
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue