Add a previous message command

Add a "previous message" command, triggered via ctrl+p.

I attempted here to get the message area to still take up a row of space
post-hiding the message, but failed - should revisit that at some point
This commit is contained in:
Griffin Smith 2019-09-02 10:36:15 -04:00
parent adb3b74c0c
commit 18551cdf30
5 changed files with 31 additions and 6 deletions

View file

@ -35,7 +35,8 @@ startEvent = say ["welcome"]
handleEvent :: BrickEvent Name () -> AppM (Next GameState) handleEvent :: BrickEvent Name () -> AppM (Next GameState)
handleEvent (VtyEvent (EvKey k mods)) handleEvent (VtyEvent (EvKey k mods))
| Just command <- commandFromKey k mods | Just command <- commandFromKey k mods
= handleCommand command = do messageHistory %= hideMessage
handleCommand command
handleEvent _ = continue handleEvent _ = continue
handleCommand :: Command -> AppM (Next GameState) handleCommand :: Command -> AppM (Next GameState)
@ -43,4 +44,7 @@ handleCommand Quit = halt
handleCommand (Move dir) = do handleCommand (Move dir) = do
characterPosition %= move dir characterPosition %= move dir
continue continue
handleCommand _ = error "unimplemented"
handleCommand PreviousMessage = do
messageHistory %= popMessage
continue

View file

@ -8,8 +8,8 @@ import Xanthous.Data (Direction(..))
data Command data Command
= Quit = Quit
| Move Direction | Move Direction
| PickUp
| PreviousMessage | PreviousMessage
-- | PickUp
commandFromKey :: Key -> [Modifier] -> Maybe Command commandFromKey :: Key -> [Modifier] -> Maybe Command
commandFromKey (KChar 'q') [] = Just Quit commandFromKey (KChar 'q') [] = Just Quit
@ -17,4 +17,7 @@ commandFromKey (KChar 'h') [] = Just $ Move Left
commandFromKey (KChar 'j') [] = Just $ Move Down commandFromKey (KChar 'j') [] = Just $ Move Down
commandFromKey (KChar 'k') [] = Just $ Move Up commandFromKey (KChar 'k') [] = Just $ Move Up
commandFromKey (KChar 'l') [] = Just $ Move Right commandFromKey (KChar 'l') [] = Just $ Move Right
commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
commandFromKey _ _ = Nothing commandFromKey _ _ = Nothing

View file

@ -14,6 +14,8 @@ module Xanthous.Game
, MessageHistory(..) , MessageHistory(..)
, pushMessage , pushMessage
, popMessage
, hideMessage
) where ) where
import Data.List.NonEmpty ( NonEmpty((:|))) import Data.List.NonEmpty ( NonEmpty((:|)))
@ -43,6 +45,16 @@ pushMessage :: Text -> MessageHistory -> MessageHistory
pushMessage msg NoMessageHistory = MessageHistory (msg :| []) True pushMessage msg NoMessageHistory = MessageHistory (msg :| []) True
pushMessage msg (MessageHistory msgs _) = MessageHistory (NonEmpty.cons msg msgs) True pushMessage msg (MessageHistory msgs _) = MessageHistory (NonEmpty.cons msg msgs) True
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
hideMessage :: MessageHistory -> MessageHistory
hideMessage NoMessageHistory = NoMessageHistory
hideMessage (MessageHistory msgs _) = MessageHistory msgs False
data GameState = GameState data GameState = GameState
{ _entities :: EntityMap SomeEntity { _entities :: EntityMap SomeEntity
, _characterEntityID :: EntityID , _characterEntityID :: EntityID

View file

@ -26,7 +26,13 @@ import Xanthous.Orphans ()
drawMessages :: MessageHistory -> Widget Name drawMessages :: MessageHistory -> Widget Name
drawMessages NoMessageHistory = emptyWidget drawMessages NoMessageHistory = emptyWidget
drawMessages (MessageHistory _ False) = emptyWidget drawMessages (MessageHistory _ False) = emptyWidget
drawMessages (MessageHistory (lastMessage :| _) True) = str $ unpack lastMessage drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
-- an attempt to still take up a row even when no messages
-- drawMessages msgs = vLimit 1 . Widget Greedy Fixed . render $ case msgs of
-- NoMessageHistory -> padTop (Pad 2) $ str " "
-- (MessageHistory _ False) -> padTop (Pad 2) $ str " "
-- (MessageHistory (lastMessage :| _) True) -> txt lastMessage
drawEntities :: (Draw a, Show a) => EntityMap a -> Widget Name drawEntities :: (Draw a, Show a) => EntityMap a -> Widget Name
drawEntities em@(fromNullable . positions -> Just entityPositions) drawEntities em@(fromNullable . positions -> Just entityPositions)

View file

@ -15,8 +15,8 @@ test = testGroup "Xanthous.Game"
[ testGroup "positionedCharacter" [ testGroup "positionedCharacter"
[ testProperty "lens laws" $ isLens positionedCharacter [ testProperty "lens laws" $ isLens positionedCharacter
, testCase "updates the position of the character" $ do , testCase "updates the position of the character" $ do
let initialGame = getInitialState initialGame <- getInitialState
initialPos = initialGame ^. characterPosition let initialPos = initialGame ^. characterPosition
updatedGame = initialGame & characterPosition %~ move Down updatedGame = initialGame & characterPosition %~ move Down
updatedPos = updatedGame ^. characterPosition updatedPos = updatedGame ^. characterPosition
updatedPos @?= move Down initialPos updatedPos @?= move Down initialPos