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

users/grfn/xanthous/src/Xanthous/App.hs

@@ -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
+-- | Prompt with an item to select out of the inventory and call callback with
--- inventory, and call callback with it
+-- 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 =
+selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = do
-  uses (character . inventory . backpack)
+  uses (character . inventory)
-       (V.mapMaybe $ preview extraInfo)
+       (V.mapMaybe (preview extraInfo) . toVectorOf items)
     >>= \case
       Empty -> onEmpty
-      items' ->
+      items' -> menu msgPath msgParams cancellable (itemMenu items') cb
-        menu msgPath msgParams cancellable (itemMenu items')
-        $ \(MenuResult (idx, item)) -> do
-          character . inventory . backpack %= removeVectorIndex idx
-          cb $ MenuResult item
   where
-    itemMenu = mkMenuItems . imap itemMenuItem
+    itemMenu = mkMenuItems . map itemMenuItem
-    itemMenuItem idx extraInfoItem =
+    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
 

users/grfn/xanthous/src/Xanthous/Command.hs

@@ -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

users/grfn/xanthous/src/Xanthous/Data.hs

@@ -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

users/grfn/xanthous/src/Xanthous/Data/App.hs

@@ -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
+  = -- | A panel displaying the character's inventory
-  deriving stock (Show, Eq, Ord, Generic, Enum, Bounded)
+    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
 

users/grfn/xanthous/src/Xanthous/Entities/Item.hs

@@ -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)
+  ]

users/grfn/xanthous/src/Xanthous/Game/Draw.hs

@@ -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

users/grfn/xanthous/src/Xanthous/messages.yaml

@@ -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

users/grfn/xanthous/test/Xanthous/DataSpec.hs

@@ -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³"
+      ]
+    ]
   ]