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:
parent
f0c167d361
commit
76258fbfa1
8 changed files with 133 additions and 23 deletions
|
@ -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_
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
]
|
||||
]
|
||||
|
|
|
@ -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
|
||||
]
|
||||
]
|
||||
]
|
||||
|
|
|
@ -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]
|
||||
]
|
||||
]
|
||||
|
|
Loading…
Reference in a new issue