about summary refs log tree commit diff
path: root/src/Xanthous
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xanthous')
-rw-r--r--src/Xanthous/App.hs84
-rw-r--r--src/Xanthous/Command.hs2
-rw-r--r--src/Xanthous/Entities.hs12
-rw-r--r--src/Xanthous/Entities/Item.hs6
-rw-r--r--src/Xanthous/Entities/RawTypes.hs33
-rw-r--r--src/Xanthous/Entities/Raws/noodles.yaml4
-rw-r--r--src/Xanthous/Game/Draw.hs16
-rw-r--r--src/Xanthous/Game/Prompt.hs79
-rw-r--r--src/Xanthous/Messages.hs27
-rw-r--r--src/Xanthous/Monad.hs37
-rw-r--r--src/Xanthous/Util.hs10
-rw-r--r--src/Xanthous/messages.yaml21
12 files changed, 258 insertions, 73 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
diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs
index 4bf0e2893908..f2f21160df75 100644
--- a/src/Xanthous/Command.hs
+++ b/src/Xanthous/Command.hs
@@ -16,6 +16,7 @@ data Command
   | PickUp
   | Open
   | Wait
+  | Eat
 
     -- | TODO replace with `:` commands
   | ToggleRevealAll
@@ -27,6 +28,7 @@ commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir
 commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
 commandFromKey (KChar ',') [] = Just PickUp
 commandFromKey (KChar 'o') [] = Just Open
+commandFromKey (KChar 'e') [] = Just Eat
 commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
 commandFromKey _ _ = Nothing
 
diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs
index 15080b3221e0..af226b395d9e 100644
--- a/src/Xanthous/Entities.hs
+++ b/src/Xanthous/Entities.hs
@@ -1,8 +1,9 @@
-{-# LANGUAGE RoleAnnotations       #-}
-{-# LANGUAGE RecordWildCards       #-}
-{-# LANGUAGE UndecidableInstances  #-}
-{-# LANGUAGE GADTs                 #-}
-{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE RoleAnnotations      #-}
+{-# LANGUAGE RecordWildCards      #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE GADTs                #-}
+{-# LANGUAGE AllowAmbiguousTypes  #-}
+{-# LANGUAGE TemplateHaskell      #-}
 --------------------------------------------------------------------------------
 module Xanthous.Entities
   ( Draw(..)
@@ -103,6 +104,7 @@ data EntityChar = EntityChar
   }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
+makeFieldsNoPrefix ''EntityChar
 
 instance Arbitrary EntityChar where
   arbitrary = genericArbitrary
diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs
index 832f0d4d62b3..ea6f16e05dc3 100644
--- a/src/Xanthous/Entities/Item.hs
+++ b/src/Xanthous/Entities/Item.hs
@@ -5,6 +5,7 @@ module Xanthous.Entities.Item
   ( Item(..)
   , itemType
   , newWithType
+  , isEdible
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude
@@ -12,7 +13,7 @@ import           Test.QuickCheck
 import           Data.Aeson (ToJSON, FromJSON)
 import           Data.Aeson.Generic.DerivingVia
 --------------------------------------------------------------------------------
-import           Xanthous.Entities.RawTypes hiding (Item, description)
+import           Xanthous.Entities.RawTypes hiding (Item, description, isEdible)
 import qualified Xanthous.Entities.RawTypes as Raw
 import           Xanthous.Entities
                  ( Draw(..)
@@ -47,3 +48,6 @@ instance Entity Item where
 
 newWithType :: ItemType -> Item
 newWithType = Item
+
+isEdible :: Item -> Bool
+isEdible = Raw.isEdible . view itemType
diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs
index 3fb89c58ba3b..f1f5e05f7aac 100644
--- a/src/Xanthous/Entities/RawTypes.hs
+++ b/src/Xanthous/Entities/RawTypes.hs
@@ -3,14 +3,20 @@
 --------------------------------------------------------------------------------
 module Xanthous.Entities.RawTypes
   ( CreatureType(..)
+  , EdibleItem(..)
   , ItemType(..)
+  , isEdible
   , EntityRaw(..)
 
+    -- * Lens classes
   , HasName(..)
   , HasDescription(..)
   , HasLongDescription(..)
   , HasMaxHitpoints(..)
   , HasFriendly(..)
+  , HasEatMessage(..)
+  , HasHitpointsHealed(..)
+  , HasEdible(..)
   , _Creature
   ) where
 --------------------------------------------------------------------------------
@@ -21,6 +27,7 @@ import Data.Aeson.Generic.DerivingVia
 import Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import Xanthous.Entities (EntityChar, HasChar(..))
+import Xanthous.Messages (Message(..))
 --------------------------------------------------------------------------------
 data CreatureType = CreatureType
   { _name :: Text
@@ -41,11 +48,26 @@ instance Arbitrary CreatureType where
 
 --------------------------------------------------------------------------------
 
+data EdibleItem = EdibleItem
+  { _hitpointsHealed :: Int
+  , _eatMessage :: Maybe Message
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       EdibleItem
+makeFieldsNoPrefix ''EdibleItem
+
+instance Arbitrary EdibleItem where
+  arbitrary = genericArbitrary
+
 data ItemType = ItemType
-  { _name :: Text
-  , _description :: Text
+  { _name            :: Text
+  , _description     :: Text
   , _longDescription :: Text
-  , _char :: EntityChar
+  , _char            :: EntityChar
+  , _edible          :: Maybe EdibleItem
   }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
@@ -57,6 +79,11 @@ makeFieldsNoPrefix ''ItemType
 instance Arbitrary ItemType where
   arbitrary = genericArbitrary
 
+isEdible :: ItemType -> Bool
+isEdible = has $ edible . _Just
+
+--------------------------------------------------------------------------------
+
 data EntityRaw
   = Creature CreatureType
   | Item ItemType
diff --git a/src/Xanthous/Entities/Raws/noodles.yaml b/src/Xanthous/Entities/Raws/noodles.yaml
index 91a0a35388ad..c3f19dce91d1 100644
--- a/src/Xanthous/Entities/Raws/noodles.yaml
+++ b/src/Xanthous/Entities/Raws/noodles.yaml
@@ -6,3 +6,7 @@ Item:
     char: 'n'
     style:
       foreground: yellow
+  edible:
+    hitpointsHealed: 2
+    eatMessage:
+      - You slurp up the noodles. Yumm!
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
diff --git a/src/Xanthous/Messages.hs b/src/Xanthous/Messages.hs
index b1aeeb635cc9..b0dc0e4ae9d2 100644
--- a/src/Xanthous/Messages.hs
+++ b/src/Xanthous/Messages.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
 module Xanthous.Messages
   ( Message(..)
   , resolve
@@ -7,11 +8,13 @@ module Xanthous.Messages
 
     -- * Game messages
   , messages
+  , render
+  , lookup
   , message
   ) where
 --------------------------------------------------------------------------------
-import Xanthous.Prelude
-
+import Xanthous.Prelude hiding (lookup)
+--------------------------------------------------------------------------------
 import Control.Monad.Random.Class (MonadRandom)
 import Data.Aeson (FromJSON, ToJSON, toJSON)
 import Data.Aeson.Generic.DerivingVia
@@ -22,9 +25,10 @@ import Test.QuickCheck.Arbitrary.Generic
 import Test.QuickCheck.Instances.UnorderedContainers ()
 import Text.Mustache
 import qualified Data.Yaml as Yaml
-
+--------------------------------------------------------------------------------
 import Xanthous.Random
 import Xanthous.Orphans ()
+--------------------------------------------------------------------------------
 
 data Message = Single Template | Choice (NonEmpty Template)
   deriving stock (Show, Eq, Ord, Generic)
@@ -78,10 +82,19 @@ messages
   = either (error . Yaml.prettyPrintParseException) id
   $ Yaml.decodeEither' rawMessages
 
+render :: (MonadRandom m, ToJSON params) => Message -> params -> m Text
+render msg params = do
+  tpl <- resolve msg
+  pure . toStrict . renderMustache tpl $ toJSON params
+
+lookup :: [Text] -> Message
+lookup path = fromMaybe notFound $ messages ^? ix path
+  where notFound
+          = Single
+          $ compileMustacheText "template" "Message not found"
+          ^?! _Right
+
 message :: (MonadRandom m, ToJSON params) => [Text] -> params -> m Text
-message path params = maybe notFound renderMessage $ messages ^? ix path
+message path params = maybe notFound (`render` params) $ messages ^? ix path
   where
-    renderMessage msg = do
-      tpl <- resolve msg
-      pure . toStrict . renderMustache tpl $ toJSON params
     notFound = pure "Message not found"
diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs
index 3e567ee8fa5e..c11cb0e2d4df 100644
--- a/src/Xanthous/Monad.hs
+++ b/src/Xanthous/Monad.hs
@@ -1,22 +1,28 @@
+--------------------------------------------------------------------------------
 module Xanthous.Monad
   ( AppT(..)
   , AppM
   , runAppT
   , continue
   , halt
+    -- * Messages
   , say
   , say_
+  , message
+  , message_
   ) where
-
-import Xanthous.Prelude
-import Control.Monad.Random
-import Control.Monad.State
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Control.Monad.Random
+import           Control.Monad.State
 import qualified Brick
-import Brick (EventM, Next)
-import Data.Aeson
-
-import Xanthous.Game.State
-import Xanthous.Messages (message)
+import           Brick (EventM, Next)
+import           Data.Aeson
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import           Xanthous.Messages (Message)
+import qualified Xanthous.Messages as Messages
+--------------------------------------------------------------------------------
 
 runAppT :: Monad m => AppT m a -> GameState -> m (a, GameState)
 runAppT appt initialState = flip runStateT initialState . unAppT $ appt
@@ -27,12 +33,23 @@ halt = lift . Brick.halt =<< get
 continue :: AppT (EventM n) (Next GameState)
 continue = lift . Brick.continue =<< get
 
+--------------------------------------------------------------------------------
 
 say :: (MonadRandom m, ToJSON params, MonadState GameState m)
     => [Text] -> params -> m ()
 say msgPath params = do
-  msg <- message msgPath params
+  msg <- Messages.message msgPath params
   messageHistory %= pushMessage msg
 
 say_ :: (MonadRandom m, MonadState GameState m) => [Text] -> m ()
 say_ msgPath = say msgPath $ object []
+
+message :: (MonadRandom m, ToJSON params, MonadState GameState m)
+        => Message -> params -> m ()
+message msg params = do
+  m <- Messages.render msg params
+  messageHistory %= pushMessage m
+
+message_ :: (MonadRandom m, MonadState GameState m)
+         => Message ->  m ()
+message_ msg = message msg $ object []
diff --git a/src/Xanthous/Util.hs b/src/Xanthous/Util.hs
index d90cf5b03d3d..3a7c10ace18e 100644
--- a/src/Xanthous/Util.hs
+++ b/src/Xanthous/Util.hs
@@ -24,6 +24,7 @@ module Xanthous.Util
   , uniq
     -- ** Bag sequence algorithms
   , takeWhileInclusive
+  , smallestNotIn
   ) where
 
 import Xanthous.Prelude hiding (foldr)
@@ -194,3 +195,12 @@ uniq = uniqOf folded
 takeWhileInclusive :: (a -> Bool) -> [a] -> [a]
 takeWhileInclusive _ [] = []
 takeWhileInclusive p (x:xs) = x : if p x then takeWhileInclusive p xs else []
+
+-- | Returns the smallest value not in a list
+smallestNotIn :: (Ord a, Bounded a, Enum a) => [a] -> a
+smallestNotIn xs = case uniq $ sort xs of
+  [] -> minBound
+  xs'@(x : _)
+    | x > minBound -> minBound
+    | otherwise
+    -> snd . headEx . filter (uncurry (/=)) $ zip (xs' ++ [minBound]) [minBound..]
diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml
index 8f761ba6e76d..1d8e066ed7a6 100644
--- a/src/Xanthous/messages.yaml
+++ b/src/Xanthous/messages.yaml
@@ -1,5 +1,9 @@
 welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside?
-dead: You have died... Press Enter to continue.
+dead:
+  - You have died...
+  - You die...
+  - You perish...
+  - You have perished...
 
 entities:
   description: You see here {{entityDescriptions}}
@@ -18,10 +22,10 @@ character:
   namePrompt: "What's your name? "
 
 combat:
-  nothingToAttack: There's nothing to attack there
+  nothingToAttack: There's nothing to attack there.
   hit:
-    - You hit the {{creature.creatureType.name}}
-    - You attack the {{creature.creatureType.name}}
+    - You hit the {{creature.creatureType.name}}.
+    - You attack the {{creature.creatureType.name}}.
   creatureAttack:
     - The {{creature.creatureType.name}} hits you!
     - The {{creature.creatureType.name}} attacks you!
@@ -31,3 +35,12 @@ combat:
 
 debug:
   toggleRevealAll: revealAll now set to {{revealAll}}
+
+eat:
+  noFood:
+    - You have nothing edible.
+    - You don't have any food.
+    - You don't have anything to eat.
+    - You search your pockets for something edible, and come up short.
+  menuPrompt: What would you like to eat?
+  eat: You eat the {{item.itemType.name}}.
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-24T21ยท48+0000