Add wielded, wieldable items

Split the character's inventory up into wielded items (in one or both
hands) and the backpack, and display wielded items when drawing the
inventory panel. Currently there's no way to actually *wield* items
though, so this is all unused/untested.

Also, add the ability for items to be "wieldable", which gives specific
descriptions for when attacking with them and also modified damage.

src/Xanthous/App.hs

@@ -143,8 +143,8 @@ handleCommand PickUp = do
   uses entities (entitiesAtPositionWithType @Item pos) >>= \case
     [] -> say_ ["pickUp", "nothingToPickUp"]
     [item] -> pickUpItem item
-    items ->
-      menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items)
+    items' ->
+      menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items')
       $ \(MenuResult item) -> pickUpItem item
   continue
   where
@@ -185,7 +185,7 @@ handleCommand Look = do
 handleCommand Wait = stepGame >> continue
 
 handleCommand Eat = do
-  uses (character . inventory)
+  uses (character . inventory . backpack)
        (V.mapMaybe (\item -> (item,) <$> item ^. Item.itemType . edible))
     >>= \case
       Empty -> say_ ["eat", "noFood"]
@@ -197,7 +197,7 @@ handleCommand Eat = do
             menuItems = mkMenuItems $ imap foodMenuItem food
         in menu_ ["eat", "menuPrompt"] Cancellable menuItems
           $ \(MenuResult (idx, item, edibleItem)) -> do
-            character . inventory %= \inv ->
+            character . inventory . backpack %= \inv ->
               let (before, after) = V.splitAt idx inv
               in before <> fromMaybe Empty (tailMay after)
             let msg = fromMaybe (Messages.lookup ["eat", "eat"])
@@ -231,7 +231,7 @@ handleCommand Read = do
             in readAndContinue msgs
   continue
 
-handleCommand Inventory = showPanel InventoryPanel >> continue
+handleCommand ShowInventory = showPanel InventoryPanel >> continue
 
 handleCommand Save = do
   -- TODO default save locations / config file?
@@ -280,8 +280,8 @@ handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue
 
 handlePromptEvent _ (Prompt _ SContinue _ _ _) _ = continue
 
-handlePromptEvent _ (Prompt _ SMenu _ items cb) (VtyEvent (EvKey (KChar chr) []))
-  | Just (MenuOption _ res) <- items ^. at chr
+handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) []))
+  | Just (MenuOption _ res) <- items' ^. at chr
   = cb (MenuResult res) >> clearPrompt
   | otherwise
   = continue
@@ -350,9 +350,9 @@ menu :: forall (a :: Type) (params :: Type).
      -> Map Char (MenuOption a)           -- ^ Menu items
      -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler
      -> AppM ()
-menu msgPath params cancellable items cb = do
+menu msgPath params cancellable items' cb = do
   msg <- Messages.message msgPath params
-  let p = mkMenu cancellable items cb
+  let p = mkMenu cancellable items' cb
   promptState .= WaitingPrompt msg p
 
 menu_ :: forall (a :: Type).
@@ -419,7 +419,8 @@ attackAt pos =
         say ["combat", "killed"] msgParams
         entities . at creatureID .= Nothing
       else do
-        say ["combat", "hit"] msgParams
+        -- TODO attack messages
+        say ["combat", "hit", "generic"] msgParams
         entities . ix creatureID . positioned .= SomeEntity creature'
     stepGame -- TODO
 

src/Xanthous/Command.hs

@@ -20,7 +20,7 @@ data Command
   | Look
   | Save
   | Read
-  | Inventory
+  | ShowInventory
 
     -- | TODO replace with `:` commands
   | ToggleRevealAll
@@ -36,7 +36,7 @@ commandFromKey (KChar ';') [] = Just Look
 commandFromKey (KChar 'e') [] = Just Eat
 commandFromKey (KChar 'S') [] = Just Save
 commandFromKey (KChar 'r') [] = Just Read
-commandFromKey (KChar 'i') [] = Just Inventory
+commandFromKey (KChar 'i') [] = Just ShowInventory
 
 commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
 

src/Xanthous/Entities/Character.hs

@@ -10,6 +10,22 @@ module Xanthous.Entities.Character
   , hitpointRecoveryRate
   , speed
 
+    -- * Inventory
+  , Inventory(..)
+  , backpack
+  , wielded
+  , items
+    -- ** Wielded items
+  , Wielded(..)
+  , hands
+  , leftHand
+  , rightHand
+  , doubleHanded
+  , wieldedItems
+  , WieldedItem(..)
+  , wieldedItem
+  , wieldableItem
+
     -- *
   , mkCharacter
   , pickUpItem
@@ -27,13 +43,148 @@ import Data.Aeson.Generic.DerivingVia
 import Data.Aeson (ToJSON, FromJSON)
 import Data.Coerce (coerce)
 --------------------------------------------------------------------------------
+import Xanthous.Util.QuickCheck
 import Xanthous.Game.State
 import Xanthous.Entities.Item
-import Xanthous.Data (TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned)
+import Xanthous.Data
+       (TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned, Positioned(..))
+import Xanthous.Entities.RawTypes (WieldableItem, wieldable)
+--------------------------------------------------------------------------------
+
+data WieldedItem = WieldedItem
+  { _wieldedItem :: Item
+  , _wieldableItem :: WieldableItem
+    -- ^ Invariant: item ^. itemType . wieldable ≡ Just wieldableItem
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           WieldedItem
+makeFieldsNoPrefix ''WieldedItem
+
+instance Brain WieldedItem where
+  step ticks (Positioned p wi) =
+    over positioned (\i -> WieldedItem i $ wi ^. wieldableItem)
+    <$> step ticks (Positioned p $ wi ^. wieldedItem)
+
+instance Draw WieldedItem where
+  draw = draw . view wieldedItem
+
+instance Entity WieldedItem where
+  blocksVision = blocksVision . view wieldedItem
+  description = description . view wieldedItem
+  entityChar = entityChar . view wieldedItem
+
+instance Arbitrary WieldedItem where
+  arbitrary = genericArbitrary <&> \wi ->
+    wi & wieldedItem . itemType . wieldable ?~ wi ^. wieldableItem
+
+data Wielded
+  = DoubleHanded WieldedItem
+  | Hands { _leftHand :: !(Maybe WieldedItem)
+          , _rightHand :: !(Maybe WieldedItem)
+          }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Wielded
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ 'SumEnc 'ObjWithSingleField ]
+           Wielded
+
+hands :: Prism' Wielded (Maybe WieldedItem, Maybe WieldedItem)
+hands = prism' (uncurry Hands) $ \case
+  Hands l r -> Just (l, r)
+  _ -> Nothing
+
+leftHand :: Traversal' Wielded WieldedItem
+leftHand = hands . _1 . _Just
+
+rightHand :: Traversal' Wielded WieldedItem
+rightHand = hands . _2 . _Just
+
+doubleHanded :: Prism' Wielded WieldedItem
+doubleHanded = prism' DoubleHanded $ \case
+  DoubleHanded i -> Just i
+  _ -> Nothing
+
+wieldedItems :: Traversal' Wielded Item
+wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> wieldedItem k wielded
+wieldedItems k (Hands l r) = Hands
+  <$> (_Just . wieldedItem) k l
+  <*> (_Just . wieldedItem) k r
+
+data Inventory = Inventory
+  { _backpack :: Vector Item
+  , _wielded :: Wielded
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Inventory
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Inventory
+makeFieldsNoPrefix ''Inventory
+
+items :: Traversal' Inventory Item
+items k (Inventory bp w) = Inventory
+  <$> traversed k bp
+  <*> wieldedItems k w
+
+type instance Element Inventory = Item
+
+instance MonoFunctor Inventory where
+  omap = over items
+
+instance MonoFoldable Inventory where
+  ofoldMap = foldMapOf items
+  ofoldr = foldrOf items
+  ofoldl' = foldlOf' items
+  otoList = toListOf items
+  oall = allOf items
+  oany = anyOf items
+  onull = nullOf items
+  ofoldr1Ex = foldr1Of items
+  ofoldl1Ex' = foldl1Of' items
+  headEx = headEx . toListOf items
+  lastEx = lastEx . toListOf items
+
+instance MonoTraversable Inventory where
+  otraverse = traverseOf items
+
+instance Semigroup Inventory where
+  inv₁ <> inv₂ =
+    let backpack' = inv₁ ^. backpack <> inv₂ ^. backpack
+        (wielded', backpack'') = case (inv₁ ^. wielded, inv₂ ^. wielded) of
+          (wielded₁, wielded₂@(DoubleHanded _)) ->
+            (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems))
+          (wielded₁, wielded₂@(Hands (Just _) (Just _))) ->
+            (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems))
+          (wielded₁, Hands Nothing Nothing) -> (wielded₁, backpack')
+          (Hands Nothing Nothing, wielded₂) -> (wielded₂, backpack')
+          (Hands (Just l₁) Nothing, Hands Nothing (Just r₂)) ->
+            (Hands (Just l₁) (Just r₂), backpack')
+          (wielded₁@(DoubleHanded _), wielded₂) ->
+            (wielded₁, backpack' <> fromList (wielded₂ ^.. wieldedItems))
+          (Hands Nothing (Just r₁), Hands Nothing (Just r₂)) ->
+            (Hands Nothing (Just r₂), r₁ ^. wieldedItem <| backpack')
+          (Hands Nothing r₁, Hands (Just l₂) Nothing) ->
+            (Hands (Just l₂) r₁, backpack')
+          (Hands (Just l₁) Nothing, Hands (Just l₂) Nothing) ->
+            (Hands (Just l₂) Nothing, l₁ ^. wieldedItem <| backpack')
+          (Hands (Just l₁) (Just r₁), Hands Nothing (Just r₂)) ->
+            (Hands (Just l₁) (Just r₂), r₁ ^. wieldedItem <| backpack')
+          (Hands (Just l₁) (Just r₁), Hands (Just l₂) Nothing) ->
+            (Hands (Just l₂) (Just r₁), l₁ ^. wieldedItem <| backpack')
+    in Inventory backpack'' wielded'
+
+instance Monoid Inventory where
+  mempty = Inventory mempty $ Hands Nothing Nothing
+
 --------------------------------------------------------------------------------
 
 data Character = Character
-  { _inventory :: !(Vector Item)
+  { _inventory :: !Inventory
   , _characterName :: !(Maybe Text)
   , _characterDamage :: !Hitpoints
   , _characterHitpoints' :: !Double
@@ -95,7 +246,7 @@ isDead :: Character -> Bool
 isDead = (== 0) . characterHitpoints
 
 pickUpItem :: Item -> Character -> Character
-pickUpItem item = inventory %~ (item <|)
+pickUpItem it = inventory . backpack %~ (it <|)
 
 damage :: Hitpoints -> Character -> Character
 damage (fromIntegral -> amount) = characterHitpoints' %~ \case

src/Xanthous/Entities/Creature.hs

@@ -34,7 +34,8 @@ import           Test.QuickCheck.Arbitrary.Generic
 import           Data.Aeson.Generic.DerivingVia
 import           Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
-import           Xanthous.Entities.RawTypes hiding (Creature, description)
+import           Xanthous.Entities.RawTypes
+                 hiding (Creature, description, damage)
 import           Xanthous.Game.State
 import           Xanthous.Data
 --------------------------------------------------------------------------------

src/Xanthous/Entities/RawTypes.hs

@@ -2,36 +2,51 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 --------------------------------------------------------------------------------
 module Xanthous.Entities.RawTypes
-  ( CreatureType(..)
-  , EdibleItem(..)
-  , ItemType(..)
-  , isEdible
-  , EntityRaw(..)
-
+  (
+    EntityRaw(..)
   , _Creature
+  , _Item
+
+    -- * Creatures
+  , CreatureType(..)
+
+    -- * Items
+  , ItemType(..)
+    -- ** Item sub-types
+    -- *** Edible
+  , EdibleItem(..)
+  , isEdible
+    -- *** Wieldable
+  , WieldableItem(..)
+  , isWieldable
+
     -- * Lens classes
+  , HasAttackMessage(..)
   , HasChar(..)
-  , HasName(..)
+  , HasDamage(..)
   , HasDescription(..)
+  , HasEatMessage(..)
+  , HasEdible(..)
+  , HasFriendly(..)
+  , HasHitpointsHealed(..)
   , HasLongDescription(..)
   , HasMaxHitpoints(..)
-  , HasFriendly(..)
-  , HasEatMessage(..)
-  , HasHitpointsHealed(..)
-  , HasEdible(..)
+  , HasName(..)
   , HasSpeed(..)
+  , HasWieldable(..)
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude
 import Test.QuickCheck
-import Test.QuickCheck.Arbitrary.Generic
 import Data.Aeson.Generic.DerivingVia
 import Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import Xanthous.Messages (Message(..))
 import Xanthous.Data (TicksPerTile, Hitpoints)
 import Xanthous.Data.EntityChar
+import Xanthous.Util.QuickCheck
 --------------------------------------------------------------------------------
+
 data CreatureType = CreatureType
   { _name         :: !Text
   , _description  :: !Text
@@ -42,14 +57,12 @@ data CreatureType = CreatureType
   }
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary CreatureType
   deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        CreatureType
 makeFieldsNoPrefix ''CreatureType
 
-instance Arbitrary CreatureType where
-  arbitrary = genericArbitrary
-
 --------------------------------------------------------------------------------
 
 data EdibleItem = EdibleItem
@@ -58,13 +71,25 @@ data EdibleItem = EdibleItem
   }
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary EdibleItem
   deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        EdibleItem
 makeFieldsNoPrefix ''EdibleItem
 
-instance Arbitrary EdibleItem where
-  arbitrary = genericArbitrary
+data WieldableItem = WieldableItem
+  { _damage :: !Hitpoints
+  , _attackMessage :: !(Maybe Message)
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary WieldableItem
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       WieldableItem
+makeFieldsNoPrefix ''WieldableItem
+
+--------------------------------------------------------------------------------
 
 data ItemType = ItemType
   { _name            :: Text
@@ -72,20 +97,24 @@ data ItemType = ItemType
   , _longDescription :: Text
   , _char            :: EntityChar
   , _edible          :: Maybe EdibleItem
+  , _wieldable       :: Maybe WieldableItem
   }
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary ItemType
   deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        ItemType
 makeFieldsNoPrefix ''ItemType
 
-instance Arbitrary ItemType where
-  arbitrary = genericArbitrary
-
+-- | Can this item be eaten?
 isEdible :: ItemType -> Bool
 isEdible = has $ edible . _Just
 
+-- | Can this item be used as a weapon?
+isWieldable :: ItemType -> Bool
+isWieldable = has $ wieldable . _Just
+
 --------------------------------------------------------------------------------
 
 data EntityRaw
@@ -93,9 +122,9 @@ data EntityRaw
   | Item ItemType
   deriving stock (Show, Eq, Generic)
   deriving anyclass (NFData)
+  deriving Arbitrary via GenericArbitrary EntityRaw
   deriving (FromJSON)
        via WithOptions '[ SumEnc ObjWithSingleField ]
                        EntityRaw
 makePrisms ''EntityRaw
 
-{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}

src/Xanthous/Entities/Raws/stick.yaml

@@ -0,0 +1,14 @@
+Item:
+  name: stick
+  description: a wooden stick
+  longDescription: A sturdy branch broken off from some sort of tree
+  char:
+    char: ∤
+    style:
+      foreground: yellow
+  wieldable:
+    damage: 2
+    attackMessage:
+      - You bonk the {{creature.creatureType.name}} over the head with your stick.
+      - You bash the {{creature.creatureType.name}} on the noggin with your stick.
+      - You whack the {{creature.creatureType.name}} with your stick.

src/Xanthous/Game/Draw.hs

@@ -14,6 +14,7 @@ import           Xanthous.Data.EntityMap (EntityMap, atPosition)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Game.State
 import           Xanthous.Entities.Character
+import           Xanthous.Entities.Item (Item)
 import           Xanthous.Game
                  ( GameState(..)
                  , entities
@@ -105,16 +106,36 @@ drawPanel game panel
   . viewport (Resource.Panel panel) Vertical
   $ case panel of
       InventoryPanel ->
-        let items = game ^. character . inventory
-        in if null items
-           then txtWrap "Your inventory is empty right now."
-           else
-             txtWrap "You are currently carrying the following items:"
+        drawWielded (game ^. character . inventory . wielded)
+        <=> drawBackpack (game ^. character . inventory . backpack)
+  where
+    drawWielded :: Wielded -> Widget Name
+    drawWielded (Hands Nothing Nothing) = emptyWidget
+    drawWielded (DoubleHanded i) =
+      txt $ "You are holding " <> description i <> " in both hands"
+    drawWielded (Hands l r) =
+      maybe
+        emptyWidget
+        (\i ->
+           txt $ "You are holding " <> description i <> " in your left hand")
+        l
+      <=>
+      maybe
+        emptyWidget
+        (\i ->
+           txt $ "You are holding " <> description i <> " in your right hand")
+        r
+
+    drawBackpack :: Vector Item -> Widget Name
+    drawBackpack Empty = txtWrap "Your backpack is empty right now."
+    drawBackpack backpackItems
+      = txtWrap ( "You are currently carrying the following items in your "
+                <> "backpack:")
         <=> txt " "
         <=> foldl' (<=>) emptyWidget
             (map
               (txtWrap . ((bullet <| " ") <>) . description)
-                  items)
+              backpackItems)
 
 drawCharacterInfo :: Character -> Widget Name
 drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints

src/Xanthous/messages.yaml

@@ -37,6 +37,10 @@ combat:
   nothingToAttack: There's nothing to attack there.
   menu: Which creature would you like to attack?
   hit:
+    fists:
+      - You punch the {{creature.creatureType.name}} with your bare fists! It hurts. A lot.
+      - You strike the {{creature.creatureType.name}} with your bare fists! It leaves a bit of a bruise on your knuckles.
+    generic:
       - You hit the {{creature.creatureType.name}}.
       - You attack the {{creature.creatureType.name}}.
   creatureAttack: