feat(xanthous): Add a command to describe an item in the inventory

Add a new DescribeInventory command, bound to I, to prompt for an item
in the inventory (anywhere in the inventory, including wielded) and
display a (new) panel describing it in detail. This description includes
the description, the long description, and the item's physical
properties (volume, density, and weight).

Change-Id: Idc1a05ab16b4514728d42aa6b520f93bea807c07
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3227
Reviewed-by: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI
This commit is contained in:
Griffin Smith 2021-06-19 15:40:11 -04:00 committed by grfn
parent d8bd8e7eea
commit f0c167d361
8 changed files with 139 additions and 31 deletions

View file

@ -1,6 +1,7 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
module Xanthous.App
( makeApp
, RunType(..)
@ -19,6 +20,7 @@ import qualified Data.Vector as V
import System.Exit
import System.Directory (doesFileExist)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Vector.Lens (toVectorOf)
--------------------------------------------------------------------------------
import Xanthous.App.Common
import Xanthous.App.Time
@ -151,7 +153,7 @@ handleCommand PickUp = do
stepGameBy 100 -- TODO
handleCommand Drop = do
selectItemFromInventory_ ["drop", "menu"] Cancellable id
takeItemFromInventory_ ["drop", "menu"] Cancellable id
(say_ ["drop", "nothing"])
$ \(MenuResult item) -> do
entitiesAtCharacter %= (SomeEntity item <|)
@ -271,8 +273,16 @@ handleCommand Read = do
handleCommand ShowInventory = showPanel InventoryPanel >> continue
handleCommand DescribeInventory = do
selectItemFromInventory_ ["inventory", "describe", "select"] Cancellable id
(say_ ["inventory", "describe", "nothing"])
$ \(MenuResult item) ->
showPanel . ItemDescriptionPanel $ Item.fullDescription item
continue
handleCommand Wield = do
selectItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem
takeItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem
(say_ ["wield", "nothing"])
$ \(MenuResult item) -> do
prevItems <- character . inventory . wielded <<.= inRightHand item
@ -403,8 +413,8 @@ entityMenuChar entity
then ec
else 'a'
-- | Prompt with an item to select out of the inventory, remove it from the
-- inventory, and call callback with it
-- | Prompt with an item to select out of the inventory and call callback with
-- it
selectItemFromInventory
:: forall item params.
(ToJSON params)
@ -417,23 +427,21 @@ selectItemFromInventory
-> AppM () -- ^ Action to take if there are no items matching
-> (PromptResult ('Menu item) -> AppM ())
-> AppM ()
selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb =
uses (character . inventory . backpack)
(V.mapMaybe $ preview extraInfo)
selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = do
uses (character . inventory)
(V.mapMaybe (preview extraInfo) . toVectorOf items)
>>= \case
Empty -> onEmpty
items' ->
menu msgPath msgParams cancellable (itemMenu items')
$ \(MenuResult (idx, item)) -> do
character . inventory . backpack %= removeVectorIndex idx
cb $ MenuResult item
items' -> menu msgPath msgParams cancellable (itemMenu items') cb
where
itemMenu = mkMenuItems . imap itemMenuItem
itemMenuItem idx extraInfoItem =
itemMenu = mkMenuItems . map itemMenuItem
itemMenuItem extraInfoItem =
let item = extraInfo # extraInfoItem
in ( entityMenuChar item
, MenuOption (description item) (idx, extraInfoItem))
, MenuOption (description item) extraInfoItem)
-- | Prompt with an item to select out of the inventory and call callback with
-- it
selectItemFromInventory_
:: forall item.
[Text] -- ^ Menu message
@ -446,6 +454,38 @@ selectItemFromInventory_
-> AppM ()
selectItemFromInventory_ msgPath = selectItemFromInventory msgPath ()
-- | Prompt with an item to select out of the inventory, remove it from the
-- inventory, and call callback with it
takeItemFromInventory
:: forall item params.
(ToJSON params)
=> [Text] -- ^ Menu message
-> params -- ^ Menu message params
-> PromptCancellable -- ^ Is the menu cancellable?
-> Prism' Item item -- ^ Attach some extra information to the item, in a
-- recoverable fashion. Prism vs iso so we can discard
-- items.
-> AppM () -- ^ Action to take if there are no items matching
-> (PromptResult ('Menu item) -> AppM ())
-> AppM ()
takeItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb =
selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty
$ \(MenuResult item) -> do
character . inventory . backpack %= filter (/= (item ^. re extraInfo))
cb $ MenuResult item
takeItemFromInventory_
:: forall item.
[Text] -- ^ Menu message
-> PromptCancellable -- ^ Is the menu cancellable?
-> Prism' Item item -- ^ Attach some extra information to the item, in a
-- recoverable fashion. Prism vs iso so we can discard
-- items.
-> AppM () -- ^ Action to take if there are no items matching
-> (PromptResult ('Menu item) -> AppM ())
-> AppM ()
takeItemFromInventory_ msgPath = takeItemFromInventory msgPath ()
-- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity)
-- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity

View file

@ -24,6 +24,7 @@ data Command
| Save
| Read
| ShowInventory
| DescribeInventory
| Wield
| GoUp
| GoDown
@ -50,6 +51,7 @@ commandFromKey (KChar 'e') [] = Just Eat
commandFromKey (KChar 'S') [] = Just Save
commandFromKey (KChar 'r') [] = Just Read
commandFromKey (KChar 'i') [] = Just ShowInventory
commandFromKey (KChar 'I') [] = Just DescribeInventory
commandFromKey (KChar 'w') [] = Just Wield
commandFromKey (KChar '<') [] = Just GoUp
commandFromKey (KChar '>') [] = Just GoDown

View file

@ -11,6 +11,7 @@
--------------------------------------------------------------------------------
-- | Common data types for Xanthous
--------------------------------------------------------------------------------
{-# LANGUAGE AllowAmbiguousTypes #-}
module Xanthous.Data
( Opposite(..)
@ -60,6 +61,8 @@ module Xanthous.Data
, Cubic(..)
, Grams
, Meters
, Unit(..)
, UnitSymbol(..)
-- *
, Dimensions'(..)
@ -114,13 +117,14 @@ import Data.Array.IArray
import Data.Aeson.Generic.DerivingVia
import Data.Aeson
( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject)
import Data.Random (Distribution)
import Data.Coerce
import Data.Proxy (Proxy(Proxy))
--------------------------------------------------------------------------------
import Xanthous.Util (EqEqProp(..), EqProp, between)
import Xanthous.Util.QuickCheck (GenericArbitrary(..))
import Xanthous.Orphans ()
import Xanthous.Util.Graphics
import Data.Random (Distribution)
import Data.Coerce
--------------------------------------------------------------------------------
-- | opposite ∘ opposite ≡ id
@ -147,6 +151,18 @@ instance Integral a => Scalar (ScalarIntegral a) where
deriving via (ScalarIntegral Integer) instance Scalar Integer
deriving via (ScalarIntegral Word) instance Scalar Word
-- | Units of measure
class Unit a where
unitSuffix :: Text
type UnitSymbol :: Symbol -> Type -> Type
newtype UnitSymbol suffix a = UnitSymbol a
instance KnownSymbol suffix => Unit (UnitSymbol suffix a) where
unitSuffix = pack $ symbolVal @suffix Proxy
newtype ShowUnitSuffix a b = ShowUnitSuffix a
instance (Show b, Unit a, Coercible a b) => Show (ShowUnitSuffix a b) where
show a = show (coerce @_ @b a) <> " " <> unpack (unitSuffix @a)
--------------------------------------------------------------------------------
data Position' a where
@ -494,17 +510,21 @@ rotations orig@(Neighbors tl t tr l r bl b br) = V4
--------------------------------------------------------------------------------
newtype Per a b = Rate Double
deriving stock (Show, Eq, Generic)
deriving stock (Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON)
via Double
deriving (Semigroup, Monoid) via Product Double
deriving Show via ShowUnitSuffix (Per a b) Double
deriving via Double
instance ( Distribution d Double
, forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
)
=> Distribution d (Per a b)
instance (Unit a, Unit b) => Unit (a `Per` b) where
unitSuffix = unitSuffix @a <> "/" <> unitSuffix @b
invertRate :: a `Per` b -> b `Per` a
invertRate (Rate p) = Rate $ 1 / p
@ -531,42 +551,51 @@ instance forall a. (Scalar a) => MulUnit (Square a) a where
x' |*| y' = Cubic @a . fromScalar $ scalar x' * scalar y'
newtype Square a = Square a
deriving stock (Show, Eq, Generic)
deriving stock (Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON
, Scalar
)
via a
deriving Show via ShowUnitSuffix (Square a) a
deriving via (a :: Type)
instance ( Distribution d a
, forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
)
=> Distribution d (Square a)
instance Unit a => Unit (Square a) where
unitSuffix = unitSuffix @a <> "²"
newtype Cubic a = Cubic a
deriving stock (Show, Eq, Generic)
deriving stock (Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON
, Scalar
)
via a
deriving Show via ShowUnitSuffix (Cubic a) a
deriving via (a :: Type)
instance ( Distribution d a
, forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
)
=> Distribution d (Cubic a)
instance Unit a => Unit (Cubic a) where
unitSuffix = unitSuffix @a <> "³"
--------------------------------------------------------------------------------
newtype Ticks = Ticks Word
deriving stock (Show, Eq, Generic)
deriving stock (Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word
deriving (Semigroup, Monoid) via (Sum Word)
deriving Scalar via ScalarIntegral Ticks
deriving Arbitrary via GenericArbitrary Ticks
deriving Unit via UnitSymbol "ticks" Ticks
deriving Show via ShowUnitSuffix Ticks Word
deriving via Word
instance ( Distribution d Word
, forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
@ -574,11 +603,13 @@ deriving via Word
=> Distribution d Ticks
newtype Tiles = Tiles Double
deriving stock (Show, Eq, Generic)
deriving stock (Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double
deriving (Semigroup, Monoid) via (Sum Double)
deriving Arbitrary via GenericArbitrary Tiles
deriving Unit via UnitSymbol "m" Tiles
deriving Show via ShowUnitSuffix Tiles Double
deriving via Double
instance ( Distribution d Double
, forall xx yy. Coercible xx yy => Coercible (d xx) (d yy)
@ -594,29 +625,31 @@ timesTiles = (|*|)
--------------------------------------------------------------------------------
newtype Hitpoints = Hitpoints Word
deriving stock (Show, Eq, Generic)
deriving stock (Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON)
via Word
deriving (Semigroup, Monoid) via Sum Word
deriving Unit via UnitSymbol "hp" Hitpoints
deriving Show via ShowUnitSuffix Hitpoints Word
--------------------------------------------------------------------------------
-- | Grams, the fundamental measure of weight in Xanthous.
newtype Grams = Grams Double
deriving stock (Show, Eq, Generic)
deriving stock (Eq, Generic)
deriving anyclass (NFData, CoArbitrary, Function)
deriving ( Arbitrary, Num, Ord, Enum, Real, Floating, Fractional, RealFloat
, RealFrac, Scalar, ToJSON, FromJSON
)
via Double
deriving (Semigroup, Monoid) via Sum Double
deriving Unit via UnitSymbol "g" Grams
deriving Show via ShowUnitSuffix Grams Double
-- | Every tile is 1 meter
type Meters = Tiles
--------------------------------------------------------------------------------
data Box a = Box

View file

@ -8,6 +8,7 @@ module Xanthous.Data.App
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Test.QuickCheck
import Test.QuickCheck.Instances.Text ()
import Data.Aeson (ToJSON, FromJSON)
--------------------------------------------------------------------------------
import Xanthous.Util.QuickCheck
@ -15,8 +16,13 @@ import Xanthous.Util.QuickCheck
-- | Enum for "panels" displayed in the game's UI.
data Panel
= InventoryPanel -- ^ A panel displaying the character's inventory
deriving stock (Show, Eq, Ord, Generic, Enum, Bounded)
= -- | A panel displaying the character's inventory
InventoryPanel
| -- | A panel describing an item in the inventory in detail
--
-- The argument is the full description of the item
ItemDescriptionPanel Text
deriving stock (Show, Eq, Ord, Generic)
deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
deriving Arbitrary via GenericArbitrary Panel

View file

@ -10,6 +10,7 @@ module Xanthous.Entities.Item
, newWithType
, isEdible
, weight
, fullDescription
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
@ -61,3 +62,15 @@ isEdible = Raw.isEdible . view itemType
-- density of its material
weight :: Item -> Grams
weight item = (item ^. density) |*| (item ^. volume)
-- | Describe the item in full detail
fullDescription :: Item -> Text
fullDescription item = unlines
[ item ^. itemType . Raw.description
, ""
, item ^. itemType . Raw.longDescription
, ""
, "volume: " <> tshow (item ^. volume)
, "density: " <> tshow (item ^. density)
, "weight: " <> tshow (weight item)
]

View file

@ -116,6 +116,7 @@ drawPanel game panel
. viewport (Resource.Panel panel) Vertical
. case panel of
InventoryPanel -> drawInventoryPanel
ItemDescriptionPanel desc -> const $ txtWrap desc
$ game
drawCharacterInfo :: Character -> Widget ResourceName

View file

@ -24,7 +24,7 @@ entities:
pickUp:
menu: What would you like to pick up?
pickUp: You pick up the {{item.itemType.name}}
pickUp: You pick up the {{item.itemType.name}}.
nothingToPickUp: "There's nothing here to pick up"
cant:
@ -101,6 +101,11 @@ read:
nothing: "There's nothing there to read"
result: "\"{{message}}\""
inventory:
describe:
select: Select an item in your inventory to describe
nothing: You aren't carrying anything
wield:
nothing:
- You aren't carrying anything you can wield

View file

@ -95,4 +95,12 @@ test = testGroup "Xanthous.Data"
rots
]
]
, testGroup "units"
[ testGroup "unit suffixes"
[ testCase "density"
$ tshow (10000 :: Grams `Per` Cubic Meters)
@?= "10000.0 g/m³"
]
]
]