feat(xanthous): Allow selecting hand for wielding r/3962

When wielding items, allow selecting which hand the item should be
wielded in.

Currently this has no actual effect on the mechanics of combat - that'll
come next.

Change-Id: Ic289ca2d8fa6f5fc0ad5bd0b012818a3acd8599e
Reviewed-on: https://cl.tvl.fyi/c/depot/+/5470
Reviewed-by: grfn <grfn@gws.fyi>
Autosubmit: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI

4 files changed, 119 insertions, 30 deletions

diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs
index d4ffb226305a..fdc648dda42e 100644
--- a/users/grfn/xanthous/src/Xanthous/App.hs
+++ b/users/grfn/xanthous/src/Xanthous/App.hs
@@ -54,12 +54,12 @@ import           Xanthous.Physics (throwDistance, bluntThrowDamage)
 import           Xanthous.Data.EntityMap.Graphics (lineOfSight)
 import           Xanthous.Data.EntityMap (EntityID)
 --------------------------------------------------------------------------------
---------------------------------------------------------------------------------
 import           Xanthous.Entities.Common
                  ( InventoryPosition, describeInventoryPosition, backpack
                  , wieldableItem, wieldedItems, wielded, itemsWithPosition
-                 , removeItemFromPosition, asWieldedItem, inRightHand
-                 , wieldedItem, items
+                 , removeItemFromPosition, asWieldedItem
+                 , wieldedItem, items, Hand (..), describeHand, wieldInHand
+                 , WieldedItem
                  )
 import qualified Xanthous.Entities.Character as Character
 import           Xanthous.Entities.Character hiding (pickUpItem)
@@ -296,14 +296,30 @@ handleCommand DescribeInventory = do
 
 
 handleCommand Wield = do
-  takeItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem
-    (say_ ["wield", "nothing"])
-    $ \(MenuResult item) -> do
-      prevItems <- character . inventory . wielded <<.= inRightHand item
+  selectItem $ \(MenuResult (item :: WieldedItem)) -> do
+    selectHand $ \(MenuResult hand) -> do
+      prevItems <- character . inventory . wielded %%= wieldInHand hand item
       character . inventory . backpack
-        <>= fromList (prevItems ^.. wieldedItems . wieldedItem)
-      say ["wield", "wielded"] item
+        <>= fromList (map (view wieldedItem) prevItems)
+      say ["wield", "wielded"] $ object [ "item" A..= item
+                                        , "hand" A..= describeHand hand
+                                        ]
   continue
+  where
+    selectItem =
+      takeItemFromInventory_ ["wield", "menu"] Cancellable asWieldedItem
+        (say_ ["wield", "nothing"])
+    selectHand
+      = menu_
+      ["wield", "hand"]
+      Cancellable
+      handsMenu
+    handsMenu = mapFromList
+      . map (second $ MenuOption =<< describeHand)
+      $ [ ('l', LeftHand)
+        , ('r', RightHand)
+        , ('b', BothHands)
+        ]
 
 handleCommand Fire = do
   selectItemFromInventory_ ["fire", "menu"] Cancellable id
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Common.hs b/users/grfn/xanthous/src/Xanthous/Entities/Common.hs
index becd1b1ef62e..368b03f25bed 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/Common.hs
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Common.hs
@@ -20,12 +20,18 @@ module Xanthous.Entities.Common
 
     -- ** Wielded items
   , Wielded(..)
+  , nothingWielded
   , hands
   , leftHand
   , rightHand
   , inLeftHand
   , inRightHand
   , doubleHanded
+  , Hand(..)
+  , itemsInHand
+  , inHand
+  , wieldInHand
+  , describeHand
   , wieldedItems
   , WieldedItem(..)
   , wieldedItem
@@ -95,6 +101,7 @@ data Wielded
        via WithOptions '[ 'SumEnc 'ObjWithSingleField ]
            Wielded
 
+
 nothingWielded :: Wielded
 nothingWielded = Hands Nothing Nothing
 
@@ -124,6 +131,43 @@ wieldedItems :: Traversal' Wielded WieldedItem
 wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> k wielded
 wieldedItems k (Hands l r) = Hands <$> _Just k l <*> _Just k r
 
+
+data Hand
+  = LeftHand
+  | RightHand
+  | BothHands
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Hand
+
+itemsInHand :: Hand -> Wielded -> [WieldedItem]
+itemsInHand LeftHand (DoubleHanded wi) = [wi]
+itemsInHand LeftHand (Hands lh _) = toList lh
+itemsInHand RightHand (DoubleHanded wi) = [wi]
+itemsInHand RightHand (Hands _ rh) = toList rh
+itemsInHand BothHands (DoubleHanded wi) = [wi]
+itemsInHand BothHands (Hands lh rh) = toList lh <> toList rh
+
+inHand :: Hand -> WieldedItem -> Wielded
+inHand LeftHand = inLeftHand
+inHand RightHand = inRightHand
+inHand BothHands = review doubleHanded
+
+wieldInHand :: Hand -> WieldedItem -> Wielded -> ([WieldedItem], Wielded)
+wieldInHand hand item w = (itemsInHand hand w, doWield)
+  where
+    doWield = case (hand, w) of
+      (LeftHand, Hands _ r) -> Hands (Just item) r
+      (LeftHand, DoubleHanded _) -> inLeftHand item
+      (RightHand, Hands l _) -> Hands l (Just item)
+      (RightHand, DoubleHanded _) -> inRightHand item
+      (BothHands, _) -> DoubleHanded item
+
+describeHand :: Hand -> Text
+describeHand LeftHand = "your left hand"
+describeHand RightHand = "your right hand"
+describeHand BothHands = "both hands"
+
 data Inventory = Inventory
   { _backpack :: Vector Item
   , _wielded :: Wielded
@@ -199,27 +243,23 @@ class HasInventory s a | s -> a where
 -- | Representation for where in the inventory an item might be
 data InventoryPosition
   = Backpack
-  | LeftHand
-  | RightHand
-  | BothHands
+  | InHand Hand
   deriving stock (Eq, Show, Ord, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
   deriving Arbitrary via GenericArbitrary InventoryPosition
 
 -- | Return a human-readable description of the given 'InventoryPosition'
 describeInventoryPosition :: InventoryPosition -> Text
-describeInventoryPosition Backpack  = "In backpack"
-describeInventoryPosition LeftHand  = "Wielded, in left hand"
-describeInventoryPosition RightHand = "Wielded, in right hand"
-describeInventoryPosition BothHands = "Wielded, in both hands"
+describeInventoryPosition Backpack       = "In backpack"
+describeInventoryPosition (InHand hand)  = "Wielded, in " <> describeHand hand
 
 -- | Given a position in the inventory, return a traversal on the inventory over
 -- all the items in that position
 inventoryPosition :: InventoryPosition -> Traversal' Inventory Item
 inventoryPosition Backpack = backpack . traversed
-inventoryPosition LeftHand = wielded . leftHand . _Just . wieldedItem
-inventoryPosition RightHand = wielded . leftHand . _Just . wieldedItem
-inventoryPosition BothHands = wielded . doubleHanded . wieldedItem
+inventoryPosition (InHand LeftHand) = wielded . leftHand . _Just . wieldedItem
+inventoryPosition (InHand RightHand) = wielded . leftHand . _Just . wieldedItem
+inventoryPosition (InHand BothHands) = wielded . doubleHanded . wieldedItem
 
 -- | A fold over all the items in the inventory accompanied by their position in
 -- the inventory
@@ -230,20 +270,20 @@ itemsWithPosition = folding $ (<>) <$> backpackItems <*> handItems
   where
     backpackItems = toListOf $ backpack . folded . to (Backpack ,)
     handItems inv = case inv ^. wielded of
-       DoubleHanded i -> pure (BothHands, i ^. wieldedItem)
-       Hands l r -> (l ^.. folded . wieldedItem . to (LeftHand ,))
-                 <> (r ^.. folded . wieldedItem . to (RightHand ,))
+       DoubleHanded i -> pure (InHand BothHands, i ^. wieldedItem)
+       Hands l r -> (l ^.. folded . wieldedItem . to (InHand LeftHand ,))
+                 <> (r ^.. folded . wieldedItem . to (InHand RightHand ,))
 
 -- | Remove the first item equal to 'Item' from the given position in the
 -- inventory
 removeItemFromPosition :: InventoryPosition -> Item -> Inventory -> Inventory
 removeItemFromPosition Backpack item inv
   = inv & backpack %~ removeFirst (== item)
-removeItemFromPosition LeftHand item inv
+removeItemFromPosition (InHand LeftHand) item inv
   = inv & wielded . leftHand %~ filter ((/= item) . view wieldedItem)
-removeItemFromPosition RightHand item inv
+removeItemFromPosition (InHand RightHand) item inv
   = inv & wielded . rightHand %~ filter ((/= item) . view wieldedItem)
-removeItemFromPosition BothHands item inv
+removeItemFromPosition (InHand BothHands) item inv
   | has (wielded . doubleHanded . wieldedItem . filtered (== item)) inv
   = inv & wielded .~ nothingWielded
   | otherwise
diff --git a/users/grfn/xanthous/src/Xanthous/messages.yaml b/users/grfn/xanthous/src/Xanthous/messages.yaml
index 62cb033d0c99..bc08ec1ad24d 100644
--- a/users/grfn/xanthous/src/Xanthous/messages.yaml
+++ b/users/grfn/xanthous/src/Xanthous/messages.yaml
@@ -115,8 +115,8 @@ wield:
     - You can't wield anything in your backpack
     - You can't wield anything currently in your backpack
   menu: What would you like to wield?
-  # TODO: use actual hands
-  wielded : You wield the {{wieldedItem.itemType.name}} in your right hand.
+  hand: Wield in which hand?
+  wielded: You wield the {{item.wieldedItem.itemType.name}} in {{hand}}
 
 fire:
   nothing:
diff --git a/users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs
index ba27e3cbca4e..a6f8401cf75b 100644
--- a/users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs
+++ b/users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs
@@ -10,6 +10,17 @@ import           Xanthous.Entities.Common
 main :: IO ()
 main = defaultMain test
 
+newtype OneHand = OneHand Hand
+  deriving stock Show
+
+instance Arbitrary OneHand where
+  arbitrary = OneHand <$> elements [LeftHand, RightHand]
+
+otherHand :: Hand -> Hand
+otherHand LeftHand = RightHand
+otherHand RightHand = LeftHand
+otherHand BothHands = error "OtherHand BothHands"
+
 test :: TestTree
 test = testGroup "Xanthous.Entities.CommonSpec"
   [ testGroup "Inventory"
@@ -20,13 +31,35 @@ test = testGroup "Xanthous.Entities.CommonSpec"
             let (old, inv') = inv & wielded <<.~ w
             in inv' & backpack <>~ toVectorOf (wieldedItems . wieldedItem) old
       in [ (Backpack, \item -> backpack %~ (item ^. wieldedItem <|))
-         , (LeftHand, rewield . inLeftHand)
-         , (RightHand, rewield . inRightHand)
-         , (BothHands, rewield . review doubleHanded)
+         , (InHand LeftHand, rewield . inLeftHand)
+         , (InHand RightHand, rewield . inRightHand)
+         , (InHand BothHands, rewield . review doubleHanded)
          ] <&> \(pos, addItem) ->
            testProperty (show pos) $ \inv item ->
              let inv' = addItem item inv
                  inv'' = removeItemFromPosition pos (item ^. wieldedItem) inv'
              in inv'' ^.. items === inv ^.. items
     ]
+  , testGroup "Wielded items"
+    [ testGroup "wieldInHand"
+      [ testProperty "puts the item in the hand" $ \w hand item ->
+          let (_, w') = wieldInHand hand item w
+          in itemsInHand hand w' === [item]
+      , testProperty "returns items in both hands when wielding double-handed"
+        $ \lh rh newItem ->
+          let w = Hands (Just lh) (Just rh)
+              (prevItems, _) = wieldInHand BothHands newItem w
+          in prevItems === [lh, rh]
+      , testProperty "wielding in one hand leaves the item in the other hand"
+        $ \(OneHand h) existingItem newItem ->
+          let (_, w) = wieldInHand h existingItem nothingWielded
+              (prevItems, w') = wieldInHand (otherHand h) newItem w
+          in   prevItems === []
+          .&&. sort (w' ^.. wieldedItems) === sort [existingItem, newItem]
+      , testProperty "always leaves the same items overall" $ \w hand item ->
+          let (prevItems, w') = wieldInHand hand item w
+          in  sort (prevItems <> (w' ^.. wieldedItems))
+          === sort (item : w ^.. wieldedItems)
+      ]
+    ]
   ]