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:
parent
adb3b74c0c
commit
18551cdf30
5 changed files with 31 additions and 6 deletions
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue