diff options
Diffstat (limited to 'users/grfn/xanthous/src')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/App.hs | 4 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Data/Memo.hs | 98 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs | 1 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Draw.hs | 72 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Lenses.hs | 49 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Memo.hs | 52 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/State.hs | 4 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Prelude.hs | 1 |
8 files changed, 225 insertions, 56 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs index 9091961b725c..f96662689e50 100644 --- a/users/grfn/xanthous/src/Xanthous/App.hs +++ b/users/grfn/xanthous/src/Xanthous/App.hs @@ -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 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' 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) diff --git a/users/grfn/xanthous/src/Xanthous/Prelude.hs b/users/grfn/xanthous/src/Xanthous/Prelude.hs index 4d79b026f14a..2cb4299303ba 100644 --- a/users/grfn/xanthous/src/Xanthous/Prelude.hs +++ b/users/grfn/xanthous/src/Xanthous/Prelude.hs @@ -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) |