From 0abcd8c9581f0017cb2bd59a09e93800ea8f3b1f Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Fri, 29 Nov 2019 15:43:46 -0500 Subject: Implement a "look" command Implement the PointOnMap prompt type, which allows the player to move the cursor around and select a position on the map, and use this prompt type to implement a "look" command, describing all entities at the selected position. --- src/Xanthous/App.hs | 78 ++++++++++++++++++++++++++------- src/Xanthous/Command.hs | 6 ++- src/Xanthous/Entities/Raws/gormlak.yaml | 3 +- src/Xanthous/Game/Draw.hs | 16 +++++-- src/Xanthous/Game/Prompt.hs | 32 ++++++++++---- src/Xanthous/Resource.hs | 1 + src/Xanthous/messages.yaml | 4 ++ 7 files changed, 111 insertions(+), 29 deletions(-) (limited to 'src/Xanthous') diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 71bf40c427e8..13c4af1246d5 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- module Xanthous.App (makeApp) where -------------------------------------------------------------------------------- @@ -14,8 +15,8 @@ import Control.Monad.State.Class (modify) import Data.Aeson (object, ToJSON) import qualified Data.Aeson as A import qualified Data.Vector as V -import qualified Data.Yaml as Yaml import System.Exit +import GHC.TypeLits (TypeError, ErrorMessage(..)) -------------------------------------------------------------------------------- import Xanthous.Command import Xanthous.Data @@ -167,6 +168,15 @@ handleCommand Open = do stepGame -- TODO continue +handleCommand Look = do + prompt_ @'PointOnMap ["look", "prompt"] Cancellable + $ \(PointOnMapResult pos) -> + use (entities . EntityMap.atPosition pos) + >>= \case + Empty -> say_ ["look", "nothing"] + ents -> describeEntities ents + continue + handleCommand Wait = stepGame >> continue handleCommand Eat = do @@ -217,11 +227,10 @@ handlePromptEvent -> BrickEvent Name () -> AppM (Next GameState) -handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc [])) = do - promptState .= NoPrompt - continue -handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) = - submitPrompt pr >> clearPrompt +handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc [])) + = clearPrompt +handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) + = submitPrompt pr >> clearPrompt handlePromptEvent msg @@ -246,14 +255,32 @@ handlePromptEvent _ (Prompt _ SMenu _ items cb) (VtyEvent (EvKey (KChar chr) []) | otherwise = continue -handlePromptEvent _ _ _ = undefined +handlePromptEvent + msg + (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb) + (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) [])) + = let pos' = move dir pos + prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb + in promptState .= WaitingPrompt msg prompt' + >> continue +handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue clearPrompt :: AppM (Next GameState) clearPrompt = promptState .= NoPrompt >> continue +class NotMenu (pt :: PromptType) +instance NotMenu 'StringPrompt +instance NotMenu 'Confirm +instance NotMenu 'DirectionPrompt +instance NotMenu 'PointOnMap +instance NotMenu 'Continue +instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts" + ':$$: 'Text "Use `menu` or `menu_` instead") + => NotMenu ('Menu a) + prompt :: forall (pt :: PromptType) (params :: Type). - (ToJSON params, SingPromptType pt, PromptInput pt ~ ()) + (ToJSON params, SingPromptType pt, NotMenu pt) => [Text] -- ^ Message key -> params -- ^ Message params -> PromptCancellable @@ -262,12 +289,20 @@ prompt prompt msgPath params cancellable cb = do let pt = singPromptType @pt msg <- Messages.message msgPath params - let p = mkPrompt cancellable pt cb + p <- case pt of + SPointOnMap -> do + charPos <- use characterPosition + pure $ mkPointOnMapPrompt cancellable charPos cb + SStringPrompt -> pure $ mkPrompt cancellable pt cb + SConfirm -> pure $ mkPrompt cancellable pt cb + SDirectionPrompt -> pure $ mkPrompt cancellable pt cb + SContinue -> pure $ mkPrompt cancellable pt cb + SMenu -> error "unreachable" promptState .= WaitingPrompt msg p prompt_ - :: forall (pt :: PromptType) . - (SingPromptType pt, PromptInput pt ~ ()) + :: forall (pt :: PromptType). + (SingPromptType pt, NotMenu pt) => [Text] -- ^ Message key -> PromptCancellable -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler @@ -295,6 +330,7 @@ menu_ :: forall (a :: Type). -> AppM () menu_ msgPath = menu msgPath $ object [] + -------------------------------------------------------------------------------- entitiesAtPositionWithType @@ -316,10 +352,22 @@ describeEntitiesAt pos = . to (filter (not . entityIs @Character)) ) >>= \case Empty -> pure () - ents -> - let descriptions = description <$> ents - in say ["entities", "description"] $ object - ["entityDescriptions" A..= toSentence descriptions] + ents -> describeEntities ents + +describeEntities + :: ( Entity entity + , MonadRandom m + , MonadState GameState m + , MonoFoldable (f Text) + , Functor f + , Element (f Text) ~ Text + ) + => f entity + -> m () +describeEntities ents = + let descriptions = description <$> ents + in say ["entities", "description"] + $ object ["entityDescriptions" A..= toSentence descriptions] attackAt :: Position -> AppM () attackAt pos = diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs index 74808443d34c..35a8ce367269 100644 --- a/src/Xanthous/Command.hs +++ b/src/Xanthous/Command.hs @@ -17,6 +17,7 @@ data Command | Open | Wait | Eat + | Look | Save -- | TODO replace with `:` commands @@ -29,9 +30,12 @@ commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage commandFromKey (KChar ',') [] = Just PickUp commandFromKey (KChar 'o') [] = Just Open +commandFromKey (KChar ';') [] = Just Look commandFromKey (KChar 'e') [] = Just Eat -commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll commandFromKey (KChar 'S') [] = Just Save + +commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll + commandFromKey _ _ = Nothing -------------------------------------------------------------------------------- diff --git a/src/Xanthous/Entities/Raws/gormlak.yaml b/src/Xanthous/Entities/Raws/gormlak.yaml index 9a9281c9a91a..2eac895190b3 100644 --- a/src/Xanthous/Entities/Raws/gormlak.yaml +++ b/src/Xanthous/Entities/Raws/gormlak.yaml @@ -1,6 +1,7 @@ Creature: name: gormlak - description: | + description: a gormlak + longDescription: | A chittering imp-like creature with bright yellow horns. It adores shiny objects and gathers in swarms. char: diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index ffbf30cca864..2f7ccf29f795 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -32,6 +32,14 @@ import qualified Xanthous.Resource as Resource import Xanthous.Orphans () -------------------------------------------------------------------------------- +cursorPosition :: GameState -> Widget Name -> Widget Name +cursorPosition game + | WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState pos) _ _) + <- game ^. promptState + = showCursor Resource.Prompt (pos ^. loc) + | otherwise + = showCursor Resource.Character (game ^. characterPosition . loc) + drawMessages :: MessageHistory -> Widget Name drawMessages = txt . (<> " ") . unwords . oextract @@ -46,7 +54,7 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) = (SMenu, _, menuItems) -> txt msg <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems) - _ -> undefined + _ -> txt msg where drawMenuItem (chr, MenuOption m _) = str ("[" <> pure chr <> "] ") <+> txt m @@ -77,7 +85,7 @@ drawEntities canRenderPos allEnts drawMap :: GameState -> Widget Name drawMap game = viewport Resource.MapViewport Both - . showCursor Resource.Character (game ^. characterPosition . loc) + . cursorPosition game $ drawEntities (\pos -> (game ^. debugState . allRevealed) @@ -102,7 +110,9 @@ drawGame :: GameState -> [Widget Name] drawGame game = pure . withBorderStyle unicode - $ drawMessages (game ^. messageHistory) + $ case game ^. promptState of + NoPrompt -> drawMessages (game ^. messageHistory) + _ -> emptyWidget <=> drawPromptState (game ^. promptState) <=> border (drawMap game) <=> drawCharacterInfo (game ^. character) diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs index 1154d6db5a4c..6c3629f31055 100644 --- a/src/Xanthous/Game/Prompt.hs +++ b/src/Xanthous/Game/Prompt.hs @@ -15,6 +15,7 @@ module Xanthous.Game.Prompt , Prompt(..) , mkPrompt , mkMenu + , mkPointOnMapPrompt , isCancellable , submitPrompt ) where @@ -67,6 +68,7 @@ instance NFData (SPromptType pt) where class SingPromptType pt where singPromptType :: SPromptType pt instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt +instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap instance SingPromptType 'Continue where singPromptType = SContinue instance Show (SPromptType pt) where @@ -115,16 +117,20 @@ instance Arbitrary (PromptResult 'Continue) where -------------------------------------------------------------------------------- data PromptState pt where - StringPromptState :: Editor Text Name -> PromptState 'StringPrompt - DirectionPromptState :: PromptState 'DirectionPrompt - ContinuePromptState :: PromptState 'Continue - MenuPromptState :: forall a. PromptState ('Menu a) + StringPromptState :: Editor Text Name -> PromptState 'StringPrompt + DirectionPromptState :: PromptState 'DirectionPrompt + ContinuePromptState :: PromptState 'Continue + ConfirmPromptState :: PromptState 'Confirm + MenuPromptState :: forall a. PromptState ('Menu a) + PointOnMapPromptState :: Position -> PromptState 'PointOnMap instance NFData (PromptState pt) where rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` () rnf DirectionPromptState = () rnf ContinuePromptState = () + rnf ConfirmPromptState = () rnf MenuPromptState = () + rnf pomps@(PointOnMapPromptState pos) = pomps `deepseq` pos `deepseq` () instance Arbitrary (PromptState 'StringPrompt) where arbitrary = StringPromptState <$> arbitrary @@ -170,6 +176,7 @@ instance Show (MenuOption a) where type family PromptInput (pt :: PromptType) :: Type where PromptInput ('Menu a) = Map Char (MenuOption a) + PromptInput 'PointOnMap = Position -- Character pos PromptInput _ = () data Prompt (m :: Type -> Type) where @@ -236,7 +243,7 @@ mkPrompt c pt@SStringPrompt cb = in Prompt c pt ps () cb mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb -mkPrompt _ _ _ = undefined +mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb mkMenu :: forall a m. @@ -246,6 +253,13 @@ mkMenu -> Prompt m mkMenu c = Prompt c SMenu MenuPromptState +mkPointOnMapPrompt + :: PromptCancellable + -> Position + -> (PromptResult 'PointOnMap -> m ()) + -> Prompt m +mkPointOnMapPrompt c pos = Prompt c SPointOnMap (PointOnMapPromptState pos) pos + isCancellable :: Prompt m -> Bool isCancellable (Prompt Cancellable _ _ _ _) = True isCancellable (Prompt Uncancellable _ _ _ _) = False @@ -261,7 +275,7 @@ submitPrompt (Prompt _ pt ps _ cb) = cb ContinueResult (SMenu, MenuPromptState) -> pure () -- Don't use submit with a menu prompt - _ -> undefined - --- data PromptInput :: PromptType -> Type where --- StringInput :: PromptInput 'StringPrompt + (SPointOnMap, PointOnMapPromptState pos) -> + cb $ PointOnMapResult pos + (SConfirm, ConfirmPromptState) -> + cb $ ConfirmResult True diff --git a/src/Xanthous/Resource.hs b/src/Xanthous/Resource.hs index 13f7e539679b..5350e7646e38 100644 --- a/src/Xanthous/Resource.hs +++ b/src/Xanthous/Resource.hs @@ -16,6 +16,7 @@ data Name = MapViewport | MessageBox -- ^ The box where we display messages to the user | Prompt + -- ^ The game's prompt deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml index 69664f8a7940..71f08f263185 100644 --- a/src/Xanthous/messages.yaml +++ b/src/Xanthous/messages.yaml @@ -22,6 +22,10 @@ open: locked: "That door is locked" nothingToOpen: "There's nothing to open there" +look: + prompt: Select a position on the map to describe (use Enter to confirm) + nothing: There's nothing there + character: namePrompt: "What's your name? " -- cgit 1.4.1