From 76258fbfa1fc04c3ef3ecdb539c6dc48dc4131a5 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sun, 20 Jun 2021 15:35:08 -0400 Subject: 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 Tested-by: BuildkiteCI --- users/grfn/xanthous/src/Xanthous/App.hs | 23 ++++--- .../xanthous/src/Xanthous/Entities/Character.hs | 77 +++++++++++++++++++--- users/grfn/xanthous/src/Xanthous/Messages.hs | 6 +- users/grfn/xanthous/src/Xanthous/Orphans.hs | 6 +- users/grfn/xanthous/src/Xanthous/Util.hs | 12 ++++ .../test/Xanthous/Entities/CharacterSpec.hs | 18 +++++ users/grfn/xanthous/test/Xanthous/MessageSpec.hs | 8 ++- users/grfn/xanthous/test/Xanthous/UtilSpec.hs | 6 ++ 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 f43b7e58fc91..8c5cffc9f859 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 b073f0d0719b..4d641e46dc48 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 985694139783..c273d650821b 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 0b282af44ca0..e9cfddc0e69c 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 fea9c07c124d..d3e8cdc30138 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 734cce1efbbe..9210355d2dbb 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 b681e537efe6..2068e338bafe 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 01e8e402c54f..0d6b718bc351 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] + ] ] -- cgit 1.4.1