about summary refs log tree commit diff
path: root/src/Xanthous/App.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xanthous/App.hs')
-rw-r--r--src/Xanthous/App.hs84
1 files changed, 66 insertions, 18 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 72c9a3f553ad..eb2f0cf7ad83 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -13,6 +13,7 @@ import           Control.Monad.Random (MonadRandom)
 import           Control.Monad.State.Class (modify)
 import           Data.Aeson (object, ToJSON)
 import qualified Data.Aeson as A
+import qualified Data.Vector as V
 import           System.Exit
 --------------------------------------------------------------------------------
 import           Xanthous.Command
@@ -29,16 +30,18 @@ import           Xanthous.Game.Draw (drawGame)
 import           Xanthous.Game.Prompt
 import           Xanthous.Monad
 import           Xanthous.Resource (Name)
-import           Xanthous.Messages (message)
+import qualified Xanthous.Messages as Messages
 import           Xanthous.Util.Inflection (toSentence)
 --------------------------------------------------------------------------------
 import qualified Xanthous.Entities.Character as Character
 import           Xanthous.Entities.Character
 import           Xanthous.Entities
 import           Xanthous.Entities.Item (Item)
+import qualified Xanthous.Entities.Item as Item
 import           Xanthous.Entities.Creature (Creature)
 import qualified Xanthous.Entities.Creature as Creature
 import           Xanthous.Entities.Environment (Door, open, locked)
+import           Xanthous.Entities.RawTypes (edible, eatMessage, hitpointsHealed)
 import           Xanthous.Generators
 import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
 --------------------------------------------------------------------------------
@@ -155,6 +158,26 @@ handleCommand Open = do
 
 handleCommand Wait = stepGame >> continue
 
+handleCommand Eat = do
+  uses (character . inventory)
+       (V.mapMaybe (\item -> (item,) <$> item ^. Item.itemType . edible))
+    >>= \case
+      Empty -> say_ ["eat", "noFood"]
+      food ->
+        let foodMenuItem idx (item, edibleItem)
+              = ( item ^. Item.itemType . char . char
+                , MenuOption (description item) (idx, item, edibleItem))
+            menuItems = mkMenuItems $ imap foodMenuItem food
+        in menu_ ["eat", "menuPrompt"] Cancellable menuItems
+          $ \(MenuResult (idx, item, edibleItem)) -> do
+            character . inventory %= \inv ->
+              let (before, after) = V.splitAt idx inv
+              in before <> fromMaybe Empty (tailMay after)
+            let msg = fromMaybe (Messages.lookup ["eat", "eat"])
+                      $ edibleItem ^. eatMessage
+            message msg $ object ["item" A..= item]
+  continue
+
 handleCommand ToggleRevealAll = do
   val <- debugState . allRevealed <%= not
   say ["debug", "toggleRevealAll"] $ object [ "revealAll" A..= val ]
@@ -168,39 +191,43 @@ handlePromptEvent
   -> BrickEvent Name ()
   -> AppM (Next GameState)
 
-handlePromptEvent _ (Prompt Cancellable _ _ _) (VtyEvent (EvKey KEsc [])) = do
-  promptState .= NoPrompt
-  continue
-handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) = do
-  submitPrompt pr
+handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc [])) = do
   promptState .= NoPrompt
   continue
+handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) =
+  submitPrompt pr >> clearPrompt
 
 handlePromptEvent
   msg
-  (Prompt c SStringPrompt (StringPromptState edit) cb)
+  (Prompt c SStringPrompt (StringPromptState edit) pi cb)
   (VtyEvent ev)
   = do
     edit' <- lift $ handleEditorEvent ev edit
-    let prompt' = Prompt c SStringPrompt (StringPromptState edit') cb
+    let prompt' = Prompt c SStringPrompt (StringPromptState edit') pi cb
     promptState .= WaitingPrompt msg prompt'
     continue
 
-handlePromptEvent _ (Prompt _ SDirectionPrompt _ cb)
+handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb)
   (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
-  = do
-    cb $ DirectionResult dir
-    promptState .= NoPrompt
-    continue
-handlePromptEvent _ (Prompt _ SDirectionPrompt _ _) _ = continue
+  = cb (DirectionResult dir) >> clearPrompt
+handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue
 
-handlePromptEvent _ (Prompt _ SContinue _ _) _ = continue
+handlePromptEvent _ (Prompt _ SContinue _ _ _) _ = continue
+
+handlePromptEvent _ (Prompt _ SMenu _ items cb) (VtyEvent (EvKey (KChar chr) []))
+  | Just (MenuOption _ res) <- items ^. at chr
+  = cb (MenuResult res) >> clearPrompt
+  | otherwise
+  = continue
 
 handlePromptEvent _ _ _ = undefined
 
+clearPrompt :: AppM (Next GameState)
+clearPrompt = promptState .= NoPrompt >> continue
+
 prompt
   :: forall (pt :: PromptType) (params :: Type).
-    (ToJSON params, SingPromptType pt)
+    (ToJSON params, SingPromptType pt, PromptInput pt ~ ())
   => [Text]                     -- ^ Message key
   -> params                     -- ^ Message params
   -> PromptCancellable
@@ -208,19 +235,40 @@ prompt
   -> AppM ()
 prompt msgPath params cancellable cb = do
   let pt = singPromptType @pt
-  msg <- message msgPath params
+  msg <- Messages.message msgPath params
   let p = mkPrompt cancellable pt cb
   promptState .= WaitingPrompt msg p
 
 prompt_
   :: forall (pt :: PromptType) .
-    (SingPromptType pt)
+    (SingPromptType pt, PromptInput pt ~ ())
   => [Text] -- ^ Message key
   -> PromptCancellable
   -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
   -> AppM ()
 prompt_ msg = prompt msg $ object []
 
+menu :: forall (a :: Type) (params :: Type).
+       (ToJSON params)
+     => [Text]                            -- ^ Message key
+     -> params                            -- ^ Message params
+     -> PromptCancellable
+     -> Map Char (MenuOption a)           -- ^ Menu items
+     -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
+     -> AppM ()
+menu msgPath params cancellable items cb = do
+  msg <- Messages.message msgPath params
+  let p = mkMenu cancellable items cb
+  promptState .= WaitingPrompt msg p
+
+menu_ :: forall (a :: Type).
+        [Text]                            -- ^ Message key
+      -> PromptCancellable
+      -> Map Char (MenuOption a)           -- ^ Menu items
+      -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
+      -> AppM ()
+menu_ msgPath = menu msgPath $ object []
+
 --------------------------------------------------------------------------------
 
 entitiesAtPositionWithType