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:
parent
f37d0f75c0
commit
0abcd8c958
7 changed files with 111 additions and 29 deletions
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -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:
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
||||
|
|
|
@ -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? "
|
||||
|
||||
|
|
Loading…
Reference in a new issue