From 7770ed05484a8a7aae4d5d680a069a0886a145dd Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Fri, 20 Sep 2019 12:03:30 -0400 Subject: Add the beginnings of a prompt system Add the beginnings of a generic prompt system, with exclusive support atm for string prompts, and test it out by asking the character for their name at startup --- src/Xanthous/App.hs | 87 +++++++++++++++++++++------ src/Xanthous/Data/EntityMap.hs | 27 +++++---- src/Xanthous/Entities/Character.hs | 9 +++ src/Xanthous/Game.hs | 44 ++++++++++++++ src/Xanthous/Game/Draw.hs | 68 +++++++++++---------- src/Xanthous/Game/Prompt.hs | 117 +++++++++++++++++++++++++++++++++++++ src/Xanthous/Monad.hs | 39 +++---------- src/Xanthous/Resource.hs | 1 + src/Xanthous/messages.yaml | 4 +- 9 files changed, 302 insertions(+), 94 deletions(-) create mode 100644 src/Xanthous/Game/Prompt.hs (limited to 'src/Xanthous') diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 0f49b4d8007c..0c7b85541ae0 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -4,11 +4,13 @@ module Xanthous.App (makeApp) where import Xanthous.Prelude import Brick hiding (App, halt, continue, raw) import qualified Brick +import Brick.Widgets.Edit (handleEditorEvent) import Graphics.Vty.Attributes (defAttr) -import Graphics.Vty.Input.Events (Event(EvKey)) -import Control.Monad.State (get) +import Graphics.Vty.Input.Events (Event(EvKey), Key(..)) +import Control.Monad.State (get, state, StateT(..)) +import Data.Coerce import Control.Monad.State.Class (modify) -import Data.Aeson (object) +import Data.Aeson (object, ToJSON) import qualified Data.Aeson as A -------------------------------------------------------------------------------- import Xanthous.Command @@ -20,14 +22,13 @@ import Xanthous.Data import qualified Xanthous.Data.EntityMap as EntityMap import Xanthous.Game import Xanthous.Game.Draw (drawGame) +import Xanthous.Game.Prompt import Xanthous.Monad import Xanthous.Resource (Name) +import Xanthous.Messages (message) -------------------------------------------------------------------------------- -import Xanthous.Entities.Creature (Creature) -import qualified Xanthous.Entities.Creature as Creature import qualified Xanthous.Entities.Character as Character -import Xanthous.Entities.RawTypes (EntityRaw(..)) -import Xanthous.Entities.Raws (raw) +import Xanthous.Entities.Character (characterName) import Xanthous.Entities import Xanthous.Entities.Item (Item) import Xanthous.Generators @@ -41,7 +42,7 @@ makeApp :: IO App makeApp = pure $ Brick.App { appDraw = drawGame , appChooseCursor = const headMay - , appHandleEvent = \state event -> runAppM (handleEvent event) state + , appHandleEvent = \game event -> runAppM (handleEvent event) game , appStartEvent = runAppM $ startEvent >> get , appAttrMap = const $ attrMap defAttr [] } @@ -49,14 +50,13 @@ makeApp = pure $ Brick.App runAppM :: AppM a -> GameState -> EventM Name a runAppM appm = fmap fst . runAppT appm -testGormlak :: Creature -testGormlak = - let Just (Creature gormlak) = raw "gormlak" - in Creature.newWithType gormlak +-- testGormlak :: Creature +-- testGormlak = +-- let Just (Creature gormlak) = raw "gormlak" +-- in Creature.newWithType gormlak startEvent :: AppM () startEvent = do - say_ ["welcome"] level <- generateLevel SCaveAutomata CaveAutomata.defaultParams $ Dimensions 80 80 @@ -64,15 +64,23 @@ startEvent = do entities <>= (SomeEntity <$> level ^. levelItems) characterPosition .= level ^. levelCharacterPosition modify updateCharacterVision - -- entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak) - + prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable + $ \(StringResult s) -> do + character . characterName ?= s + say ["welcome"] =<< use character handleEvent :: BrickEvent Name () -> AppM (Next GameState) -handleEvent (VtyEvent (EvKey k mods)) +handleEvent ev = use promptState >>= \case + NoPrompt -> handleNoPromptEvent ev + WaitingPrompt msg pr -> handlePromptEvent msg pr ev + + +handleNoPromptEvent :: BrickEvent Name () -> AppM (Next GameState) +handleNoPromptEvent (VtyEvent (EvKey k mods)) | Just command <- commandFromKey k mods = do messageHistory %= hideMessage handleCommand command -handleEvent _ = continue +handleNoPromptEvent _ = continue handleCommand :: Command -> AppM (Next GameState) handleCommand Quit = halt @@ -106,3 +114,48 @@ handleCommand PreviousMessage = do messageHistory %= popMessage continue +handlePromptEvent + :: Text -- ^ Prompt message + -> Prompt (AppT Identity) + -> BrickEvent Name () + -> AppM (Next GameState) +handlePromptEvent _ (Prompt Cancellable _ _ _) (VtyEvent (EvKey KEsc [])) = do + promptState .= NoPrompt + continue +handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) = do + () <- state . coerce $ submitPrompt pr + promptState .= NoPrompt + continue +handlePromptEvent + msg + (Prompt c SStringPrompt (StringPromptState edit) cb) + (VtyEvent ev) + = do + edit' <- lift $ handleEditorEvent ev edit + let prompt' = Prompt c SStringPrompt (StringPromptState edit') cb + promptState .= WaitingPrompt msg prompt' + continue +handlePromptEvent _ _ _ = undefined + +prompt + :: forall (pt :: PromptType) (params :: Type). + (ToJSON params, SingPromptType pt) + => [Text] -- ^ Message key + -> params -- ^ Message params + -> PromptCancellable + -> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler + -> AppM () +prompt msgPath params cancellable cb = do + let pt = singPromptType @pt + msg <- message msgPath params + let p = mkPrompt cancellable pt cb + promptState .= WaitingPrompt msg p + +prompt_ + :: forall (pt :: PromptType) . + (SingPromptType pt) + => [Text] -- ^ Message key + -> PromptCancellable + -> (PromptResult pt -> AppT Identity ()) -- ^ Prompt promise handler + -> AppM () +prompt_ msg = prompt msg $ object [] diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs index 926a02a48ce1..7885839d51b0 100644 --- a/src/Xanthous/Data/EntityMap.hs +++ b/src/Xanthous/Data/EntityMap.hs @@ -23,7 +23,10 @@ module Xanthous.Data.EntityMap , neighbors , Deduplicate(..) - -- * Querying an entityMap + -- * debug + , byID + , byPosition + ) where -------------------------------------------------------------------------------- import Xanthous.Prelude hiding (lookup) @@ -31,7 +34,6 @@ import Xanthous.Data ( Position , Positioned(..) , positioned - , position , Neighbors(..) , neighborPositions ) @@ -81,15 +83,15 @@ instance At (EntityMap a) where pure $ m & removeEIDAtPos pos & byID . at eid .~ Nothing - setter m (Just (Positioned pos e)) = - case lookupWithPosition eid m of - Nothing -> insertAt pos e m - Just (Positioned origPos _) -> m - & removeEIDAtPos origPos - & byID . ix eid . position .~ pos - & byPosition . at pos %~ \case - Nothing -> Just $ ncons eid mempty - Just es -> Just $ eid <| es + setter m (Just pe@(Positioned pos _)) = m + & (case lookupWithPosition eid m of + Nothing -> id + Just (Positioned origPos _) -> removeEIDAtPos origPos + ) + & byID . at eid ?~ pe + & byPosition . at pos %~ \case + Nothing -> Just $ ncons eid mempty + Just es -> Just $ eid <| es removeEIDAtPos pos = byPosition . at pos %~ (>>= fromNullable . nfilter (/= eid)) @@ -117,9 +119,6 @@ instance Semigroup (Deduplicate a) where _lastID = fromMaybe 1 $ maximumOf (ifolded . asIndex) _byID in Deduplicate EntityMap{..} -instance Monoid (Deduplicate a) where - mempty = Deduplicate emptyEntityMap - -------------------------------------------------------------------------------- diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs index 3b2b320004e2..695d7bb0d0d1 100644 --- a/src/Xanthous/Entities/Character.hs +++ b/src/Xanthous/Entities/Character.hs @@ -1,6 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} module Xanthous.Entities.Character ( Character(..) + , characterName + , inventory , mkCharacter , pickUpItem ) where @@ -10,6 +12,8 @@ import Test.QuickCheck import Test.QuickCheck.Instances.Vector () import Test.QuickCheck.Arbitrary.Generic import Brick +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) -------------------------------------------------------------------------------- import Xanthous.Entities import Xanthous.Entities.Item @@ -17,9 +21,13 @@ import Xanthous.Entities.Item data Character = Character { _inventory :: !(Vector Item) + , _characterName :: !(Maybe Text) } deriving stock (Show, Eq, Generic) deriving anyclass (CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Character makeLenses ''Character scrollOffset :: Int @@ -40,6 +48,7 @@ instance Arbitrary Character where mkCharacter :: Character mkCharacter = Character { _inventory = mempty + , _characterName = Nothing } pickUpItem :: Item -> Character -> Character diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs index 777e05ee4149..59e436edc942 100644 --- a/src/Xanthous/Game.hs +++ b/src/Xanthous/Game.hs @@ -8,6 +8,8 @@ module Xanthous.Game , revealedPositions , messageHistory , randomGen + , promptState + , GamePromptState(..) , getInitialState @@ -24,6 +26,9 @@ module Xanthous.Game -- * collisions , Collision(..) , collisionAt + + -- * App monad + , AppT(..) ) where -------------------------------------------------------------------------------- import Xanthous.Prelude @@ -34,6 +39,8 @@ import System.Random import Test.QuickCheck import Test.QuickCheck.Arbitrary.Generic import Control.Monad.State.Class +import Control.Monad.State +import Control.Monad.Random.Class -------------------------------------------------------------------------------- import Xanthous.Data.EntityMap (EntityMap, EntityID) import qualified Xanthous.Data.EntityMap as EntityMap @@ -45,6 +52,7 @@ import Xanthous.Entities.Creature import Xanthous.Entities.Item import Xanthous.Entities.Arbitrary () import Xanthous.Orphans () +import Xanthous.Game.Prompt -------------------------------------------------------------------------------- data MessageHistory @@ -70,12 +78,33 @@ hideMessage :: MessageHistory -> MessageHistory hideMessage NoMessageHistory = NoMessageHistory hideMessage (MessageHistory msgs _) = MessageHistory msgs False +-------------------------------------------------------------------------------- + +data GamePromptState m where + NoPrompt :: GamePromptState m + WaitingPrompt :: Text -> Prompt m -> GamePromptState m + deriving stock (Show) + +-------------------------------------------------------------------------------- + +newtype AppT m a + = AppT { unAppT :: StateT GameState m a } + deriving ( Functor + , Applicative + , Monad + , MonadState GameState + ) + via (StateT GameState m) + +-------------------------------------------------------------------------------- + data GameState = GameState { _entities :: !(EntityMap SomeEntity) , _revealedPositions :: !(Set Position) , _characterEntityID :: !EntityID , _messageHistory :: !MessageHistory , _randomGen :: !StdGen + , _promptState :: !(GamePromptState (AppT Identity)) } deriving stock (Show) makeLenses ''GameState @@ -88,6 +117,7 @@ instance Eq GameState where , gs ^. messageHistory ) + instance Arbitrary GameState where arbitrary = do char <- arbitrary @Character @@ -97,8 +127,10 @@ instance Arbitrary GameState where EntityMap.insertAtReturningID charPos (SomeEntity char) _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities _randomGen <- mkStdGen <$> arbitrary + let _promptState = NoPrompt -- TODO pure $ GameState {..} + getInitialState :: IO GameState getInitialState = do _randomGen <- getStdGen @@ -110,6 +142,7 @@ getInitialState = do mempty _messageHistory = NoMessageHistory _revealedPositions = mempty + _promptState = NoPrompt pure GameState {..} positionedCharacter :: Lens' GameState (Positioned Character) @@ -166,3 +199,14 @@ collisionAt pos = do | any (entityIs @Creature) ents -> pure Combat | all (entityIs @Item) ents -> Nothing | otherwise -> pure Stop + +-------------------------------------------------------------------------------- + +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 diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index 8deb20ff84cb..60ae7110a6bf 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -1,40 +1,47 @@ -{-# LANGUAGE ViewPatterns #-} - +-------------------------------------------------------------------------------- module Xanthous.Game.Draw ( drawGame ) where - -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 (EntityMap, atPosition) +-------------------------------------------------------------------------------- +import Xanthous.Prelude +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) import qualified Xanthous.Data.EntityMap as EntityMap -import Xanthous.Entities -import Xanthous.Game - ( GameState(..) - , entities - , revealedPositions - , characterPosition - , MessageHistory(..) - , messageHistory - ) -import Xanthous.Resource (Name(..)) -import Xanthous.Orphans () +import Xanthous.Entities +import Xanthous.Game + ( GameState(..) + , entities + , revealedPositions + , characterPosition + , MessageHistory(..) + , messageHistory + , GamePromptState(..) + , promptState + ) +import Xanthous.Game.Prompt +import Xanthous.Resource (Name) +import qualified Xanthous.Resource as Resource +import Xanthous.Orphans () +-------------------------------------------------------------------------------- drawMessages :: MessageHistory -> Widget Name drawMessages NoMessageHistory = emptyWidget -drawMessages (MessageHistory _ False) = emptyWidget +drawMessages (MessageHistory _ False) = str " " 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 +drawPromptState :: GamePromptState m -> Widget Name +drawPromptState NoPrompt = emptyWidget +drawPromptState (WaitingPrompt msg (Prompt _ pt ps _)) = + case (pt, ps) of + (SStringPrompt, StringPromptState edit) -> + txt msg <+> renderEditor (txt . fold) True edit + _ -> undefined drawEntities :: Set Position @@ -61,8 +68,8 @@ drawEntities visiblePositions allEnts drawMap :: GameState -> Widget Name drawMap game - = viewport MapViewport Both - . showCursor Character (game ^. characterPosition . loc) + = viewport Resource.MapViewport Both + . showCursor Resource.Character (game ^. characterPosition . loc) $ drawEntities (game ^. revealedPositions) (game ^. entities) @@ -72,4 +79,5 @@ drawGame game = pure . withBorderStyle unicode $ drawMessages (game ^. messageHistory) + <=> drawPromptState (game ^. promptState) <=> border (drawMap game) diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs new file mode 100644 index 000000000000..928340f06480 --- /dev/null +++ b/src/Xanthous/Game/Prompt.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GADTs #-} +-------------------------------------------------------------------------------- +module Xanthous.Game.Prompt + ( PromptType(..) + , SPromptType(..) + , SingPromptType(..) + , PromptCancellable(..) + , PromptResult(..) + , PromptState(..) + , Prompt(..) + , mkPrompt + , isCancellable + , submitPrompt + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude +-------------------------------------------------------------------------------- +import Brick.Widgets.Edit (Editor, editorText, getEditContents) +import Test.QuickCheck +import Test.QuickCheck.Arbitrary.Generic +-------------------------------------------------------------------------------- +import Xanthous.Data (Direction, Position) +import Xanthous.Resource (Name) +import qualified Xanthous.Resource as Resource +-------------------------------------------------------------------------------- + +data PromptType where + StringPrompt :: PromptType + Confirm :: PromptType + Menu :: Type -> PromptType + DirectionPrompt :: PromptType + PointOnMap :: PromptType + deriving stock (Generic) + +instance Show PromptType where + show StringPrompt = "StringPrompt" + show Confirm = "Confirm" + show (Menu _) = "Menu" + show DirectionPrompt = "DirectionPrompt" + show PointOnMap = "PointOnMap" + +data SPromptType :: PromptType -> Type where + SStringPrompt :: SPromptType 'StringPrompt + SConfirm :: SPromptType 'Confirm + SMenu :: forall a. SPromptType ('Menu a) + SDirectionPrompt :: SPromptType 'DirectionPrompt + SPointOnMap :: SPromptType 'PointOnMap + +class SingPromptType pt where singPromptType :: SPromptType pt +instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt + +instance Show (SPromptType pt) where + show SStringPrompt = "SStringPrompt" + show SConfirm = "SConfirm" + show SMenu = "SMenu" + show SDirectionPrompt = "SDirectionPrompt" + show SPointOnMap = "SPointOnMap" + +data PromptCancellable + = Cancellable + | Uncancellable + deriving stock (Show, Eq, Ord, Enum, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + +instance Arbitrary PromptCancellable where + arbitrary = genericArbitrary + +data PromptResult (pt :: PromptType) where + StringResult :: Text -> PromptResult 'StringPrompt + ConfirmResult :: Bool -> PromptResult 'Confirm + MenuResult :: forall a. a -> PromptResult ('Menu a) + DirectionResult :: Direction -> PromptResult 'DirectionPrompt + PointOnMapResult :: Position -> PromptResult 'PointOnMap + +data PromptState pt where + StringPromptState :: Editor Text Name -> PromptState 'StringPrompt + +deriving stock instance Show (PromptState pt) + +data Prompt (m :: Type -> Type) where + Prompt + :: forall (pt :: PromptType) + (m :: Type -> Type). + PromptCancellable + -> SPromptType pt + -> PromptState pt + -> (PromptResult pt -> m ()) + -> Prompt m + +instance Show (Prompt m) where + show (Prompt c pt ps _) + = "(Prompt " + <> show c <> " " + <> show pt <> " " + <> show ps + <> " )" + +mkPrompt :: PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m +mkPrompt c pt@SStringPrompt cb = + let ps = StringPromptState $ editorText Resource.Prompt (Just 1) "" + in Prompt c pt ps cb +mkPrompt _ _ _ = undefined + +isCancellable :: Prompt m -> Bool +isCancellable (Prompt Cancellable _ _ _) = True +isCancellable (Prompt Uncancellable _ _ _) = False + +submitPrompt :: Prompt m -> m () +submitPrompt (Prompt _ pt ps cb) = + case (pt, ps) of + (SStringPrompt, StringPromptState edit) -> + cb . StringResult . mconcat . getEditContents $ edit + _ -> undefined + +-- data PromptInput :: PromptType -> Type where +-- StringInput :: PromptInput 'StringPrompt diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs index acf7775ede41..4e3e58607ce8 100644 --- a/src/Xanthous/Monad.hs +++ b/src/Xanthous/Monad.hs @@ -17,24 +17,6 @@ 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 @@ -44,19 +26,12 @@ 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 +say :: (MonadRandom m, ToJSON params, MonadState GameState m) + => [Text] -> params -> m () +say msgPath params = do + msg <- message msgPath params + messageHistory %= pushMessage msg -say_ :: Monad m => [Text] -> AppT m () -say_ = say +say_ :: (MonadRandom m, MonadState GameState m) => [Text] -> m () +say_ msgPath = say msgPath $ object [] diff --git a/src/Xanthous/Resource.hs b/src/Xanthous/Resource.hs index aa9020903cfc..782fd5040d93 100644 --- a/src/Xanthous/Resource.hs +++ b/src/Xanthous/Resource.hs @@ -10,4 +10,5 @@ data Name = MapViewport -- ^ The character | MessageBox -- ^ The box where we display messages to the user + | Prompt deriving stock (Show, Eq, Ord) diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml index 5bb11ab05945..0f0a0149f6d0 100644 --- a/src/Xanthous/messages.yaml +++ b/src/Xanthous/messages.yaml @@ -1,4 +1,6 @@ -welcome: Welcome to Xanthous! It's dangerous out there, why not stay inside? +welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside? items: pickUp: You pick up the {{item.itemType.name}} nothingToPickUp: There's nothing here to pick up +character: + namePrompt: "What's your name? " -- cgit 1.4.1