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

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
This commit is contained in:
Griffin Smith 2021-06-20 15:35:08 -04:00 committed by grfn
parent f0c167d361
commit 76258fbfa1
8 changed files with 133 additions and 23 deletions

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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