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.

2 files changed, 36 insertions, 12 deletions

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