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.
This commit is contained in:
Griffin Smith 2019-11-29 15:43:46 -05:00
parent f37d0f75c0
commit 0abcd8c958
7 changed files with 111 additions and 29 deletions

View file

@ -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 =

View file

@ -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
--------------------------------------------------------------------------------

View file

@ -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:

View file

@ -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)

View file

@ -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

View file

@ -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)

View file

@ -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? "