Display multiple messages per turn
When tracking message history, save messages associated with the turn they were displayed on, which allows us to have the notion of the "current turn's" messages (provided via a MonoComonad instance).
This commit is contained in:
parent
272ff5b3e6
commit
5c6ba40019
7 changed files with 84 additions and 28 deletions
|
@ -103,7 +103,7 @@ handleEvent ev = use promptState >>= \case
|
||||||
handleNoPromptEvent :: BrickEvent Name () -> AppM (Next GameState)
|
handleNoPromptEvent :: BrickEvent Name () -> AppM (Next GameState)
|
||||||
handleNoPromptEvent (VtyEvent (EvKey k mods))
|
handleNoPromptEvent (VtyEvent (EvKey k mods))
|
||||||
| Just command <- commandFromKey k mods
|
| Just command <- commandFromKey k mods
|
||||||
= do messageHistory %= hideMessage
|
= do messageHistory %= nextTurn
|
||||||
handleCommand command
|
handleCommand command
|
||||||
handleNoPromptEvent _ = continue
|
handleNoPromptEvent _ = continue
|
||||||
|
|
||||||
|
@ -135,7 +135,7 @@ handleCommand PickUp = do
|
||||||
continue
|
continue
|
||||||
|
|
||||||
handleCommand PreviousMessage = do
|
handleCommand PreviousMessage = do
|
||||||
messageHistory %= popMessage
|
messageHistory %= previousMessage
|
||||||
continue
|
continue
|
||||||
|
|
||||||
handleCommand Open = do
|
handleCommand Open = do
|
||||||
|
|
|
@ -14,10 +14,14 @@ module Xanthous.Game
|
||||||
, characterPosition
|
, characterPosition
|
||||||
, updateCharacterVision
|
, updateCharacterVision
|
||||||
|
|
||||||
|
-- * Messages
|
||||||
, MessageHistory(..)
|
, MessageHistory(..)
|
||||||
|
, HasMessages(..)
|
||||||
|
, HasTurn(..)
|
||||||
|
, HasDisplayedTurn(..)
|
||||||
, pushMessage
|
, pushMessage
|
||||||
, popMessage
|
, previousMessage
|
||||||
, hideMessage
|
, nextTurn
|
||||||
|
|
||||||
-- * Collisions
|
-- * Collisions
|
||||||
, Collision(..)
|
, Collision(..)
|
||||||
|
|
|
@ -8,7 +8,6 @@ import Brick hiding (loc)
|
||||||
import Brick.Widgets.Border
|
import Brick.Widgets.Border
|
||||||
import Brick.Widgets.Border.Style
|
import Brick.Widgets.Border.Style
|
||||||
import Brick.Widgets.Edit
|
import Brick.Widgets.Edit
|
||||||
import Data.List.NonEmpty(NonEmpty((:|)))
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Data (Position(Position), x, y, loc)
|
import Xanthous.Data (Position(Position), x, y, loc)
|
||||||
import Xanthous.Data.EntityMap (EntityMap, atPosition)
|
import Xanthous.Data.EntityMap (EntityMap, atPosition)
|
||||||
|
@ -34,9 +33,7 @@ import Xanthous.Orphans ()
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
drawMessages :: MessageHistory -> Widget Name
|
drawMessages :: MessageHistory -> Widget Name
|
||||||
drawMessages NoMessageHistory = emptyWidget
|
drawMessages = txt . (<> " ") . unwords . oextract
|
||||||
drawMessages (MessageHistory _ False) = str " "
|
|
||||||
drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
|
|
||||||
|
|
||||||
drawPromptState :: GamePromptState m -> Widget Name
|
drawPromptState :: GamePromptState m -> Widget Name
|
||||||
drawPromptState NoPrompt = emptyWidget
|
drawPromptState NoPrompt = emptyWidget
|
||||||
|
|
|
@ -36,7 +36,7 @@ getInitialState = do
|
||||||
(Position 0 0)
|
(Position 0 0)
|
||||||
(SomeEntity char)
|
(SomeEntity char)
|
||||||
mempty
|
mempty
|
||||||
_messageHistory = NoMessageHistory
|
_messageHistory = mempty
|
||||||
_revealedPositions = mempty
|
_revealedPositions = mempty
|
||||||
_promptState = NoPrompt
|
_promptState = NoPrompt
|
||||||
_debugState = DebugState
|
_debugState = DebugState
|
||||||
|
|
|
@ -14,9 +14,12 @@ module Xanthous.Game.State
|
||||||
|
|
||||||
-- * Messages
|
-- * Messages
|
||||||
, MessageHistory(..)
|
, MessageHistory(..)
|
||||||
|
, HasMessages(..)
|
||||||
|
, HasTurn(..)
|
||||||
|
, HasDisplayedTurn(..)
|
||||||
, pushMessage
|
, pushMessage
|
||||||
, popMessage
|
, previousMessage
|
||||||
, hideMessage
|
, nextTurn
|
||||||
|
|
||||||
-- * App monad
|
-- * App monad
|
||||||
, AppT(..)
|
, AppT(..)
|
||||||
|
@ -61,27 +64,54 @@ import Xanthous.Resource
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
data MessageHistory
|
data MessageHistory
|
||||||
= NoMessageHistory
|
= MessageHistory
|
||||||
| MessageHistory (NonEmpty Text) Bool
|
{ _messages :: Map Word (NonEmpty Text)
|
||||||
|
, _turn :: Word
|
||||||
|
, _displayedTurn :: Maybe Word
|
||||||
|
}
|
||||||
deriving stock (Show, Eq, Generic)
|
deriving stock (Show, Eq, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function)
|
deriving anyclass (NFData, CoArbitrary, Function)
|
||||||
|
makeFieldsNoPrefix ''MessageHistory
|
||||||
|
|
||||||
|
instance Semigroup MessageHistory where
|
||||||
|
(MessageHistory msgs₁ turn₁ dt₁) <> (MessageHistory msgs₂ turn₂ dt₂) =
|
||||||
|
MessageHistory (msgs₁ <> msgs₂) (max turn₁ turn₂) $ case (dt₁, dt₂) of
|
||||||
|
(_, Nothing) -> Nothing
|
||||||
|
(Just t, _) -> Just t
|
||||||
|
(Nothing, Just t) -> Just t
|
||||||
|
|
||||||
|
instance Monoid MessageHistory where
|
||||||
|
mempty = MessageHistory mempty 0 Nothing
|
||||||
|
|
||||||
instance Arbitrary MessageHistory where
|
instance Arbitrary MessageHistory where
|
||||||
arbitrary = genericArbitrary
|
arbitrary = genericArbitrary
|
||||||
|
|
||||||
|
type instance Element MessageHistory = [Text]
|
||||||
|
instance MonoFunctor MessageHistory where
|
||||||
|
omap f mh@(MessageHistory _ t _) =
|
||||||
|
mh & messages . at t %~ (NonEmpty.nonEmpty . f . toList =<<)
|
||||||
|
|
||||||
|
instance MonoComonad MessageHistory where
|
||||||
|
oextract (MessageHistory ms t dt) = maybe [] toList $ ms ^. at (fromMaybe t dt)
|
||||||
|
oextend cok mh@(MessageHistory _ t dt) =
|
||||||
|
mh & messages . at (fromMaybe t dt) .~ NonEmpty.nonEmpty (cok mh)
|
||||||
|
|
||||||
pushMessage :: Text -> MessageHistory -> MessageHistory
|
pushMessage :: Text -> MessageHistory -> MessageHistory
|
||||||
pushMessage msg NoMessageHistory = MessageHistory (msg :| []) True
|
pushMessage msg mh@(MessageHistory _ turn' _) =
|
||||||
pushMessage msg (MessageHistory msgs _) = MessageHistory (NonEmpty.cons msg msgs) True
|
mh
|
||||||
|
& messages . at turn' %~ \case
|
||||||
|
Nothing -> Just $ msg :| mempty
|
||||||
|
Just msgs -> Just $ msg <| msgs
|
||||||
|
& displayedTurn .~ Nothing
|
||||||
|
|
||||||
popMessage :: MessageHistory -> MessageHistory
|
nextTurn :: MessageHistory -> MessageHistory
|
||||||
popMessage NoMessageHistory = NoMessageHistory
|
nextTurn = (turn +~ 1) . (displayedTurn .~ Nothing)
|
||||||
popMessage (MessageHistory msgs False) = MessageHistory msgs True
|
|
||||||
popMessage (MessageHistory msgs@(_ :| []) _) = MessageHistory msgs True
|
previousMessage :: MessageHistory -> MessageHistory
|
||||||
popMessage (MessageHistory (_ :| (msg : msgs)) True) = MessageHistory (msg :| msgs) True
|
previousMessage mh = mh & displayedTurn .~ maximumOf
|
||||||
|
(messages . ifolded . asIndex . filtered (< mh ^. turn))
|
||||||
|
mh
|
||||||
|
|
||||||
hideMessage :: MessageHistory -> MessageHistory
|
|
||||||
hideMessage NoMessageHistory = NoMessageHistory
|
|
||||||
hideMessage (MessageHistory msgs _) = MessageHistory msgs False
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
|
@ -152,7 +182,7 @@ instance Eq SomeEntity where
|
||||||
Just Refl -> a == b
|
Just Refl -> a == b
|
||||||
_ -> False
|
_ -> False
|
||||||
|
|
||||||
instance Draw (SomeEntity) where
|
instance Draw SomeEntity where
|
||||||
drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
|
drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
|
||||||
|
|
||||||
instance Brain SomeEntity where
|
instance Brain SomeEntity where
|
||||||
|
|
|
@ -25,7 +25,8 @@ import Text.Mustache.Type ( showKey )
|
||||||
|
|
||||||
instance forall s a.
|
instance forall s a.
|
||||||
( Cons s s a a
|
( Cons s s a a
|
||||||
, MonoFoldable s
|
, IsSequence s
|
||||||
|
, Element s ~ a
|
||||||
) => Cons (NonNull s) (NonNull s) a a where
|
) => Cons (NonNull s) (NonNull s) a a where
|
||||||
_Cons = prism hither yon
|
_Cons = prism hither yon
|
||||||
where
|
where
|
||||||
|
@ -35,9 +36,21 @@ instance forall s a.
|
||||||
in impureNonNull $ a <| s
|
in impureNonNull $ a <| s
|
||||||
|
|
||||||
yon :: NonNull s -> Either (NonNull s) (a, NonNull s)
|
yon :: NonNull s -> Either (NonNull s) (a, NonNull s)
|
||||||
yon ns = case ns ^? _Cons of
|
yon ns = case nuncons ns of
|
||||||
Nothing -> Left ns
|
(_, Nothing) -> Left ns
|
||||||
Just (a, ns') -> Right (a, ns')
|
(x, Just xs) -> Right (x, xs)
|
||||||
|
|
||||||
|
instance forall a. Cons (NonEmpty a) (NonEmpty a) a a where
|
||||||
|
_Cons = prism hither yon
|
||||||
|
where
|
||||||
|
hither :: (a, NonEmpty a) -> NonEmpty a
|
||||||
|
hither (a, x :| xs) = a :| (x : xs)
|
||||||
|
|
||||||
|
yon :: NonEmpty a -> Either (NonEmpty a) (a, NonEmpty a)
|
||||||
|
yon ns@(x :| xs) = case xs of
|
||||||
|
(y : ys) -> Right (x, y :| ys)
|
||||||
|
[] -> Left ns
|
||||||
|
|
||||||
|
|
||||||
instance Arbitrary PName where
|
instance Arbitrary PName where
|
||||||
arbitrary = PName . pack <$> listOf1 (elements ['a'..'z'])
|
arbitrary = PName . pack <$> listOf1 (elements ['a'..'z'])
|
||||||
|
|
|
@ -30,4 +30,16 @@ test = testGroup "Xanthous.Game"
|
||||||
, testGroup "character"
|
, testGroup "character"
|
||||||
[ testProperty "lens laws" $ isLens character
|
[ testProperty "lens laws" $ isLens character
|
||||||
]
|
]
|
||||||
|
, localOption (QuickCheckTests 10)
|
||||||
|
$ testGroup "MessageHistory"
|
||||||
|
[ testGroup "MonoComonad laws"
|
||||||
|
[ testProperty "oextend oextract ≡ id"
|
||||||
|
$ \(mh :: MessageHistory) -> oextend oextract mh === mh
|
||||||
|
, testProperty "oextract ∘ oextend f ≡ f"
|
||||||
|
$ \(mh :: MessageHistory) f -> (oextract . oextend f) mh === f mh
|
||||||
|
, testProperty "oextend f ∘ oextend g ≡ oextend (f . oextend g)"
|
||||||
|
$ \(mh :: MessageHistory) f g ->
|
||||||
|
(oextend f . oextend g) mh === oextend (f . oextend g) mh
|
||||||
|
]
|
||||||
|
]
|
||||||
]
|
]
|
||||||
|
|
Loading…
Reference in a new issue