Allow eating edible items

Add menu support to the prompt system, and an "Eat" command that prompts
for an item to eat and eats the item the character specifies, restoring
an amount of hitpoints configurable via the item raw type.

2 files changed, 70 insertions, 25 deletions

diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index addeaa14cd45..9f247d383325 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -37,13 +37,19 @@ drawMessages = txt . (<> " ") . unwords . oextract
 
 drawPromptState :: GamePromptState m -> Widget Name
 drawPromptState NoPrompt = emptyWidget
-drawPromptState (WaitingPrompt msg (Prompt _ pt ps _)) =
-  case (pt, ps) of
-    (SStringPrompt, StringPromptState edit) ->
+drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
+  case (pt, ps, pri) of
+    (SStringPrompt, StringPromptState edit, _) ->
       txt msg <+> renderEditor (txt . fold) True edit
-    (SDirectionPrompt, DirectionPromptState) -> txt msg
-    (SContinue, _) -> txt msg
+    (SDirectionPrompt, DirectionPromptState, _) -> txt msg
+    (SContinue, _, _) -> txt msg
+    (SMenu, _, menuItems) ->
+      txt msg
+      <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems)
     _ -> undefined
+  where
+    drawMenuItem (chr, MenuOption m _) =
+      str ("[" <> pure chr <> "] ") <+> txt m
 
 drawEntities
   :: (Position -> Bool)
diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs
index cb34793c6d60..26a7b96eb1f2 100644
--- a/src/Xanthous/Game/Prompt.hs
+++ b/src/Xanthous/Game/Prompt.hs
@@ -8,20 +8,25 @@ module Xanthous.Game.Prompt
   , PromptCancellable(..)
   , PromptResult(..)
   , PromptState(..)
+  , MenuOption(..)
+  , mkMenuItems
+  , PromptInput
   , Prompt(..)
   , mkPrompt
+  , mkMenu
   , isCancellable
   , submitPrompt
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude
 --------------------------------------------------------------------------------
-import Brick.Widgets.Edit (Editor, editorText, getEditContents)
-import Test.QuickCheck
-import Test.QuickCheck.Arbitrary.Generic
+import           Brick.Widgets.Edit (Editor, editorText, getEditContents)
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
 --------------------------------------------------------------------------------
-import Xanthous.Data (Direction, Position)
-import Xanthous.Resource (Name)
+import           Xanthous.Util (smallestNotIn)
+import           Xanthous.Data (Direction, Position)
+import           Xanthous.Resource (Name)
 import qualified Xanthous.Resource as Resource
 --------------------------------------------------------------------------------
 
@@ -81,12 +86,31 @@ data PromptResult (pt :: PromptType) where
   ContinueResult   ::             PromptResult 'Continue
 
 data PromptState pt where
-  StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
-  DirectionPromptState :: PromptState 'DirectionPrompt
-  ContinuePromptState :: PromptState 'Continue
+  StringPromptState    :: Editor Text Name -> PromptState 'StringPrompt
+  DirectionPromptState ::                    PromptState 'DirectionPrompt
+  ContinuePromptState  ::                    PromptState 'Continue
+  MenuPromptState      :: forall a.               PromptState ('Menu a)
 
 deriving stock instance Show (PromptState pt)
 
+data MenuOption a = MenuOption Text a
+
+mkMenuItems :: (MonoFoldable f, Element f ~ (Char, MenuOption a))
+            => f
+            -> Map Char (MenuOption a)
+mkMenuItems = flip foldl' mempty $ \items (chr, option) ->
+  let chr' = if has (ix chr) items
+             then smallestNotIn $ keys items
+             else chr
+  in items & at chr' ?~ option
+
+instance Show (MenuOption a) where
+  show (MenuOption m _) = show m
+
+type family PromptInput (pt :: PromptType) :: Type where
+  PromptInput ('Menu a) = Map Char (MenuOption a)
+  PromptInput _ = ()
+
 data Prompt (m :: Type -> Type) where
   Prompt
     :: forall (pt :: PromptType)
@@ -94,38 +118,53 @@ data Prompt (m :: Type -> Type) where
       PromptCancellable
     -> SPromptType pt
     -> PromptState pt
+    -> PromptInput pt
     -> (PromptResult pt -> m ())
     -> Prompt m
 
 instance Show (Prompt m) where
-  show (Prompt c pt ps _)
+  show (Prompt c pt ps pri _)
     = "(Prompt "
     <> show c <> " "
     <> show pt <> " "
-    <> show ps
-    <> " <function> )"
-
-mkPrompt :: PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m
+    <> show ps <> " "
+    <> showPri
+    <> " <function>)"
+    where showPri = case pt of
+            SMenu -> show pri
+            _ -> "()"
+
+mkPrompt :: (PromptInput pt ~ ()) => PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m
 mkPrompt c pt@SStringPrompt cb =
   let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
-  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
+  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
 
+mkMenu
+  :: forall a m.
+    PromptCancellable
+  -> Map Char (MenuOption a) -- ^ Menu items
+  -> (PromptResult ('Menu a) -> m ())
+  -> Prompt m
+mkMenu c = Prompt c SMenu MenuPromptState
+
 isCancellable :: Prompt m -> Bool
-isCancellable (Prompt Cancellable _ _ _)   = True
-isCancellable (Prompt Uncancellable _ _ _) = False
+isCancellable (Prompt Cancellable _ _ _ _)   = True
+isCancellable (Prompt Uncancellable _ _ _ _) = False
 
 submitPrompt :: Applicative m => Prompt m -> m ()
-submitPrompt (Prompt _ pt ps cb) =
+submitPrompt (Prompt _ pt ps _ cb) =
   case (pt, ps) of
     (SStringPrompt, StringPromptState edit) ->
       cb . StringResult . mconcat . getEditContents $ edit
     (SDirectionPrompt, DirectionPromptState) ->
       pure () -- Don't use submit with a direction prompt
     (SContinue, ContinuePromptState) ->
-      cb ContinueResult -- Don't use submit with a direction prompt
+      cb ContinueResult
+    (SMenu, MenuPromptState) ->
+      pure () -- Don't use submit with a menu prompt
     _ -> undefined
 
 -- data PromptInput :: PromptType -> Type where