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…
	
	Add table
		Add a link
		
	
		Reference in a new issue