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 (VtyEvent (EvKey k mods))
| Just command <- commandFromKey k mods
= do messageHistory %= hideMessage
= do messageHistory %= nextTurn
handleCommand command
handleNoPromptEvent _ = continue
@ -135,7 +135,7 @@ handleCommand PickUp = do
continue
handleCommand PreviousMessage = do
messageHistory %= popMessage
messageHistory %= previousMessage
continue
handleCommand Open = do

View file

@ -14,10 +14,14 @@ module Xanthous.Game
, characterPosition
, updateCharacterVision
-- * Messages
, MessageHistory(..)
, HasMessages(..)
, HasTurn(..)
, HasDisplayedTurn(..)
, pushMessage
, popMessage
, hideMessage
, previousMessage
, nextTurn
-- * Collisions
, Collision(..)

View file

@ -8,7 +8,6 @@ import Brick hiding (loc)
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Edit
import Data.List.NonEmpty(NonEmpty((:|)))
--------------------------------------------------------------------------------
import Xanthous.Data (Position(Position), x, y, loc)
import Xanthous.Data.EntityMap (EntityMap, atPosition)
@ -34,9 +33,7 @@ import Xanthous.Orphans ()
--------------------------------------------------------------------------------
drawMessages :: MessageHistory -> Widget Name
drawMessages NoMessageHistory = emptyWidget
drawMessages (MessageHistory _ False) = str " "
drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
drawMessages = txt . (<> " ") . unwords . oextract
drawPromptState :: GamePromptState m -> Widget Name
drawPromptState NoPrompt = emptyWidget

View file

@ -36,7 +36,7 @@ getInitialState = do
(Position 0 0)
(SomeEntity char)
mempty
_messageHistory = NoMessageHistory
_messageHistory = mempty
_revealedPositions = mempty
_promptState = NoPrompt
_debugState = DebugState

View file

@ -14,9 +14,12 @@ module Xanthous.Game.State
-- * Messages
, MessageHistory(..)
, HasMessages(..)
, HasTurn(..)
, HasDisplayedTurn(..)
, pushMessage
, popMessage
, hideMessage
, previousMessage
, nextTurn
-- * App monad
, AppT(..)
@ -61,27 +64,54 @@ import Xanthous.Resource
--------------------------------------------------------------------------------
data MessageHistory
= NoMessageHistory
| MessageHistory (NonEmpty Text) Bool
= MessageHistory
{ _messages :: Map Word (NonEmpty Text)
, _turn :: Word
, _displayedTurn :: Maybe Word
}
deriving stock (Show, Eq, Generic)
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
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 msg NoMessageHistory = MessageHistory (msg :| []) True
pushMessage msg (MessageHistory msgs _) = MessageHistory (NonEmpty.cons msg msgs) True
pushMessage msg mh@(MessageHistory _ turn' _) =
mh
& messages . at turn' %~ \case
Nothing -> Just $ msg :| mempty
Just msgs -> Just $ msg <| msgs
& displayedTurn .~ Nothing
popMessage :: MessageHistory -> MessageHistory
popMessage NoMessageHistory = NoMessageHistory
popMessage (MessageHistory msgs False) = MessageHistory msgs True
popMessage (MessageHistory msgs@(_ :| []) _) = MessageHistory msgs True
popMessage (MessageHistory (_ :| (msg : msgs)) True) = MessageHistory (msg :| msgs) True
nextTurn :: MessageHistory -> MessageHistory
nextTurn = (turn +~ 1) . (displayedTurn .~ Nothing)
previousMessage :: MessageHistory -> MessageHistory
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
_ -> False
instance Draw (SomeEntity) where
instance Draw SomeEntity where
drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
instance Brain SomeEntity where

View file

@ -25,7 +25,8 @@ import Text.Mustache.Type ( showKey )
instance forall s a.
( Cons s s a a
, MonoFoldable s
, IsSequence s
, Element s ~ a
) => Cons (NonNull s) (NonNull s) a a where
_Cons = prism hither yon
where
@ -35,9 +36,21 @@ instance forall s a.
in impureNonNull $ a <| s
yon :: NonNull s -> Either (NonNull s) (a, NonNull s)
yon ns = case ns ^? _Cons of
Nothing -> Left ns
Just (a, ns') -> Right (a, ns')
yon ns = case nuncons ns of
(_, Nothing) -> Left 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
arbitrary = PName . pack <$> listOf1 (elements ['a'..'z'])

View file

@ -30,4 +30,16 @@ test = testGroup "Xanthous.Game"
, testGroup "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
]
]
]