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:
parent
d8bd8e7eea
commit
f0c167d361
8 changed files with 139 additions and 31 deletions
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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)
|
||||
]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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³"
|
||||
]
|
||||
]
|
||||
]
|
||||
|
|
Loading…
Reference in a new issue