diff options
Diffstat (limited to 'users/grfn/xanthous/src')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/App.hs | 23 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Entities/Character.hs | 77 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Messages.hs | 6 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Orphans.hs | 6 | ||||
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Util.hs | 12 |
5 files changed, 102 insertions, 22 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 |