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.
This commit is contained in:
Griffin Smith
parent
262fc7fb41
commit
de8052cef8
16 changed files with 289 additions and 73 deletions
|
|
@ -48,6 +48,7 @@ dependencies:
|
|||
- reflection
|
||||
- stache
|
||||
- tomland
|
||||
- vector
|
||||
- vty
|
||||
- yaml
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -6,3 +6,7 @@ Item:
|
|||
char: 'n'
|
||||
style:
|
||||
foreground: yellow
|
||||
edible:
|
||||
hitpointsHealed: 2
|
||||
eatMessage:
|
||||
- You slurp up the noodles. Yumm!
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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> )"
|
||||
<> show ps <> " "
|
||||
<> showPri
|
||||
<> " <function>)"
|
||||
where showPri = case pt of
|
||||
SMenu -> show pri
|
||||
_ -> "()"
|
||||
|
||||
mkPrompt :: PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 []
|
||||
|
|
|
|||
|
|
@ -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..]
|
||||
|
|
|
|||
|
|
@ -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}}.
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ import qualified Xanthous.GameSpec
|
|||
import qualified Xanthous.Generators.UtilSpec
|
||||
import qualified Xanthous.MessageSpec
|
||||
import qualified Xanthous.OrphansSpec
|
||||
import qualified Xanthous.UtilSpec
|
||||
import qualified Xanthous.Util.GraphicsSpec
|
||||
import qualified Xanthous.Util.InflectionSpec
|
||||
|
||||
|
|
@ -21,6 +22,7 @@ test = testGroup "Xanthous"
|
|||
, Xanthous.MessageSpec.test
|
||||
, Xanthous.OrphansSpec.test
|
||||
, Xanthous.DataSpec.test
|
||||
, Xanthous.UtilSpec.test
|
||||
, Xanthous.Util.GraphicsSpec.test
|
||||
, Xanthous.Util.InflectionSpec.test
|
||||
]
|
||||
|
|
|
|||
24
test/Xanthous/UtilSpec.hs
Normal file
24
test/Xanthous/UtilSpec.hs
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
module Xanthous.UtilSpec (main, test) where
|
||||
|
||||
import Test.Prelude
|
||||
import Xanthous.Util
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain test
|
||||
|
||||
test :: TestTree
|
||||
test = testGroup "Xanthous.Util"
|
||||
[ testGroup "smallestNotIn"
|
||||
[ testCase "examples" $ do
|
||||
smallestNotIn [7 :: Word, 3, 7] @?= 0
|
||||
smallestNotIn [7 :: Word, 0, 1, 3, 7] @?= 2
|
||||
, testProperty "returns an element not in the list" $ \(xs :: [Word]) ->
|
||||
smallestNotIn xs `notElem` xs
|
||||
, testProperty "pred return is in the list" $ \(xs :: [Word]) ->
|
||||
let res = smallestNotIn xs
|
||||
in res /= 0 ==> pred res `elem` xs
|
||||
, testProperty "ignores order" $ \(xs :: [Word]) ->
|
||||
forAll (shuffle xs) $ \shuffledXs ->
|
||||
smallestNotIn xs === smallestNotIn shuffledXs
|
||||
]
|
||||
]
|
||||
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: ad4acf50f6be0dc7ae6c68d9920b61c2d32b5d759aae7311a124d159b4a9bc7f
|
||||
-- hash: ac15bf59fd57f7a0bc23f010aec83824f819592494145cbce3e1db36e23f1107
|
||||
|
||||
name: xanthous
|
||||
version: 0.1.0.0
|
||||
|
|
@ -103,6 +103,7 @@ library
|
|||
, reflection
|
||||
, stache
|
||||
, tomland
|
||||
, vector
|
||||
, vty
|
||||
, yaml
|
||||
default-language: Haskell2010
|
||||
|
|
@ -183,6 +184,7 @@ executable xanthous
|
|||
, reflection
|
||||
, stache
|
||||
, tomland
|
||||
, vector
|
||||
, vty
|
||||
, xanthous
|
||||
, yaml
|
||||
|
|
@ -202,6 +204,7 @@ test-suite test
|
|||
Xanthous.OrphansSpec
|
||||
Xanthous.Util.GraphicsSpec
|
||||
Xanthous.Util.InflectionSpec
|
||||
Xanthous.UtilSpec
|
||||
Paths_xanthous
|
||||
hs-source-dirs:
|
||||
test
|
||||
|
|
@ -244,6 +247,7 @@ test-suite test
|
|||
, tasty-hunit
|
||||
, tasty-quickcheck
|
||||
, tomland
|
||||
, vector
|
||||
, vty
|
||||
, xanthous
|
||||
, yaml
|
||||
|
|
|
|||
Loading…
Reference in a new issue