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
|
- file-embed
|
||||||
- filepath
|
- filepath
|
||||||
- generic-arbitrary
|
- generic-arbitrary
|
||||||
- generic-monoid
|
|
||||||
- generic-lens
|
- generic-lens
|
||||||
- groups
|
- groups
|
||||||
- hgeometry
|
- hgeometry
|
||||||
|
@ -68,6 +67,7 @@ dependencies:
|
||||||
- splitmix
|
- splitmix
|
||||||
- streams
|
- streams
|
||||||
- stache
|
- stache
|
||||||
|
- semigroups
|
||||||
- semigroupoids
|
- semigroupoids
|
||||||
- tomland
|
- tomland
|
||||||
- transformers
|
- transformers
|
||||||
|
|
|
@ -2,13 +2,13 @@
|
||||||
, checkers, classy-prelude, comonad, comonad-extras, constraints
|
, checkers, classy-prelude, comonad, comonad-extras, constraints
|
||||||
, containers, criterion, data-default, deepseq, directory, fgl
|
, containers, criterion, data-default, deepseq, directory, fgl
|
||||||
, fgl-arbitrary, file-embed, filepath, generic-arbitrary
|
, fgl-arbitrary, file-embed, filepath, generic-arbitrary
|
||||||
, generic-lens, generic-monoid, groups, hgeometry
|
, generic-lens, groups, hgeometry, hgeometry-combinatorial, hpack
|
||||||
, hgeometry-combinatorial, hpack, JuicyPixels, lens
|
, JuicyPixels, lens, lens-properties, lib, lifted-async, linear
|
||||||
, lens-properties, lib, lifted-async, linear, megaparsec, mmorph
|
, megaparsec, mmorph, monad-control, MonadRandom, mtl
|
||||||
, monad-control, MonadRandom, mtl, optparse-applicative, parallel
|
, optparse-applicative, parallel, parser-combinators, pointed
|
||||||
, parser-combinators, pointed, QuickCheck, quickcheck-instances
|
, QuickCheck, quickcheck-instances, quickcheck-text, random
|
||||||
, quickcheck-text, random, random-extras, random-fu, random-source
|
, random-extras, random-fu, random-source, Rasterific
|
||||||
, Rasterific, raw-strings-qq, reflection, semigroupoids, splitmix
|
, raw-strings-qq, reflection, semigroupoids, semigroups, splitmix
|
||||||
, stache, streams, tasty, tasty-hunit, tasty-quickcheck, text
|
, stache, streams, tasty, tasty-hunit, tasty-quickcheck, text
|
||||||
, text-zipper, tomland, transformers, vector, vty, witherable, yaml
|
, text-zipper, tomland, transformers, vector, vty, witherable, yaml
|
||||||
, zlib
|
, zlib
|
||||||
|
@ -23,54 +23,55 @@ mkDerivation {
|
||||||
aeson array async base bifunctors brick checkers classy-prelude
|
aeson array async base bifunctors brick checkers classy-prelude
|
||||||
comonad comonad-extras constraints containers criterion
|
comonad comonad-extras constraints containers criterion
|
||||||
data-default deepseq directory fgl fgl-arbitrary file-embed
|
data-default deepseq directory fgl fgl-arbitrary file-embed
|
||||||
filepath generic-arbitrary generic-lens generic-monoid groups
|
filepath generic-arbitrary generic-lens groups hgeometry
|
||||||
hgeometry hgeometry-combinatorial JuicyPixels lens lifted-async
|
hgeometry-combinatorial JuicyPixels lens lifted-async linear
|
||||||
linear megaparsec mmorph monad-control MonadRandom mtl
|
megaparsec mmorph monad-control MonadRandom mtl
|
||||||
optparse-applicative parallel parser-combinators pointed QuickCheck
|
optparse-applicative parallel parser-combinators pointed QuickCheck
|
||||||
quickcheck-instances quickcheck-text random random-extras random-fu
|
quickcheck-instances quickcheck-text random random-extras random-fu
|
||||||
random-source Rasterific raw-strings-qq reflection semigroupoids
|
random-source Rasterific raw-strings-qq reflection semigroupoids
|
||||||
splitmix stache streams text text-zipper tomland transformers
|
semigroups splitmix stache streams text text-zipper tomland
|
||||||
vector vty witherable yaml zlib
|
transformers vector vty witherable yaml zlib
|
||||||
];
|
];
|
||||||
libraryToolDepends = [ hpack ];
|
libraryToolDepends = [ hpack ];
|
||||||
executableHaskellDepends = [
|
executableHaskellDepends = [
|
||||||
aeson array async base bifunctors brick checkers classy-prelude
|
aeson array async base bifunctors brick checkers classy-prelude
|
||||||
comonad comonad-extras constraints containers criterion
|
comonad comonad-extras constraints containers criterion
|
||||||
data-default deepseq directory fgl fgl-arbitrary file-embed
|
data-default deepseq directory fgl fgl-arbitrary file-embed
|
||||||
filepath generic-arbitrary generic-lens generic-monoid groups
|
filepath generic-arbitrary generic-lens groups hgeometry
|
||||||
hgeometry hgeometry-combinatorial JuicyPixels lens lifted-async
|
hgeometry-combinatorial JuicyPixels lens lifted-async linear
|
||||||
linear megaparsec mmorph monad-control MonadRandom mtl
|
megaparsec mmorph monad-control MonadRandom mtl
|
||||||
optparse-applicative parallel parser-combinators pointed QuickCheck
|
optparse-applicative parallel parser-combinators pointed QuickCheck
|
||||||
quickcheck-instances quickcheck-text random random-extras random-fu
|
quickcheck-instances quickcheck-text random random-extras random-fu
|
||||||
random-source Rasterific raw-strings-qq reflection semigroupoids
|
random-source Rasterific raw-strings-qq reflection semigroupoids
|
||||||
splitmix stache streams text text-zipper tomland transformers
|
semigroups splitmix stache streams text text-zipper tomland
|
||||||
vector vty witherable yaml zlib
|
transformers vector vty witherable yaml zlib
|
||||||
];
|
];
|
||||||
testHaskellDepends = [
|
testHaskellDepends = [
|
||||||
aeson array async base bifunctors brick checkers classy-prelude
|
aeson array async base bifunctors brick checkers classy-prelude
|
||||||
comonad comonad-extras constraints containers criterion
|
comonad comonad-extras constraints containers criterion
|
||||||
data-default deepseq directory fgl fgl-arbitrary file-embed
|
data-default deepseq directory fgl fgl-arbitrary file-embed
|
||||||
filepath generic-arbitrary generic-lens generic-monoid groups
|
filepath generic-arbitrary generic-lens groups hgeometry
|
||||||
hgeometry hgeometry-combinatorial JuicyPixels lens lens-properties
|
hgeometry-combinatorial JuicyPixels lens lens-properties
|
||||||
lifted-async linear megaparsec mmorph monad-control MonadRandom mtl
|
lifted-async linear megaparsec mmorph monad-control MonadRandom mtl
|
||||||
optparse-applicative parallel parser-combinators pointed QuickCheck
|
optparse-applicative parallel parser-combinators pointed QuickCheck
|
||||||
quickcheck-instances quickcheck-text random random-extras random-fu
|
quickcheck-instances quickcheck-text random random-extras random-fu
|
||||||
random-source Rasterific raw-strings-qq reflection semigroupoids
|
random-source Rasterific raw-strings-qq reflection semigroupoids
|
||||||
splitmix stache streams tasty tasty-hunit tasty-quickcheck text
|
semigroups splitmix stache streams tasty tasty-hunit
|
||||||
text-zipper tomland transformers vector vty witherable yaml zlib
|
tasty-quickcheck text text-zipper tomland transformers vector vty
|
||||||
|
witherable yaml zlib
|
||||||
];
|
];
|
||||||
benchmarkHaskellDepends = [
|
benchmarkHaskellDepends = [
|
||||||
aeson array async base bifunctors brick checkers classy-prelude
|
aeson array async base bifunctors brick checkers classy-prelude
|
||||||
comonad comonad-extras constraints containers criterion
|
comonad comonad-extras constraints containers criterion
|
||||||
data-default deepseq directory fgl fgl-arbitrary file-embed
|
data-default deepseq directory fgl fgl-arbitrary file-embed
|
||||||
filepath generic-arbitrary generic-lens generic-monoid groups
|
filepath generic-arbitrary generic-lens groups hgeometry
|
||||||
hgeometry hgeometry-combinatorial JuicyPixels lens lifted-async
|
hgeometry-combinatorial JuicyPixels lens lifted-async linear
|
||||||
linear megaparsec mmorph monad-control MonadRandom mtl
|
megaparsec mmorph monad-control MonadRandom mtl
|
||||||
optparse-applicative parallel parser-combinators pointed QuickCheck
|
optparse-applicative parallel parser-combinators pointed QuickCheck
|
||||||
quickcheck-instances quickcheck-text random random-extras random-fu
|
quickcheck-instances quickcheck-text random random-extras random-fu
|
||||||
random-source Rasterific raw-strings-qq reflection semigroupoids
|
random-source Rasterific raw-strings-qq reflection semigroupoids
|
||||||
splitmix stache streams text text-zipper tomland transformers
|
semigroups splitmix stache streams text text-zipper tomland
|
||||||
vector vty witherable yaml zlib
|
transformers vector vty witherable yaml zlib
|
||||||
];
|
];
|
||||||
prePatch = "hpack";
|
prePatch = "hpack";
|
||||||
homepage = "https://github.com/glittershark/xanthous#readme";
|
homepage = "https://github.com/glittershark/xanthous#readme";
|
||||||
|
|
|
@ -16,5 +16,6 @@ in
|
||||||
hp2pretty
|
hp2pretty
|
||||||
hlint
|
hlint
|
||||||
haskell-language-server
|
haskell-language-server
|
||||||
|
cabal2nix
|
||||||
];
|
];
|
||||||
}
|
}
|
||||||
|
|
|
@ -216,9 +216,7 @@ handleCommand Close = do
|
||||||
|
|
||||||
handleCommand Look = do
|
handleCommand Look = do
|
||||||
prompt_ @'PointOnMap ["look", "prompt"] Cancellable
|
prompt_ @'PointOnMap ["look", "prompt"] Cancellable
|
||||||
$ \(PointOnMapResult pos) ->
|
$ \(PointOnMapResult pos) -> revealedEntitiesAtPosition pos >>= \case
|
||||||
gets (revealedEntitiesAtPosition pos)
|
|
||||||
>>= \case
|
|
||||||
Empty -> say_ ["look", "nothing"]
|
Empty -> say_ ["look", "nothing"]
|
||||||
ents -> describeEntities ents
|
ents -> describeEntities ents
|
||||||
continue
|
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
|
_activePanel <- arbitrary
|
||||||
_debugState <- arbitrary
|
_debugState <- arbitrary
|
||||||
let _autocommand = NoAutocommand
|
let _autocommand = NoAutocommand
|
||||||
|
_memo <- arbitrary
|
||||||
pure $ GameState {..}
|
pure $ GameState {..}
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -23,6 +23,8 @@ import Xanthous.Game
|
||||||
)
|
)
|
||||||
import Xanthous.Game.Prompt
|
import Xanthous.Game.Prompt
|
||||||
import Xanthous.Orphans ()
|
import Xanthous.Orphans ()
|
||||||
|
import Control.Monad.State.Lazy (evalState)
|
||||||
|
import Control.Monad.State.Class ( get, MonadState, gets )
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
|
cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
|
||||||
|
@ -53,29 +55,28 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
|
||||||
str ("[" <> pure chr <> "] ") <+> txtWrap m
|
str ("[" <> pure chr <> "] ") <+> txtWrap m
|
||||||
|
|
||||||
drawEntities
|
drawEntities
|
||||||
:: GameState
|
:: forall m. MonadState GameState m
|
||||||
-> Widget ResourceName
|
=> m (Widget ResourceName)
|
||||||
drawEntities game = vBox rows
|
drawEntities = do
|
||||||
where
|
allEnts <- use entities
|
||||||
allEnts = game ^. entities
|
let entityPositions = EntityMap.positions allEnts
|
||||||
entityPositions = EntityMap.positions allEnts
|
maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
|
||||||
maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
|
maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
|
||||||
maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
|
rows = traverse mkRow [0..maxY]
|
||||||
rows = mkRow <$> [0..maxY]
|
mkRow rowY = hBox <$> traverse (renderEntityAt . flip Position rowY) [0..maxX]
|
||||||
mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX]
|
renderEntityAt pos
|
||||||
renderEntityAt pos
|
= renderTopEntity pos <$> revealedEntitiesAtPosition pos
|
||||||
= renderTopEntity pos $ revealedEntitiesAtPosition pos game
|
renderTopEntity pos ents
|
||||||
renderTopEntity pos ents
|
= let neighbors = EntityMap.neighbors pos allEnts
|
||||||
= let neighbors = EntityMap.neighbors pos allEnts
|
in maybe (str " ") (drawWithNeighbors neighbors)
|
||||||
in maybe (str " ") (drawWithNeighbors neighbors)
|
$ maximumBy (compare `on` drawPriority)
|
||||||
$ maximumBy (compare `on` drawPriority)
|
<$> fromNullable ents
|
||||||
<$> fromNullable ents
|
vBox <$> rows
|
||||||
|
|
||||||
drawMap :: GameState -> Widget ResourceName
|
drawMap :: MonadState GameState m => m (Widget ResourceName)
|
||||||
drawMap game
|
drawMap = do
|
||||||
= viewport Resource.MapViewport Both
|
cursorPos <- gets cursorPosition
|
||||||
. cursorPosition game
|
viewport Resource.MapViewport Both . cursorPos <$> drawEntities
|
||||||
$ drawEntities game
|
|
||||||
|
|
||||||
bullet :: Char
|
bullet :: Char
|
||||||
bullet = '•'
|
bullet = '•'
|
||||||
|
@ -129,15 +130,18 @@ drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints
|
||||||
<+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp)
|
<+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp)
|
||||||
|
|
||||||
drawGame :: GameState -> [Widget ResourceName]
|
drawGame :: GameState -> [Widget ResourceName]
|
||||||
drawGame game
|
drawGame = evalState $ do
|
||||||
= pure
|
game <- get
|
||||||
. withBorderStyle unicode
|
drawnMap <- drawMap
|
||||||
$ case game ^. promptState of
|
pure
|
||||||
NoPrompt -> drawMessages (game ^. messageHistory)
|
. pure
|
||||||
_ -> emptyWidget
|
. withBorderStyle unicode
|
||||||
<=> drawPromptState (game ^. promptState)
|
$ case game ^. promptState of
|
||||||
<=>
|
NoPrompt -> drawMessages (game ^. messageHistory)
|
||||||
(maybe emptyWidget (drawPanel game) (game ^. activePanel)
|
_ -> emptyWidget
|
||||||
<+> border (drawMap game)
|
<=> drawPromptState (game ^. promptState)
|
||||||
)
|
<=>
|
||||||
<=> drawCharacterInfo (game ^. character)
|
(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 Control.Monad.Random (getRandom)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Game.State
|
import Xanthous.Game.State
|
||||||
|
import qualified Xanthous.Game.Memo as Memo
|
||||||
import Xanthous.Data
|
import Xanthous.Data
|
||||||
import Xanthous.Data.Levels
|
import Xanthous.Data.Levels
|
||||||
import qualified Xanthous.Data.EntityMap as EntityMap
|
import qualified Xanthous.Data.EntityMap as EntityMap
|
||||||
|
@ -35,6 +36,8 @@ import Xanthous.Data.EntityMap.Graphics
|
||||||
import Xanthous.Data.VectorBag
|
import Xanthous.Data.VectorBag
|
||||||
import Xanthous.Entities.Character (Character, mkCharacter)
|
import Xanthous.Entities.Character (Character, mkCharacter)
|
||||||
import {-# SOURCE #-} Xanthous.Entities.Entities ()
|
import {-# SOURCE #-} Xanthous.Entities.Entities ()
|
||||||
|
import Xanthous.Game.Memo (emptyMemoState)
|
||||||
|
import Xanthous.Data.Memo (fillWithM)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
getInitialState :: IO GameState
|
getInitialState :: IO GameState
|
||||||
|
@ -60,9 +63,9 @@ initialStateFromSeed seed =
|
||||||
{ _allRevealed = False
|
{ _allRevealed = False
|
||||||
}
|
}
|
||||||
_autocommand = NoAutocommand
|
_autocommand = NoAutocommand
|
||||||
|
_memo = emptyMemoState
|
||||||
in GameState {..}
|
in GameState {..}
|
||||||
|
|
||||||
|
|
||||||
positionedCharacter :: Lens' GameState (Positioned Character)
|
positionedCharacter :: Lens' GameState (Positioned Character)
|
||||||
positionedCharacter = lens getPositionedCharacter setPositionedCharacter
|
positionedCharacter = lens getPositionedCharacter setPositionedCharacter
|
||||||
where
|
where
|
||||||
|
@ -96,13 +99,17 @@ visionRadius = 12 -- TODO make this dynamic
|
||||||
-- | Update the revealed entities at the character's position based on their
|
-- | Update the revealed entities at the character's position based on their
|
||||||
-- vision
|
-- vision
|
||||||
updateCharacterVision :: GameState -> GameState
|
updateCharacterVision :: GameState -> GameState
|
||||||
updateCharacterVision game
|
updateCharacterVision = execState $ do
|
||||||
= game & revealedPositions <>~ characterVisiblePositions game
|
positions <- characterVisiblePositions
|
||||||
|
revealedPositions <>= positions
|
||||||
|
|
||||||
characterVisiblePositions :: GameState -> Set Position
|
characterVisiblePositions :: MonadState GameState m => m (Set Position)
|
||||||
characterVisiblePositions game =
|
characterVisiblePositions = do
|
||||||
let charPos = game ^. characterPosition
|
charPos <- use characterPosition
|
||||||
in visiblePositions charPos visionRadius $ game ^. entities
|
fillWithM
|
||||||
|
(memo . Memo.characterVisiblePositions)
|
||||||
|
charPos
|
||||||
|
(uses entities $ visiblePositions charPos visionRadius)
|
||||||
|
|
||||||
characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity
|
characterVisibleEntities :: GameState -> EntityMap.EntityMap SomeEntity
|
||||||
characterVisibleEntities game =
|
characterVisibleEntities game =
|
||||||
|
@ -137,14 +144,18 @@ entitiesAtCharacter = lens getter setter
|
||||||
-- Concretely, this is either entities that are *currently* visible to the
|
-- Concretely, this is either entities that are *currently* visible to the
|
||||||
-- character, or entities, that are immobile and that the character has seen
|
-- character, or entities, that are immobile and that the character has seen
|
||||||
-- before
|
-- before
|
||||||
revealedEntitiesAtPosition :: Position -> GameState -> (VectorBag SomeEntity)
|
revealedEntitiesAtPosition
|
||||||
revealedEntitiesAtPosition p gs
|
:: MonadState GameState m
|
||||||
| p `member` characterVisiblePositions gs
|
=> Position
|
||||||
= entitiesAtPosition
|
-> m (VectorBag SomeEntity)
|
||||||
| p `member` (gs ^. revealedPositions)
|
revealedEntitiesAtPosition p = do
|
||||||
= immobileEntitiesAtPosition
|
cvps <- characterVisiblePositions
|
||||||
| otherwise
|
entitiesAtPosition <- use $ entities . EntityMap.atPosition p
|
||||||
= mempty
|
revealed <- use revealedPositions
|
||||||
where
|
let immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition
|
||||||
entitiesAtPosition = gs ^. entities . EntityMap.atPosition p
|
pure $ if | p `member` cvps
|
||||||
immobileEntitiesAtPosition = filter (not . entityCanMove) entitiesAtPosition
|
-> 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
|
, promptState
|
||||||
, characterEntityID
|
, characterEntityID
|
||||||
, autocommand
|
, autocommand
|
||||||
|
, memo
|
||||||
, GamePromptState(..)
|
, GamePromptState(..)
|
||||||
|
|
||||||
-- * Game Level
|
-- * Game Level
|
||||||
|
@ -107,6 +108,7 @@ import Xanthous.Data.Entities
|
||||||
import Xanthous.Orphans ()
|
import Xanthous.Orphans ()
|
||||||
import Xanthous.Game.Prompt
|
import Xanthous.Game.Prompt
|
||||||
import Xanthous.Game.Env
|
import Xanthous.Game.Env
|
||||||
|
import Xanthous.Game.Memo (MemoState)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
data MessageHistory
|
data MessageHistory
|
||||||
|
@ -502,6 +504,8 @@ data GameState = GameState
|
||||||
, _promptState :: !(GamePromptState AppM)
|
, _promptState :: !(GamePromptState AppM)
|
||||||
, _debugState :: !DebugState
|
, _debugState :: !DebugState
|
||||||
, _autocommand :: !AutocommandState
|
, _autocommand :: !AutocommandState
|
||||||
|
|
||||||
|
, _memo :: MemoState
|
||||||
}
|
}
|
||||||
deriving stock (Show, Generic)
|
deriving stock (Show, Generic)
|
||||||
deriving anyclass (NFData)
|
deriving anyclass (NFData)
|
||||||
|
|
|
@ -21,6 +21,7 @@ module Xanthous.Prelude
|
||||||
import ClassyPrelude hiding
|
import ClassyPrelude hiding
|
||||||
( return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say
|
( return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say
|
||||||
, catMaybes, filter, mapMaybe, hashNub, ordNub
|
, catMaybes, filter, mapMaybe, hashNub, ordNub
|
||||||
|
, Memoized, runMemoized
|
||||||
)
|
)
|
||||||
import Data.Kind
|
import Data.Kind
|
||||||
import GHC.TypeLits hiding (Text)
|
import GHC.TypeLits hiding (Text)
|
||||||
|
|
|
@ -6,6 +6,7 @@ import qualified Xanthous.Data.EntityCharSpec
|
||||||
import qualified Xanthous.Data.EntityMap.GraphicsSpec
|
import qualified Xanthous.Data.EntityMap.GraphicsSpec
|
||||||
import qualified Xanthous.Data.EntityMapSpec
|
import qualified Xanthous.Data.EntityMapSpec
|
||||||
import qualified Xanthous.Data.LevelsSpec
|
import qualified Xanthous.Data.LevelsSpec
|
||||||
|
import qualified Xanthous.Data.MemoSpec
|
||||||
import qualified Xanthous.Data.NestedMapSpec
|
import qualified Xanthous.Data.NestedMapSpec
|
||||||
import qualified Xanthous.DataSpec
|
import qualified Xanthous.DataSpec
|
||||||
import qualified Xanthous.Entities.RawsSpec
|
import qualified Xanthous.Entities.RawsSpec
|
||||||
|
@ -30,6 +31,7 @@ test = testGroup "Xanthous"
|
||||||
, Xanthous.Data.EntityMap.GraphicsSpec.test
|
, Xanthous.Data.EntityMap.GraphicsSpec.test
|
||||||
, Xanthous.Data.EntityMapSpec.test
|
, Xanthous.Data.EntityMapSpec.test
|
||||||
, Xanthous.Data.LevelsSpec.test
|
, Xanthous.Data.LevelsSpec.test
|
||||||
|
, Xanthous.Data.MemoSpec.test
|
||||||
, Xanthous.Data.NestedMapSpec.test
|
, Xanthous.Data.NestedMapSpec.test
|
||||||
, Xanthous.DataSpec.test
|
, Xanthous.DataSpec.test
|
||||||
, Xanthous.Entities.RawsSpec.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
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: b46f24dcf24decf8e16be6f62943648aaafc9272d923945f97d5c26a370ad235
|
-- hash: f642cb264ff0785d5883884fa8db14adb92ce3d897cfc22e69555089dbc8dfd2
|
||||||
|
|
||||||
name: xanthous
|
name: xanthous
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
@ -44,6 +44,7 @@ library
|
||||||
Xanthous.Data.EntityMap
|
Xanthous.Data.EntityMap
|
||||||
Xanthous.Data.EntityMap.Graphics
|
Xanthous.Data.EntityMap.Graphics
|
||||||
Xanthous.Data.Levels
|
Xanthous.Data.Levels
|
||||||
|
Xanthous.Data.Memo
|
||||||
Xanthous.Data.NestedMap
|
Xanthous.Data.NestedMap
|
||||||
Xanthous.Data.VectorBag
|
Xanthous.Data.VectorBag
|
||||||
Xanthous.Entities.Character
|
Xanthous.Entities.Character
|
||||||
|
@ -61,6 +62,7 @@ library
|
||||||
Xanthous.Game.Draw
|
Xanthous.Game.Draw
|
||||||
Xanthous.Game.Env
|
Xanthous.Game.Env
|
||||||
Xanthous.Game.Lenses
|
Xanthous.Game.Lenses
|
||||||
|
Xanthous.Game.Memo
|
||||||
Xanthous.Game.Prompt
|
Xanthous.Game.Prompt
|
||||||
Xanthous.Game.State
|
Xanthous.Game.State
|
||||||
Xanthous.Generators
|
Xanthous.Generators
|
||||||
|
@ -142,7 +144,6 @@ library
|
||||||
, filepath
|
, filepath
|
||||||
, generic-arbitrary
|
, generic-arbitrary
|
||||||
, generic-lens
|
, generic-lens
|
||||||
, generic-monoid
|
|
||||||
, groups
|
, groups
|
||||||
, hgeometry
|
, hgeometry
|
||||||
, hgeometry-combinatorial
|
, hgeometry-combinatorial
|
||||||
|
@ -166,6 +167,7 @@ library
|
||||||
, raw-strings-qq
|
, raw-strings-qq
|
||||||
, reflection
|
, reflection
|
||||||
, semigroupoids
|
, semigroupoids
|
||||||
|
, semigroups
|
||||||
, splitmix
|
, splitmix
|
||||||
, stache
|
, stache
|
||||||
, streams
|
, streams
|
||||||
|
@ -198,6 +200,7 @@ executable xanthous
|
||||||
Xanthous.Data.EntityMap
|
Xanthous.Data.EntityMap
|
||||||
Xanthous.Data.EntityMap.Graphics
|
Xanthous.Data.EntityMap.Graphics
|
||||||
Xanthous.Data.Levels
|
Xanthous.Data.Levels
|
||||||
|
Xanthous.Data.Memo
|
||||||
Xanthous.Data.NestedMap
|
Xanthous.Data.NestedMap
|
||||||
Xanthous.Data.VectorBag
|
Xanthous.Data.VectorBag
|
||||||
Xanthous.Entities.Character
|
Xanthous.Entities.Character
|
||||||
|
@ -215,6 +218,7 @@ executable xanthous
|
||||||
Xanthous.Game.Draw
|
Xanthous.Game.Draw
|
||||||
Xanthous.Game.Env
|
Xanthous.Game.Env
|
||||||
Xanthous.Game.Lenses
|
Xanthous.Game.Lenses
|
||||||
|
Xanthous.Game.Memo
|
||||||
Xanthous.Game.Prompt
|
Xanthous.Game.Prompt
|
||||||
Xanthous.Game.State
|
Xanthous.Game.State
|
||||||
Xanthous.Generators
|
Xanthous.Generators
|
||||||
|
@ -295,7 +299,6 @@ executable xanthous
|
||||||
, filepath
|
, filepath
|
||||||
, generic-arbitrary
|
, generic-arbitrary
|
||||||
, generic-lens
|
, generic-lens
|
||||||
, generic-monoid
|
|
||||||
, groups
|
, groups
|
||||||
, hgeometry
|
, hgeometry
|
||||||
, hgeometry-combinatorial
|
, hgeometry-combinatorial
|
||||||
|
@ -319,6 +322,7 @@ executable xanthous
|
||||||
, raw-strings-qq
|
, raw-strings-qq
|
||||||
, reflection
|
, reflection
|
||||||
, semigroupoids
|
, semigroupoids
|
||||||
|
, semigroups
|
||||||
, splitmix
|
, splitmix
|
||||||
, stache
|
, stache
|
||||||
, streams
|
, streams
|
||||||
|
@ -344,6 +348,7 @@ test-suite test
|
||||||
Xanthous.Data.EntityMap.GraphicsSpec
|
Xanthous.Data.EntityMap.GraphicsSpec
|
||||||
Xanthous.Data.EntityMapSpec
|
Xanthous.Data.EntityMapSpec
|
||||||
Xanthous.Data.LevelsSpec
|
Xanthous.Data.LevelsSpec
|
||||||
|
Xanthous.Data.MemoSpec
|
||||||
Xanthous.Data.NestedMapSpec
|
Xanthous.Data.NestedMapSpec
|
||||||
Xanthous.DataSpec
|
Xanthous.DataSpec
|
||||||
Xanthous.Entities.RawsSpec
|
Xanthous.Entities.RawsSpec
|
||||||
|
@ -415,7 +420,6 @@ test-suite test
|
||||||
, filepath
|
, filepath
|
||||||
, generic-arbitrary
|
, generic-arbitrary
|
||||||
, generic-lens
|
, generic-lens
|
||||||
, generic-monoid
|
|
||||||
, groups
|
, groups
|
||||||
, hgeometry
|
, hgeometry
|
||||||
, hgeometry-combinatorial
|
, hgeometry-combinatorial
|
||||||
|
@ -440,6 +444,7 @@ test-suite test
|
||||||
, raw-strings-qq
|
, raw-strings-qq
|
||||||
, reflection
|
, reflection
|
||||||
, semigroupoids
|
, semigroupoids
|
||||||
|
, semigroups
|
||||||
, splitmix
|
, splitmix
|
||||||
, stache
|
, stache
|
||||||
, streams
|
, streams
|
||||||
|
@ -523,7 +528,6 @@ benchmark benchmark
|
||||||
, filepath
|
, filepath
|
||||||
, generic-arbitrary
|
, generic-arbitrary
|
||||||
, generic-lens
|
, generic-lens
|
||||||
, generic-monoid
|
|
||||||
, groups
|
, groups
|
||||||
, hgeometry
|
, hgeometry
|
||||||
, hgeometry-combinatorial
|
, hgeometry-combinatorial
|
||||||
|
@ -547,6 +551,7 @@ benchmark benchmark
|
||||||
, raw-strings-qq
|
, raw-strings-qq
|
||||||
, reflection
|
, reflection
|
||||||
, semigroupoids
|
, semigroupoids
|
||||||
|
, semigroups
|
||||||
, splitmix
|
, splitmix
|
||||||
, stache
|
, stache
|
||||||
, streams
|
, streams
|
||||||
|
|
Loading…
Reference in a new issue