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:
Griffin Smith 2019-10-05 16:18:11 -04:00
parent 272ff5b3e6
commit 5c6ba40019
7 changed files with 84 additions and 28 deletions

View file

@ -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

View file

@ -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(..)

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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'])

View file

@ -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
]
]
] ]