From adb3b74c0c3a3bffa0d47f52036fde3623f859f7 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sun, 1 Sep 2019 16:21:45 -0400 Subject: Link up messages to the overall game Add a "say" function for saying messages within an app monad to the user, and link everything up to display them and track their history --- src/Main.hs | 2 +- src/Xanthous/App.hs | 29 +++++++++++++------- src/Xanthous/Game.hs | 68 ++++++++++++++++++++++++++++++++++++----------- src/Xanthous/Game/Draw.hs | 18 ++++++++++--- src/Xanthous/Messages.hs | 12 ++++----- src/Xanthous/Monad.hs | 58 ++++++++++++++++++++++++++++++++++++++++ src/Xanthous/Prelude.hs | 2 +- src/Xanthous/Random.hs | 1 - 8 files changed, 152 insertions(+), 38 deletions(-) create mode 100644 src/Xanthous/Monad.hs (limited to 'src') diff --git a/src/Main.hs b/src/Main.hs index de867067b971..1cd4e9445789 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -12,6 +12,6 @@ ui = str "Hello, world!" main :: IO () main = do app <- makeApp - let initialState = getInitialState + initialState <- getInitialState _ <- defaultMain app initialState pure () diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index ae88a746cec6..c543ad468f6d 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -1,35 +1,46 @@ module Xanthous.App (makeApp) where import Xanthous.Prelude -import Brick hiding (App) +import Brick hiding (App, halt, continue) import qualified Brick import Graphics.Vty.Attributes (defAttr) import Graphics.Vty.Input.Events (Event(EvKey)) +import Control.Monad.State (get) import Xanthous.Game import Xanthous.Game.Draw (drawGame) import Xanthous.Resource (Name) import Xanthous.Command import Xanthous.Data (move) +import Xanthous.Monad type App = Brick.App GameState () Name +type AppM a = AppT (EventM Name) a makeApp :: IO App makeApp = pure $ Brick.App { appDraw = drawGame , appChooseCursor = const headMay - , appHandleEvent = handleEvent - , appStartEvent = pure + , appHandleEvent = \state event -> runAppM (handleEvent event) state + , appStartEvent = runAppM $ startEvent >> get , appAttrMap = const $ attrMap defAttr [] } -handleEvent :: GameState -> BrickEvent Name () -> EventM Name (Next GameState) -handleEvent game (VtyEvent (EvKey k mods)) +runAppM :: AppM a -> GameState -> EventM Name a +runAppM appm = fmap fst . runAppT appm + +startEvent :: AppM () +startEvent = say ["welcome"] + +handleEvent :: BrickEvent Name () -> AppM (Next GameState) +handleEvent (VtyEvent (EvKey k mods)) | Just command <- commandFromKey k mods - = handleCommand command game -handleEvent game _ = continue game + = handleCommand command +handleEvent _ = continue -handleCommand :: Command -> GameState -> EventM Name (Next GameState) +handleCommand :: Command -> AppM (Next GameState) handleCommand Quit = halt -handleCommand (Move dir) = continue . (characterPosition %~ move dir) +handleCommand (Move dir) = do + characterPosition %= move dir + continue handleCommand _ = error "unimplemented" diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs index f30f7534392f..39066c23b622 100644 --- a/src/Xanthous/Game.hs +++ b/src/Xanthous/Game.hs @@ -3,46 +3,82 @@ module Xanthous.Game ( GameState(..) , entities + , messageHistory + , randomGen + , getInitialState , positionedCharacter , character , characterPosition + + , MessageHistory(..) + , pushMessage ) where -import Xanthous.Prelude -import Test.QuickCheck.Arbitrary +import Data.List.NonEmpty ( NonEmpty((:|))) +import qualified Data.List.NonEmpty as NonEmpty +import System.Random +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic +import Xanthous.Prelude -import Xanthous.Data.EntityMap (EntityMap, EntityID) +import Xanthous.Data.EntityMap (EntityMap, EntityID) import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Data (Positioned, Position(..), positioned, position) -import Xanthous.Entities.SomeEntity -import Xanthous.Entities.Character +import Xanthous.Data (Positioned, Position(..), positioned, position) +import Xanthous.Entities.SomeEntity +import Xanthous.Entities.Character +import Xanthous.Orphans () + +data MessageHistory + = NoMessageHistory + | MessageHistory (NonEmpty Text) Bool + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + +instance Arbitrary MessageHistory where + arbitrary = genericArbitrary + +pushMessage :: Text -> MessageHistory -> MessageHistory +pushMessage msg NoMessageHistory = MessageHistory (msg :| []) True +pushMessage msg (MessageHistory msgs _) = MessageHistory (NonEmpty.cons msg msgs) True data GameState = GameState { _entities :: EntityMap SomeEntity , _characterEntityID :: EntityID + , _messageHistory :: MessageHistory + , _randomGen :: StdGen } - deriving stock (Show, Eq) + deriving stock (Show) makeLenses ''GameState +instance Eq GameState where + (GameState es₁ ceid₁ mh₁ _) == (GameState es₂ ceid₂ mh₂ _) + = es₁ == es₂ + && ceid₁ == ceid₂ + && mh₁ == mh₂ + instance Arbitrary GameState where arbitrary = do - ents <- arbitrary - char <- arbitrary - pure $ getInitialState - & entities .~ ents - & positionedCharacter .~ char - -getInitialState :: GameState -getInitialState = + char <- arbitrary @Character + charPos <- arbitrary + _messageHistory <- arbitrary + (_characterEntityID, _entities) <- arbitrary <&> + EntityMap.insertAtReturningID charPos (SomeEntity char) + _randomGen <- mkStdGen <$> arbitrary + pure $ GameState {..} + +getInitialState :: IO GameState +getInitialState = do + _randomGen <- getStdGen let char = mkCharacter (_characterEntityID, _entities) = EntityMap.insertAtReturningID (Position 0 0) (SomeEntity char) mempty - in GameState {..} + _messageHistory = NoMessageHistory + pure GameState {..} positionedCharacter :: Lens' GameState (Positioned Character) positionedCharacter = lens getPositionedCharacter setPositionedCharacter diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index 79089029ea8d..5a2f773c1b18 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -8,15 +8,25 @@ import Xanthous.Prelude import Brick hiding (loc) import Brick.Widgets.Border import Brick.Widgets.Border.Style +import Data.List.NonEmpty(NonEmpty((:|))) import Xanthous.Data (Position(Position), x, y, loc) import Xanthous.Data.EntityMap import Xanthous.Entities -import Xanthous.Game (GameState(..), entities, characterPosition) +import Xanthous.Game + ( GameState(..) + , entities + , characterPosition + , MessageHistory(..) + , messageHistory + ) import Xanthous.Resource (Name(..)) +import Xanthous.Orphans () -drawMessages :: GameState -> Widget Name -drawMessages _ = str "Welcome to Xanthous! It's dangerous out there, why not stay inside?" +drawMessages :: MessageHistory -> Widget Name +drawMessages NoMessageHistory = emptyWidget +drawMessages (MessageHistory _ False) = emptyWidget +drawMessages (MessageHistory (lastMessage :| _) True) = str $ unpack lastMessage drawEntities :: (Draw a, Show a) => EntityMap a -> Widget Name drawEntities em@(fromNullable . positions -> Just entityPositions) @@ -41,5 +51,5 @@ drawGame :: GameState -> [Widget Name] drawGame game = pure . withBorderStyle unicode - $ drawMessages game + $ drawMessages (game ^. messageHistory) <=> border (drawMap game) diff --git a/src/Xanthous/Messages.hs b/src/Xanthous/Messages.hs index 4ff46ba3f5e7..b1aeeb635cc9 100644 --- a/src/Xanthous/Messages.hs +++ b/src/Xanthous/Messages.hs @@ -9,19 +9,19 @@ module Xanthous.Messages , messages , message ) where - +-------------------------------------------------------------------------------- import Xanthous.Prelude + +import Control.Monad.Random.Class (MonadRandom) +import Data.Aeson (FromJSON, ToJSON, toJSON) +import Data.Aeson.Generic.DerivingVia +import Data.FileEmbed import Data.List.NonEmpty import Test.QuickCheck hiding (choose) import Test.QuickCheck.Arbitrary.Generic import Test.QuickCheck.Instances.UnorderedContainers () import Text.Mustache -import Data.Aeson (FromJSON, ToJSON) -import Data.Aeson.Generic.DerivingVia -import Data.FileEmbed import qualified Data.Yaml as Yaml -import Data.Aeson (toJSON) -import Control.Monad.Random.Class (MonadRandom) import Xanthous.Random import Xanthous.Orphans () diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs new file mode 100644 index 000000000000..fb790d5f9cb2 --- /dev/null +++ b/src/Xanthous/Monad.hs @@ -0,0 +1,58 @@ +module Xanthous.Monad + ( AppT(..) + , runAppT + , continue + , halt + , say + ) where + +import Xanthous.Prelude +import Control.Monad.Random +import Control.Monad.State +import qualified Brick +import Brick (EventM, Next) +import Data.Aeson + +import Xanthous.Game +import Xanthous.Messages (message) + +newtype AppT m a + = AppT { unAppT :: StateT GameState m a } + deriving ( Functor + , Applicative + , Monad + , MonadState GameState + ) + via (StateT GameState m) + +instance MonadTrans AppT where + lift = AppT . lift + +instance (Monad m) => MonadRandom (AppT m) where + getRandomR rng = randomGen %%= randomR rng + getRandom = randomGen %%= random + getRandomRs rng = uses randomGen $ randomRs rng + getRandoms = uses randomGen randoms + +runAppT :: Monad m => AppT m a -> GameState -> m (a, GameState) +runAppT appt initialState = flip runStateT initialState . unAppT $ appt + +halt :: AppT (EventM n) (Next GameState) +halt = lift . Brick.halt =<< get + +continue :: AppT (EventM n) (Next GameState) +continue = lift . Brick.continue =<< get + +-- say :: [Text] -> AppT m () +-- say :: [Text] -> params -> AppT m () + +class SayR a where + say :: [Text] -> a + +instance Monad m => SayR (AppT m ()) where + say msgPath = say msgPath $ object [] + +instance (Monad m, ToJSON params) => SayR (params -> AppT m ()) where + say msgPath params = do + msg <- message msgPath params + messageHistory %= pushMessage msg diff --git a/src/Xanthous/Prelude.hs b/src/Xanthous/Prelude.hs index 20970809754b..756642440b7e 100644 --- a/src/Xanthous/Prelude.hs +++ b/src/Xanthous/Prelude.hs @@ -8,7 +8,7 @@ module Xanthous.Prelude ) where import ClassyPrelude hiding - (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index) + (return, (<|), unsnoc, uncons, cons, snoc, index, (<.>), Index, say) import Data.Kind import GHC.TypeLits hiding (Text) import Control.Lens diff --git a/src/Xanthous/Random.hs b/src/Xanthous/Random.hs index a3a1124f2780..33ada54cf105 100644 --- a/src/Xanthous/Random.hs +++ b/src/Xanthous/Random.hs @@ -8,7 +8,6 @@ module Xanthous.Random import Xanthous.Prelude import Data.List.NonEmpty (NonEmpty) -import System.Random import Control.Monad.Random.Class (MonadRandom(getRandomR)) class Choose a where -- cgit 1.4.1