From 5c6ba40019ea23660cfab80864593b398567f223 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 5 Oct 2019 16:18:11 -0400 Subject: [PATCH] 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). --- src/Xanthous/App.hs | 4 +-- src/Xanthous/Game.hs | 8 +++-- src/Xanthous/Game/Draw.hs | 5 +--- src/Xanthous/Game/Lenses.hs | 2 +- src/Xanthous/Game/State.hs | 60 +++++++++++++++++++++++++++---------- src/Xanthous/Orphans.hs | 21 ++++++++++--- test/Xanthous/GameSpec.hs | 12 ++++++++ 7 files changed, 84 insertions(+), 28 deletions(-) diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 02f6f0987..72c9a3f55 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -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 diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs index 2b346ace5..0ab5425a0 100644 --- a/src/Xanthous/Game.hs +++ b/src/Xanthous/Game.hs @@ -14,10 +14,14 @@ module Xanthous.Game , characterPosition , updateCharacterVision + -- * Messages , MessageHistory(..) + , HasMessages(..) + , HasTurn(..) + , HasDisplayedTurn(..) , pushMessage - , popMessage - , hideMessage + , previousMessage + , nextTurn -- * Collisions , Collision(..) diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index e1242f2b7..addeaa14c 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -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 diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs index e077e339c..101de3021 100644 --- a/src/Xanthous/Game/Lenses.hs +++ b/src/Xanthous/Game/Lenses.hs @@ -36,7 +36,7 @@ getInitialState = do (Position 0 0) (SomeEntity char) mempty - _messageHistory = NoMessageHistory + _messageHistory = mempty _revealedPositions = mempty _promptState = NoPrompt _debugState = DebugState diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 00785bf12..302d20e1e 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -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 diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs index 22325f636..610067a37 100644 --- a/src/Xanthous/Orphans.hs +++ b/src/Xanthous/Orphans.hs @@ -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']) diff --git a/test/Xanthous/GameSpec.hs b/test/Xanthous/GameSpec.hs index 32faae03d..af98c7f6c 100644 --- a/test/Xanthous/GameSpec.hs +++ b/test/Xanthous/GameSpec.hs @@ -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 + ] + ] ]