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 ViewPatterns #-}
|
||||||
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
module Xanthous.App (makeApp) where
|
module Xanthous.App (makeApp) where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -14,8 +15,8 @@ import Control.Monad.State.Class (modify)
|
||||||
import Data.Aeson (object, ToJSON)
|
import Data.Aeson (object, ToJSON)
|
||||||
import qualified Data.Aeson as A
|
import qualified Data.Aeson as A
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
import qualified Data.Yaml as Yaml
|
|
||||||
import System.Exit
|
import System.Exit
|
||||||
|
import GHC.TypeLits (TypeError, ErrorMessage(..))
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Command
|
import Xanthous.Command
|
||||||
import Xanthous.Data
|
import Xanthous.Data
|
||||||
|
@ -167,6 +168,15 @@ handleCommand Open = do
|
||||||
stepGame -- TODO
|
stepGame -- TODO
|
||||||
continue
|
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 Wait = stepGame >> continue
|
||||||
|
|
||||||
handleCommand Eat = do
|
handleCommand Eat = do
|
||||||
|
@ -217,11 +227,10 @@ handlePromptEvent
|
||||||
-> BrickEvent Name ()
|
-> BrickEvent Name ()
|
||||||
-> AppM (Next GameState)
|
-> AppM (Next GameState)
|
||||||
|
|
||||||
handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc [])) = do
|
handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc []))
|
||||||
promptState .= NoPrompt
|
= clearPrompt
|
||||||
continue
|
handlePromptEvent _ pr (VtyEvent (EvKey KEnter []))
|
||||||
handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) =
|
= submitPrompt pr >> clearPrompt
|
||||||
submitPrompt pr >> clearPrompt
|
|
||||||
|
|
||||||
handlePromptEvent
|
handlePromptEvent
|
||||||
msg
|
msg
|
||||||
|
@ -246,14 +255,32 @@ handlePromptEvent _ (Prompt _ SMenu _ items cb) (VtyEvent (EvKey (KChar chr) [])
|
||||||
| otherwise
|
| otherwise
|
||||||
= continue
|
= 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 :: AppM (Next GameState)
|
||||||
clearPrompt = promptState .= NoPrompt >> continue
|
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
|
prompt
|
||||||
:: forall (pt :: PromptType) (params :: Type).
|
:: forall (pt :: PromptType) (params :: Type).
|
||||||
(ToJSON params, SingPromptType pt, PromptInput pt ~ ())
|
(ToJSON params, SingPromptType pt, NotMenu pt)
|
||||||
=> [Text] -- ^ Message key
|
=> [Text] -- ^ Message key
|
||||||
-> params -- ^ Message params
|
-> params -- ^ Message params
|
||||||
-> PromptCancellable
|
-> PromptCancellable
|
||||||
|
@ -262,12 +289,20 @@ prompt
|
||||||
prompt msgPath params cancellable cb = do
|
prompt msgPath params cancellable cb = do
|
||||||
let pt = singPromptType @pt
|
let pt = singPromptType @pt
|
||||||
msg <- Messages.message msgPath params
|
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
|
promptState .= WaitingPrompt msg p
|
||||||
|
|
||||||
prompt_
|
prompt_
|
||||||
:: forall (pt :: PromptType) .
|
:: forall (pt :: PromptType).
|
||||||
(SingPromptType pt, PromptInput pt ~ ())
|
(SingPromptType pt, NotMenu pt)
|
||||||
=> [Text] -- ^ Message key
|
=> [Text] -- ^ Message key
|
||||||
-> PromptCancellable
|
-> PromptCancellable
|
||||||
-> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
|
-> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
|
||||||
|
@ -295,6 +330,7 @@ menu_ :: forall (a :: Type).
|
||||||
-> AppM ()
|
-> AppM ()
|
||||||
menu_ msgPath = menu msgPath $ object []
|
menu_ msgPath = menu msgPath $ object []
|
||||||
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
entitiesAtPositionWithType
|
entitiesAtPositionWithType
|
||||||
|
@ -316,10 +352,22 @@ describeEntitiesAt pos =
|
||||||
. to (filter (not . entityIs @Character))
|
. to (filter (not . entityIs @Character))
|
||||||
) >>= \case
|
) >>= \case
|
||||||
Empty -> pure ()
|
Empty -> pure ()
|
||||||
ents ->
|
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
|
let descriptions = description <$> ents
|
||||||
in say ["entities", "description"] $ object
|
in say ["entities", "description"]
|
||||||
["entityDescriptions" A..= toSentence descriptions]
|
$ object ["entityDescriptions" A..= toSentence descriptions]
|
||||||
|
|
||||||
attackAt :: Position -> AppM ()
|
attackAt :: Position -> AppM ()
|
||||||
attackAt pos =
|
attackAt pos =
|
||||||
|
|
|
@ -17,6 +17,7 @@ data Command
|
||||||
| Open
|
| Open
|
||||||
| Wait
|
| Wait
|
||||||
| Eat
|
| Eat
|
||||||
|
| Look
|
||||||
| Save
|
| Save
|
||||||
|
|
||||||
-- | TODO replace with `:` commands
|
-- | TODO replace with `:` commands
|
||||||
|
@ -29,9 +30,12 @@ commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir
|
||||||
commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
|
commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
|
||||||
commandFromKey (KChar ',') [] = Just PickUp
|
commandFromKey (KChar ',') [] = Just PickUp
|
||||||
commandFromKey (KChar 'o') [] = Just Open
|
commandFromKey (KChar 'o') [] = Just Open
|
||||||
|
commandFromKey (KChar ';') [] = Just Look
|
||||||
commandFromKey (KChar 'e') [] = Just Eat
|
commandFromKey (KChar 'e') [] = Just Eat
|
||||||
commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
|
|
||||||
commandFromKey (KChar 'S') [] = Just Save
|
commandFromKey (KChar 'S') [] = Just Save
|
||||||
|
|
||||||
|
commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
|
||||||
|
|
||||||
commandFromKey _ _ = Nothing
|
commandFromKey _ _ = Nothing
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -1,6 +1,7 @@
|
||||||
Creature:
|
Creature:
|
||||||
name: gormlak
|
name: gormlak
|
||||||
description: |
|
description: a gormlak
|
||||||
|
longDescription: |
|
||||||
A chittering imp-like creature with bright yellow horns. It adores shiny objects
|
A chittering imp-like creature with bright yellow horns. It adores shiny objects
|
||||||
and gathers in swarms.
|
and gathers in swarms.
|
||||||
char:
|
char:
|
||||||
|
|
|
@ -32,6 +32,14 @@ import qualified Xanthous.Resource as Resource
|
||||||
import Xanthous.Orphans ()
|
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 :: MessageHistory -> Widget Name
|
||||||
drawMessages = txt . (<> " ") . unwords . oextract
|
drawMessages = txt . (<> " ") . unwords . oextract
|
||||||
|
|
||||||
|
@ -46,7 +54,7 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
|
||||||
(SMenu, _, menuItems) ->
|
(SMenu, _, menuItems) ->
|
||||||
txt msg
|
txt msg
|
||||||
<=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems)
|
<=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems)
|
||||||
_ -> undefined
|
_ -> txt msg
|
||||||
where
|
where
|
||||||
drawMenuItem (chr, MenuOption m _) =
|
drawMenuItem (chr, MenuOption m _) =
|
||||||
str ("[" <> pure chr <> "] ") <+> txt m
|
str ("[" <> pure chr <> "] ") <+> txt m
|
||||||
|
@ -77,7 +85,7 @@ drawEntities canRenderPos allEnts
|
||||||
drawMap :: GameState -> Widget Name
|
drawMap :: GameState -> Widget Name
|
||||||
drawMap game
|
drawMap game
|
||||||
= viewport Resource.MapViewport Both
|
= viewport Resource.MapViewport Both
|
||||||
. showCursor Resource.Character (game ^. characterPosition . loc)
|
. cursorPosition game
|
||||||
$ drawEntities
|
$ drawEntities
|
||||||
(\pos ->
|
(\pos ->
|
||||||
(game ^. debugState . allRevealed)
|
(game ^. debugState . allRevealed)
|
||||||
|
@ -102,7 +110,9 @@ drawGame :: GameState -> [Widget Name]
|
||||||
drawGame game
|
drawGame game
|
||||||
= pure
|
= pure
|
||||||
. withBorderStyle unicode
|
. withBorderStyle unicode
|
||||||
$ drawMessages (game ^. messageHistory)
|
$ case game ^. promptState of
|
||||||
|
NoPrompt -> drawMessages (game ^. messageHistory)
|
||||||
|
_ -> emptyWidget
|
||||||
<=> drawPromptState (game ^. promptState)
|
<=> drawPromptState (game ^. promptState)
|
||||||
<=> border (drawMap game)
|
<=> border (drawMap game)
|
||||||
<=> drawCharacterInfo (game ^. character)
|
<=> drawCharacterInfo (game ^. character)
|
||||||
|
|
|
@ -15,6 +15,7 @@ module Xanthous.Game.Prompt
|
||||||
, Prompt(..)
|
, Prompt(..)
|
||||||
, mkPrompt
|
, mkPrompt
|
||||||
, mkMenu
|
, mkMenu
|
||||||
|
, mkPointOnMapPrompt
|
||||||
, isCancellable
|
, isCancellable
|
||||||
, submitPrompt
|
, submitPrompt
|
||||||
) where
|
) where
|
||||||
|
@ -67,6 +68,7 @@ instance NFData (SPromptType pt) where
|
||||||
class SingPromptType pt where singPromptType :: SPromptType pt
|
class SingPromptType pt where singPromptType :: SPromptType pt
|
||||||
instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
|
instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
|
||||||
instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
|
instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
|
||||||
|
instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap
|
||||||
instance SingPromptType 'Continue where singPromptType = SContinue
|
instance SingPromptType 'Continue where singPromptType = SContinue
|
||||||
|
|
||||||
instance Show (SPromptType pt) where
|
instance Show (SPromptType pt) where
|
||||||
|
@ -118,13 +120,17 @@ data PromptState pt where
|
||||||
StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
|
StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
|
||||||
DirectionPromptState :: PromptState 'DirectionPrompt
|
DirectionPromptState :: PromptState 'DirectionPrompt
|
||||||
ContinuePromptState :: PromptState 'Continue
|
ContinuePromptState :: PromptState 'Continue
|
||||||
|
ConfirmPromptState :: PromptState 'Confirm
|
||||||
MenuPromptState :: forall a. PromptState ('Menu a)
|
MenuPromptState :: forall a. PromptState ('Menu a)
|
||||||
|
PointOnMapPromptState :: Position -> PromptState 'PointOnMap
|
||||||
|
|
||||||
instance NFData (PromptState pt) where
|
instance NFData (PromptState pt) where
|
||||||
rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` ()
|
rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` ()
|
||||||
rnf DirectionPromptState = ()
|
rnf DirectionPromptState = ()
|
||||||
rnf ContinuePromptState = ()
|
rnf ContinuePromptState = ()
|
||||||
|
rnf ConfirmPromptState = ()
|
||||||
rnf MenuPromptState = ()
|
rnf MenuPromptState = ()
|
||||||
|
rnf pomps@(PointOnMapPromptState pos) = pomps `deepseq` pos `deepseq` ()
|
||||||
|
|
||||||
instance Arbitrary (PromptState 'StringPrompt) where
|
instance Arbitrary (PromptState 'StringPrompt) where
|
||||||
arbitrary = StringPromptState <$> arbitrary
|
arbitrary = StringPromptState <$> arbitrary
|
||||||
|
@ -170,6 +176,7 @@ instance Show (MenuOption a) where
|
||||||
|
|
||||||
type family PromptInput (pt :: PromptType) :: Type where
|
type family PromptInput (pt :: PromptType) :: Type where
|
||||||
PromptInput ('Menu a) = Map Char (MenuOption a)
|
PromptInput ('Menu a) = Map Char (MenuOption a)
|
||||||
|
PromptInput 'PointOnMap = Position -- Character pos
|
||||||
PromptInput _ = ()
|
PromptInput _ = ()
|
||||||
|
|
||||||
data Prompt (m :: Type -> Type) where
|
data Prompt (m :: Type -> Type) where
|
||||||
|
@ -236,7 +243,7 @@ mkPrompt c pt@SStringPrompt cb =
|
||||||
in Prompt c pt ps () cb
|
in Prompt c pt ps () cb
|
||||||
mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb
|
mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb
|
||||||
mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb
|
mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb
|
||||||
mkPrompt _ _ _ = undefined
|
mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb
|
||||||
|
|
||||||
mkMenu
|
mkMenu
|
||||||
:: forall a m.
|
:: forall a m.
|
||||||
|
@ -246,6 +253,13 @@ mkMenu
|
||||||
-> Prompt m
|
-> Prompt m
|
||||||
mkMenu c = Prompt c SMenu MenuPromptState
|
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 m -> Bool
|
||||||
isCancellable (Prompt Cancellable _ _ _ _) = True
|
isCancellable (Prompt Cancellable _ _ _ _) = True
|
||||||
isCancellable (Prompt Uncancellable _ _ _ _) = False
|
isCancellable (Prompt Uncancellable _ _ _ _) = False
|
||||||
|
@ -261,7 +275,7 @@ submitPrompt (Prompt _ pt ps _ cb) =
|
||||||
cb ContinueResult
|
cb ContinueResult
|
||||||
(SMenu, MenuPromptState) ->
|
(SMenu, MenuPromptState) ->
|
||||||
pure () -- Don't use submit with a menu prompt
|
pure () -- Don't use submit with a menu prompt
|
||||||
_ -> undefined
|
(SPointOnMap, PointOnMapPromptState pos) ->
|
||||||
|
cb $ PointOnMapResult pos
|
||||||
-- data PromptInput :: PromptType -> Type where
|
(SConfirm, ConfirmPromptState) ->
|
||||||
-- StringInput :: PromptInput 'StringPrompt
|
cb $ ConfirmResult True
|
||||||
|
|
|
@ -16,6 +16,7 @@ data Name = MapViewport
|
||||||
| MessageBox
|
| MessageBox
|
||||||
-- ^ The box where we display messages to the user
|
-- ^ The box where we display messages to the user
|
||||||
| Prompt
|
| Prompt
|
||||||
|
-- ^ The game's prompt
|
||||||
deriving stock (Show, Eq, Ord, Generic)
|
deriving stock (Show, Eq, Ord, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function)
|
deriving anyclass (NFData, CoArbitrary, Function)
|
||||||
|
|
||||||
|
|
|
@ -22,6 +22,10 @@ open:
|
||||||
locked: "That door is locked"
|
locked: "That door is locked"
|
||||||
nothingToOpen: "There's nothing to open there"
|
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:
|
character:
|
||||||
namePrompt: "What's your name? "
|
namePrompt: "What's your name? "
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue