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.

4 files changed, 218 insertions, 23 deletions

diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index dd14390df979..5ddf33c29434 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/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
diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs
index 6f97c128d257..19c7834228e0 100644
--- a/src/Xanthous/Entities/Creature.hs
+++ b/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
 --------------------------------------------------------------------------------
diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs
index 822b93f2dfe1..4b31524ad7f1 100644
--- a/src/Xanthous/Entities/RawTypes.hs
+++ b/src/Xanthous/Entities/RawTypes.hs
@@ -2,36 +2,51 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 --------------------------------------------------------------------------------
 module Xanthous.Entities.RawTypes
-  ( CreatureType(..)
-  , EdibleItem(..)
+  (
+    EntityRaw(..)
+  , _Creature
+  , _Item
+
+    -- * Creatures
+  , CreatureType(..)
+
+    -- * Items
   , ItemType(..)
+    -- ** Item sub-types
+    -- *** Edible
+  , EdibleItem(..)
   , isEdible
-  , EntityRaw(..)
+    -- *** Wieldable
+  , WieldableItem(..)
+  , isWieldable
 
-  , _Creature
     -- * Lens classes
+  , HasAttackMessage(..)
   , HasChar(..)
-  , HasName(..)
+  , HasDamage(..)
   , HasDescription(..)
-  , HasLongDescription(..)
-  , HasMaxHitpoints(..)
-  , HasFriendly(..)
   , HasEatMessage(..)
-  , HasHitpointsHealed(..)
   , HasEdible(..)
+  , HasFriendly(..)
+  , HasHitpointsHealed(..)
+  , HasLongDescription(..)
+  , HasMaxHitpoints(..)
+  , 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) #-}
diff --git a/src/Xanthous/Entities/Raws/stick.yaml b/src/Xanthous/Entities/Raws/stick.yaml
new file mode 100644
index 000000000000..bc7fde4d8b02
--- /dev/null
+++ b/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.