feat(xanthous): Describe *where* the item is in the inventory r/2681

When describing items in the inventory, both in detail and when
producing menus from those items, describe not just the item itself but
also *where* in the inventory the item is (either in the backpack, or
wielded in either or both of the hands). This uses a new
InventoryPosition datatype, and a method to get a list of items in the
inventory associated with their inventory position. When *removing*
items from the inventory (to wield, drop, or eat them), we want to make
sure we remove from the right position, so this also introduces
a `removeItemAtPosition` method to make that happen correctly.

Finally, some of the tests for this stuff was getting really slow - I
narrowed this down to runaway arbitrary generation for message
Templates, so I've tweaked the Arbitrary instance for that type to
generate smaller values.

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

8 files changed, 133 insertions, 23 deletions

diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs
index f43b7e58fc..8c5cffc9f8 100644
--- a/users/grfn/xanthous/src/Xanthous/App.hs
+++ b/users/grfn/xanthous/src/Xanthous/App.hs
@@ -276,8 +276,9 @@ 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
+    $ \(MenuResult (invPos, item)) -> showPanel . ItemDescriptionPanel
+        $ Item.fullDescription item
+        <> "\n\n" <> describeInventoryPosition invPos
   continue
 
 
@@ -425,20 +426,23 @@ selectItemFromInventory
                       --   recoverable fashion. Prism vs iso so we can discard
                       --   items.
   -> AppM ()            -- ^ Action to take if there are no items matching
-  -> (PromptResult ('Menu item) -> AppM ())
+  -> (PromptResult ('Menu (InventoryPosition, item)) -> AppM ())
   -> AppM ()
 selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb = do
   uses (character . inventory)
-       (V.mapMaybe (preview extraInfo) . toVectorOf items)
+       (V.mapMaybe (_2 $ preview extraInfo) . toVectorOf itemsWithPosition)
     >>= \case
       Empty -> onEmpty
       items' -> menu msgPath msgParams cancellable (itemMenu items') cb
   where
     itemMenu = mkMenuItems . map itemMenuItem
-    itemMenuItem extraInfoItem =
+    itemMenuItem (invPos, extraInfoItem) =
       let item = extraInfo # extraInfoItem
       in ( entityMenuChar item
-         , MenuOption (description item) extraInfoItem)
+         , MenuOption
+           (description item <> " (" <> describeInventoryPosition invPos <> ")")
+           (invPos, extraInfoItem)
+         )
 
 -- | Prompt with an item to select out of the inventory and call callback with
 -- it
@@ -450,7 +454,7 @@ selectItemFromInventory_
                       --   recoverable fashion. Prism vs iso so we can discard
                       --   items.
   -> AppM ()            -- ^ Action to take if there are no items matching
-  -> (PromptResult ('Menu item) -> AppM ())
+  -> (PromptResult ('Menu (InventoryPosition, item)) -> AppM ())
   -> AppM ()
 selectItemFromInventory_ msgPath = selectItemFromInventory msgPath ()
 
@@ -470,8 +474,9 @@ takeItemFromInventory
   -> AppM ()
 takeItemFromInventory msgPath msgParams cancellable extraInfo onEmpty cb =
   selectItemFromInventory msgPath msgParams cancellable extraInfo onEmpty
-    $ \(MenuResult item) -> do
-      character . inventory . backpack %= filter (/= (item ^. re extraInfo))
+    $ \(MenuResult (invPos, item)) -> do
+      character . inventory
+        %= removeItemFromPosition invPos (item ^. re extraInfo)
       cb $ MenuResult item
 
 takeItemFromInventory_
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs
index b073f0d071..4d641e46dc 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs
@@ -19,6 +19,11 @@ module Xanthous.Entities.Character
   , backpack
   , wielded
   , items
+  , InventoryPosition(..)
+  , describeInventoryPosition
+  , inventoryPosition
+  , itemsWithPosition
+  , removeItemFromPosition
     -- *** Wielded items
   , Wielded(..)
   , hands
@@ -61,6 +66,8 @@ import           Test.QuickCheck.Instances.Vector ()
 import           Test.QuickCheck.Arbitrary.Generic
 import           Test.QuickCheck.Gen (chooseUpTo)
 import           Test.QuickCheck.Checkers (EqProp)
+import           Control.Monad.State.Lazy (execState)
+import           Control.Monad.Trans.State.Lazy (execStateT)
 --------------------------------------------------------------------------------
 import           Xanthous.Util.QuickCheck
 import           Xanthous.Game.State
@@ -71,10 +78,8 @@ import           Xanthous.Data
                  )
 import           Xanthous.Entities.RawTypes (WieldableItem, wieldable)
 import qualified Xanthous.Entities.RawTypes as Raw
-import           Xanthous.Util (EqEqProp(EqEqProp), modifyKL)
-import Control.Monad.State.Lazy (execState)
-import Control.Monad.Trans.State.Lazy (execStateT)
-import Xanthous.Monad (say_)
+import           Xanthous.Util (EqEqProp(EqEqProp), modifyKL, removeFirst)
+import           Xanthous.Monad (say_)
 --------------------------------------------------------------------------------
 
 data WieldedItem = WieldedItem
@@ -124,19 +129,22 @@ data Wielded
        via WithOptions '[ 'SumEnc 'ObjWithSingleField ]
            Wielded
 
+nothingWielded :: Wielded
+nothingWielded = Hands Nothing Nothing
+
 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
+leftHand :: Traversal' Wielded (Maybe WieldedItem)
+leftHand = hands . _1
 
 inLeftHand :: WieldedItem -> Wielded
 inLeftHand wi = Hands (Just wi) Nothing
 
-rightHand :: Traversal' Wielded WieldedItem
-rightHand = hands . _2 . _Just
+rightHand :: Traversal' Wielded (Maybe WieldedItem)
+rightHand = hands . _2
 
 inRightHand :: WieldedItem -> Wielded
 inRightHand wi = Hands Nothing (Just wi)
@@ -217,6 +225,59 @@ instance Semigroup Inventory where
 instance Monoid Inventory where
   mempty = Inventory mempty $ Hands Nothing Nothing
 
+-- | Representation for where in the inventory an item might be
+data InventoryPosition
+  = Backpack
+  | LeftHand
+  | RightHand
+  | BothHands
+  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"
+
+-- | 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
+
+-- | A fold over all the items in the inventory accompanied by their position in
+-- the inventory
+--
+-- Invariant: This will return items in the same order as 'items'
+itemsWithPosition :: Fold Inventory (InventoryPosition, Item)
+itemsWithPosition = folding $ (<>) <$> backpackItems <*> handItems
+  where
+    backpackItems = toListOf $ backpack . folded . to (Backpack ,)
+    handItems inventory = case inventory ^. wielded of
+       DoubleHanded i -> pure (BothHands, i ^. wieldedItem)
+       Hands l r -> (l ^.. folded . wieldedItem . to (LeftHand ,))
+                 <> (r ^.. folded . wieldedItem . to (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
+  = inv & wielded . leftHand %~ filter ((/= item) . view wieldedItem)
+removeItemFromPosition RightHand item inv
+  = inv & wielded . rightHand %~ filter ((/= item) . view wieldedItem)
+removeItemFromPosition BothHands item inv
+  | has (wielded . doubleHanded . wieldedItem . filtered (== item)) inv
+  = inv & wielded .~ nothingWielded
+  | otherwise
+  = inv
+
 --------------------------------------------------------------------------------
 
 -- | The status of the character's knuckles
diff --git a/users/grfn/xanthous/src/Xanthous/Messages.hs b/users/grfn/xanthous/src/Xanthous/Messages.hs
index 9856941397..c273d65082 100644
--- a/users/grfn/xanthous/src/Xanthous/Messages.hs
+++ b/users/grfn/xanthous/src/Xanthous/Messages.hs
@@ -24,7 +24,6 @@ import           Data.Aeson.Generic.DerivingVia
 import           Data.FileEmbed
 import           Data.List.NonEmpty
 import           Test.QuickCheck hiding (choose)
-import           Test.QuickCheck.Arbitrary.Generic
 import           Test.QuickCheck.Instances.UnorderedContainers ()
 import           Text.Mustache
 import qualified Data.Yaml as Yaml
@@ -41,7 +40,10 @@ data Message = Single Template | Choice (NonEmpty Template)
            Message
 
 instance Arbitrary Message where
-  arbitrary = genericArbitrary
+  arbitrary =
+    frequency [ (10, Single <$> arbitrary)
+              , (1, Choice <$> arbitrary)
+              ]
   shrink = genericShrink
 
 resolve :: MonadRandom m => Message -> m Template
diff --git a/users/grfn/xanthous/src/Xanthous/Orphans.hs b/users/grfn/xanthous/src/Xanthous/Orphans.hs
index 0b282af44c..e9cfddc0e6 100644
--- a/users/grfn/xanthous/src/Xanthous/Orphans.hs
+++ b/users/grfn/xanthous/src/Xanthous/Orphans.hs
@@ -84,9 +84,9 @@ instance Arbitrary Pos where
   shrink (unPos -> x) = mkPos <$> [x..1]
 
 instance Arbitrary Node where
-  arbitrary = sized node
+  arbitrary = scale (`div` 10) $ sized node
     where
-      node n | n > 0 = oneof $ leaves ++ branches (n `div` 2)
+      node n | n > 0 = oneof $ leaves ++ branches (n `div` 4)
       node _ = oneof leaves
       branches n =
         [ Section <$> arbitrary <*> subnodes n
@@ -110,7 +110,7 @@ concatTextBlocks (TextBlock txt₁ : TextBlock txt₂ : xs)
 concatTextBlocks (x : xs) = x : concatTextBlocks xs
 
 instance Arbitrary Template where
-  arbitrary = do
+  arbitrary = scale (`div` 8) $ do
     template <- concatTextBlocks <$> arbitrary
     -- templateName <- arbitrary
     -- rest <- arbitrary
diff --git a/users/grfn/xanthous/src/Xanthous/Util.hs b/users/grfn/xanthous/src/Xanthous/Util.hs
index fea9c07c12..d3e8cdc301 100644
--- a/users/grfn/xanthous/src/Xanthous/Util.hs
+++ b/users/grfn/xanthous/src/Xanthous/Util.hs
@@ -26,6 +26,7 @@ module Xanthous.Util
   , takeWhileInclusive
   , smallestNotIn
   , removeVectorIndex
+  , removeFirst
   , maximum1
   , minimum1
 
@@ -49,6 +50,7 @@ import qualified Data.Vector as V
 import           Data.Semigroup (Max(..), Min(..))
 import           Data.Semigroup.Foldable
 import           Control.Monad.State.Class
+import           Control.Monad.State (evalState)
 --------------------------------------------------------------------------------
 
 newtype EqEqProp a = EqEqProp a
@@ -229,6 +231,16 @@ removeVectorIndex idx vect =
   let (before, after) = V.splitAt idx vect
   in before <> fromMaybe Empty (tailMay after)
 
+-- | Remove the first element in a sequence that matches a given predicate
+removeFirst :: IsSequence seq => (Element seq -> Bool) -> seq -> seq
+removeFirst p
+  = flip evalState False
+  . filterM (\x -> do
+                found <- get
+                let matches = p x
+                when matches $ put True
+                pure $ found || not matches)
+
 maximum1 :: (Ord a, Foldable1 f) => f a -> a
 maximum1 = getMax . foldMap1 Max
 
diff --git a/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs
index 734cce1efb..9210355d2d 100644
--- a/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs
+++ b/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs
@@ -3,6 +3,7 @@
 module Xanthous.Entities.CharacterSpec (main, test) where
 --------------------------------------------------------------------------------
 import           Test.Prelude
+import           Data.Vector.Lens (toVectorOf)
 --------------------------------------------------------------------------------
 import           Xanthous.Entities.Character
 import           Xanthous.Util (endoTimes)
@@ -21,4 +22,21 @@ test = testGroup "Xanthous.Entities.CharacterSpec"
           in _knuckleDamage knuckles' @?= 5
       ]
     ]
+  , testGroup "Inventory"
+    [ testProperty "items === itemsWithPosition . _2" $ \inv ->
+        inv ^.. items === inv ^.. itemsWithPosition . _2
+    , testGroup "removeItemFromPosition" $
+      let rewield w inv =
+            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)
+         ] <&> \(pos, addItem) ->
+           testProperty (show pos) $ \inv item ->
+             let inv' = addItem item inv
+                 inv'' = removeItemFromPosition pos (item ^. wieldedItem) inv'
+             in inv'' ^.. items === inv ^.. items
+    ]
   ]
diff --git a/users/grfn/xanthous/test/Xanthous/MessageSpec.hs b/users/grfn/xanthous/test/Xanthous/MessageSpec.hs
index b681e537ef..2068e338ba 100644
--- a/users/grfn/xanthous/test/Xanthous/MessageSpec.hs
+++ b/users/grfn/xanthous/test/Xanthous/MessageSpec.hs
@@ -38,7 +38,7 @@ test = testGroup "Xanthous.Messages"
           let
             Right tpl = compileMustacheText "foo" "bar"
             msg = Single tpl
-            mm = Nested $ [("foo", Direct msg)]
+            mm = Nested [("foo", Direct msg)]
           in mm ^? ix ["foo"] @?= Just msg
         ]
     , testGroup "lookupMessage"
@@ -50,4 +50,10 @@ test = testGroup "Xanthous.Messages"
   , testGroup "Messages"
     [ testCase "are all valid" $ messages `deepseq` pure ()
     ]
+
+  , testGroup "Template"
+    [ testGroup "eq"
+      [ testProperty "reflexive" $ \(tpl :: Template) -> tpl == tpl
+      ]
+    ]
   ]
diff --git a/users/grfn/xanthous/test/Xanthous/UtilSpec.hs b/users/grfn/xanthous/test/Xanthous/UtilSpec.hs
index 01e8e402c5..0d6b718bc3 100644
--- a/users/grfn/xanthous/test/Xanthous/UtilSpec.hs
+++ b/users/grfn/xanthous/test/Xanthous/UtilSpec.hs
@@ -34,4 +34,10 @@ test = testGroup "Xanthous.Util"
     [ testCase "_1 += 1"
       $ execState (modifyKL _1 $ pure . succ) (1 :: Int, 2 :: Int) @?= (2, 2)
     ]
+  , testGroup "removeFirst"
+    [ testCase "example" $
+      removeFirst @[Int] (> 5) [1..10] @?= [1, 2, 3, 4, 5, 7, 8, 9, 10]
+    , testProperty "the result is the right length" $ \(xs :: [Int]) p ->
+        length (removeFirst p xs) `elem` [length xs, length xs - 1]
+    ]
   ]