From 5b1c7799a76480335f838356ad78bed50715d4c0 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sun, 22 Dec 2019 22:46:43 -0500 Subject: Add wielded, wieldable items Split the character's inventory up into wielded items (in one or both hands) and the backpack, and display wielded items when drawing the inventory panel. Currently there's no way to actually *wield* items though, so this is all unused/untested. Also, add the ability for items to be "wieldable", which gives specific descriptions for when attacking with them and also modified damage. --- src/Xanthous/App.hs | 21 ++--- src/Xanthous/Command.hs | 4 +- src/Xanthous/Entities/Character.hs | 157 +++++++++++++++++++++++++++++++++- src/Xanthous/Entities/Creature.hs | 3 +- src/Xanthous/Entities/RawTypes.hs | 67 +++++++++++---- src/Xanthous/Entities/Raws/stick.yaml | 14 +++ src/Xanthous/Game/Draw.hs | 41 ++++++--- src/Xanthous/messages.yaml | 8 +- 8 files changed, 268 insertions(+), 47 deletions(-) create mode 100644 src/Xanthous/Entities/Raws/stick.yaml (limited to 'src/Xanthous') diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index f663186a30..c7d9e3935e 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -143,8 +143,8 @@ handleCommand PickUp = do uses entities (entitiesAtPositionWithType @Item pos) >>= \case [] -> say_ ["pickUp", "nothingToPickUp"] [item] -> pickUpItem item - items -> - menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items) + items' -> + menu_ ["pickUp", "menu"] Cancellable (entityMenu_ items') $ \(MenuResult item) -> pickUpItem item continue where @@ -185,7 +185,7 @@ handleCommand Look = do handleCommand Wait = stepGame >> continue handleCommand Eat = do - uses (character . inventory) + uses (character . inventory . backpack) (V.mapMaybe (\item -> (item,) <$> item ^. Item.itemType . edible)) >>= \case Empty -> say_ ["eat", "noFood"] @@ -197,7 +197,7 @@ handleCommand Eat = do menuItems = mkMenuItems $ imap foodMenuItem food in menu_ ["eat", "menuPrompt"] Cancellable menuItems $ \(MenuResult (idx, item, edibleItem)) -> do - character . inventory %= \inv -> + character . inventory . backpack %= \inv -> let (before, after) = V.splitAt idx inv in before <> fromMaybe Empty (tailMay after) let msg = fromMaybe (Messages.lookup ["eat", "eat"]) @@ -231,7 +231,7 @@ handleCommand Read = do in readAndContinue msgs continue -handleCommand Inventory = showPanel InventoryPanel >> continue +handleCommand ShowInventory = showPanel InventoryPanel >> continue handleCommand Save = do -- TODO default save locations / config file? @@ -280,8 +280,8 @@ handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue handlePromptEvent _ (Prompt _ SContinue _ _ _) _ = continue -handlePromptEvent _ (Prompt _ SMenu _ items cb) (VtyEvent (EvKey (KChar chr) [])) - | Just (MenuOption _ res) <- items ^. at chr +handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) [])) + | Just (MenuOption _ res) <- items' ^. at chr = cb (MenuResult res) >> clearPrompt | otherwise = continue @@ -350,9 +350,9 @@ menu :: forall (a :: Type) (params :: Type). -> Map Char (MenuOption a) -- ^ Menu items -> (PromptResult ('Menu a) -> AppM ()) -- ^ Menu promise handler -> AppM () -menu msgPath params cancellable items cb = do +menu msgPath params cancellable items' cb = do msg <- Messages.message msgPath params - let p = mkMenu cancellable items cb + let p = mkMenu cancellable items' cb promptState .= WaitingPrompt msg p menu_ :: forall (a :: Type). @@ -419,7 +419,8 @@ attackAt pos = say ["combat", "killed"] msgParams entities . at creatureID .= Nothing else do - say ["combat", "hit"] msgParams + -- TODO attack messages + say ["combat", "hit", "generic"] msgParams entities . ix creatureID . positioned .= SomeEntity creature' stepGame -- TODO diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs index a14a4d0713..7b689c6466 100644 --- a/src/Xanthous/Command.hs +++ b/src/Xanthous/Command.hs @@ -20,7 +20,7 @@ data Command | Look | Save | Read - | Inventory + | ShowInventory -- | TODO replace with `:` commands | ToggleRevealAll @@ -36,7 +36,7 @@ commandFromKey (KChar ';') [] = Just Look commandFromKey (KChar 'e') [] = Just Eat commandFromKey (KChar 'S') [] = Just Save commandFromKey (KChar 'r') [] = Just Read -commandFromKey (KChar 'i') [] = Just Inventory +commandFromKey (KChar 'i') [] = Just ShowInventory commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs index dd14390df9..5ddf33c294 100644 --- a/src/Xanthous/Entities/Character.hs +++ b/src/Xanthous/Entities/Character.hs @@ -10,6 +10,22 @@ module Xanthous.Entities.Character , hitpointRecoveryRate , speed + -- * Inventory + , Inventory(..) + , backpack + , wielded + , items + -- ** Wielded items + , Wielded(..) + , hands + , leftHand + , rightHand + , doubleHanded + , wieldedItems + , WieldedItem(..) + , wieldedItem + , wieldableItem + -- * , mkCharacter , pickUpItem @@ -27,13 +43,148 @@ import Data.Aeson.Generic.DerivingVia import Data.Aeson (ToJSON, FromJSON) import Data.Coerce (coerce) -------------------------------------------------------------------------------- +import Xanthous.Util.QuickCheck import Xanthous.Game.State import Xanthous.Entities.Item -import Xanthous.Data (TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned) +import Xanthous.Data + (TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned, Positioned(..)) +import Xanthous.Entities.RawTypes (WieldableItem, wieldable) +-------------------------------------------------------------------------------- + +data WieldedItem = WieldedItem + { _wieldedItem :: Item + , _wieldableItem :: WieldableItem + -- ^ Invariant: item ^. itemType . wieldable ≡ Just wieldableItem + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + WieldedItem +makeFieldsNoPrefix ''WieldedItem + +instance Brain WieldedItem where + step ticks (Positioned p wi) = + over positioned (\i -> WieldedItem i $ wi ^. wieldableItem) + <$> step ticks (Positioned p $ wi ^. wieldedItem) + +instance Draw WieldedItem where + draw = draw . view wieldedItem + +instance Entity WieldedItem where + blocksVision = blocksVision . view wieldedItem + description = description . view wieldedItem + entityChar = entityChar . view wieldedItem + +instance Arbitrary WieldedItem where + arbitrary = genericArbitrary <&> \wi -> + wi & wieldedItem . itemType . wieldable ?~ wi ^. wieldableItem + +data Wielded + = DoubleHanded WieldedItem + | Hands { _leftHand :: !(Maybe WieldedItem) + , _rightHand :: !(Maybe WieldedItem) + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Wielded + deriving (ToJSON, FromJSON) + via WithOptions '[ 'SumEnc 'ObjWithSingleField ] + Wielded + +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 + +rightHand :: Traversal' Wielded WieldedItem +rightHand = hands . _2 . _Just + +doubleHanded :: Prism' Wielded WieldedItem +doubleHanded = prism' DoubleHanded $ \case + DoubleHanded i -> Just i + _ -> Nothing + +wieldedItems :: Traversal' Wielded Item +wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> wieldedItem k wielded +wieldedItems k (Hands l r) = Hands + <$> (_Just . wieldedItem) k l + <*> (_Just . wieldedItem) k r + +data Inventory = Inventory + { _backpack :: Vector Item + , _wielded :: Wielded + } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary Inventory + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Inventory +makeFieldsNoPrefix ''Inventory + +items :: Traversal' Inventory Item +items k (Inventory bp w) = Inventory + <$> traversed k bp + <*> wieldedItems k w + +type instance Element Inventory = Item + +instance MonoFunctor Inventory where + omap = over items + +instance MonoFoldable Inventory where + ofoldMap = foldMapOf items + ofoldr = foldrOf items + ofoldl' = foldlOf' items + otoList = toListOf items + oall = allOf items + oany = anyOf items + onull = nullOf items + ofoldr1Ex = foldr1Of items + ofoldl1Ex' = foldl1Of' items + headEx = headEx . toListOf items + lastEx = lastEx . toListOf items + +instance MonoTraversable Inventory where + otraverse = traverseOf items + +instance Semigroup Inventory where + inv₁ <> inv₂ = + let backpack' = inv₁ ^. backpack <> inv₂ ^. backpack + (wielded', backpack'') = case (inv₁ ^. wielded, inv₂ ^. wielded) of + (wielded₁, wielded₂@(DoubleHanded _)) -> + (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems)) + (wielded₁, wielded₂@(Hands (Just _) (Just _))) -> + (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems)) + (wielded₁, Hands Nothing Nothing) -> (wielded₁, backpack') + (Hands Nothing Nothing, wielded₂) -> (wielded₂, backpack') + (Hands (Just l₁) Nothing, Hands Nothing (Just r₂)) -> + (Hands (Just l₁) (Just r₂), backpack') + (wielded₁@(DoubleHanded _), wielded₂) -> + (wielded₁, backpack' <> fromList (wielded₂ ^.. wieldedItems)) + (Hands Nothing (Just r₁), Hands Nothing (Just r₂)) -> + (Hands Nothing (Just r₂), r₁ ^. wieldedItem <| backpack') + (Hands Nothing r₁, Hands (Just l₂) Nothing) -> + (Hands (Just l₂) r₁, backpack') + (Hands (Just l₁) Nothing, Hands (Just l₂) Nothing) -> + (Hands (Just l₂) Nothing, l₁ ^. wieldedItem <| backpack') + (Hands (Just l₁) (Just r₁), Hands Nothing (Just r₂)) -> + (Hands (Just l₁) (Just r₂), r₁ ^. wieldedItem <| backpack') + (Hands (Just l₁) (Just r₁), Hands (Just l₂) Nothing) -> + (Hands (Just l₂) (Just r₁), l₁ ^. wieldedItem <| backpack') + in Inventory backpack'' wielded' + +instance Monoid Inventory where + mempty = Inventory mempty $ Hands Nothing Nothing + -------------------------------------------------------------------------------- data Character = Character - { _inventory :: !(Vector Item) + { _inventory :: !Inventory , _characterName :: !(Maybe Text) , _characterDamage :: !Hitpoints , _characterHitpoints' :: !Double @@ -95,7 +246,7 @@ isDead :: Character -> Bool isDead = (== 0) . characterHitpoints pickUpItem :: Item -> Character -> Character -pickUpItem item = inventory %~ (item <|) +pickUpItem it = inventory . backpack %~ (it <|) damage :: Hitpoints -> Character -> Character damage (fromIntegral -> amount) = characterHitpoints' %~ \case diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs index 6f97c128d2..19c7834228 100644 --- a/src/Xanthous/Entities/Creature.hs +++ b/src/Xanthous/Entities/Creature.hs @@ -34,7 +34,8 @@ import Test.QuickCheck.Arbitrary.Generic import Data.Aeson.Generic.DerivingVia import Data.Aeson (ToJSON, FromJSON) -------------------------------------------------------------------------------- -import Xanthous.Entities.RawTypes hiding (Creature, description) +import Xanthous.Entities.RawTypes + hiding (Creature, description, damage) import Xanthous.Game.State import Xanthous.Data -------------------------------------------------------------------------------- diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs index 822b93f2df..4b31524ad7 100644 --- a/src/Xanthous/Entities/RawTypes.hs +++ b/src/Xanthous/Entities/RawTypes.hs @@ -2,36 +2,51 @@ {-# LANGUAGE DuplicateRecordFields #-} -------------------------------------------------------------------------------- module Xanthous.Entities.RawTypes - ( CreatureType(..) - , EdibleItem(..) + ( + EntityRaw(..) + , _Creature + , _Item + + -- * Creatures + , CreatureType(..) + + -- * Items , ItemType(..) + -- ** Item sub-types + -- *** Edible + , EdibleItem(..) , isEdible - , EntityRaw(..) + -- *** Wieldable + , WieldableItem(..) + , isWieldable - , _Creature -- * Lens classes + , HasAttackMessage(..) , HasChar(..) - , HasName(..) + , HasDamage(..) , HasDescription(..) - , HasLongDescription(..) - , HasMaxHitpoints(..) - , HasFriendly(..) , HasEatMessage(..) - , HasHitpointsHealed(..) , HasEdible(..) + , HasFriendly(..) + , HasHitpointsHealed(..) + , HasLongDescription(..) + , HasMaxHitpoints(..) + , HasName(..) , HasSpeed(..) + , HasWieldable(..) ) where -------------------------------------------------------------------------------- import Xanthous.Prelude import Test.QuickCheck -import Test.QuickCheck.Arbitrary.Generic import Data.Aeson.Generic.DerivingVia import Data.Aeson (ToJSON, FromJSON) -------------------------------------------------------------------------------- import Xanthous.Messages (Message(..)) import Xanthous.Data (TicksPerTile, Hitpoints) import Xanthous.Data.EntityChar +import Xanthous.Util.QuickCheck -------------------------------------------------------------------------------- + data CreatureType = CreatureType { _name :: !Text , _description :: !Text @@ -42,14 +57,12 @@ data CreatureType = CreatureType } deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary CreatureType deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] CreatureType makeFieldsNoPrefix ''CreatureType -instance Arbitrary CreatureType where - arbitrary = genericArbitrary - -------------------------------------------------------------------------------- data EdibleItem = EdibleItem @@ -58,13 +71,25 @@ data EdibleItem = EdibleItem } deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary EdibleItem deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] EdibleItem makeFieldsNoPrefix ''EdibleItem -instance Arbitrary EdibleItem where - arbitrary = genericArbitrary +data WieldableItem = WieldableItem + { _damage :: !Hitpoints + , _attackMessage :: !(Maybe Message) + } + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary WieldableItem + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + WieldableItem +makeFieldsNoPrefix ''WieldableItem + +-------------------------------------------------------------------------------- data ItemType = ItemType { _name :: Text @@ -72,20 +97,24 @@ data ItemType = ItemType , _longDescription :: Text , _char :: EntityChar , _edible :: Maybe EdibleItem + , _wieldable :: Maybe WieldableItem } deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary ItemType deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] ItemType makeFieldsNoPrefix ''ItemType -instance Arbitrary ItemType where - arbitrary = genericArbitrary - +-- | Can this item be eaten? isEdible :: ItemType -> Bool isEdible = has $ edible . _Just +-- | Can this item be used as a weapon? +isWieldable :: ItemType -> Bool +isWieldable = has $ wieldable . _Just + -------------------------------------------------------------------------------- data EntityRaw @@ -93,9 +122,9 @@ data EntityRaw | Item ItemType deriving stock (Show, Eq, Generic) deriving anyclass (NFData) + deriving Arbitrary via GenericArbitrary EntityRaw deriving (FromJSON) via WithOptions '[ SumEnc ObjWithSingleField ] EntityRaw makePrisms ''EntityRaw -{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-} diff --git a/src/Xanthous/Entities/Raws/stick.yaml b/src/Xanthous/Entities/Raws/stick.yaml new file mode 100644 index 0000000000..bc7fde4d8b --- /dev/null +++ b/src/Xanthous/Entities/Raws/stick.yaml @@ -0,0 +1,14 @@ +Item: + name: stick + description: a wooden stick + longDescription: A sturdy branch broken off from some sort of tree + char: + char: ∤ + style: + foreground: yellow + wieldable: + damage: 2 + attackMessage: + - You bonk the {{creature.creatureType.name}} over the head with your stick. + - You bash the {{creature.creatureType.name}} on the noggin with your stick. + - You whack the {{creature.creatureType.name}} with your stick. diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index e2390c47bf..09015d0688 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -14,6 +14,7 @@ import Xanthous.Data.EntityMap (EntityMap, atPosition) import qualified Xanthous.Data.EntityMap as EntityMap import Xanthous.Game.State import Xanthous.Entities.Character +import Xanthous.Entities.Item (Item) import Xanthous.Game ( GameState(..) , entities @@ -105,16 +106,36 @@ drawPanel game panel . viewport (Resource.Panel panel) Vertical $ case panel of InventoryPanel -> - let items = game ^. character . inventory - in if null items - then txtWrap "Your inventory is empty right now." - else - txtWrap "You are currently carrying the following items:" - <=> txt " " - <=> foldl' (<=>) emptyWidget - (map - (txtWrap . ((bullet <| " ") <>) . description) - items) + drawWielded (game ^. character . inventory . wielded) + <=> drawBackpack (game ^. character . inventory . backpack) + where + drawWielded :: Wielded -> Widget Name + drawWielded (Hands Nothing Nothing) = emptyWidget + drawWielded (DoubleHanded i) = + txt $ "You are holding " <> description i <> " in both hands" + drawWielded (Hands l r) = + maybe + emptyWidget + (\i -> + txt $ "You are holding " <> description i <> " in your left hand") + l + <=> + maybe + emptyWidget + (\i -> + txt $ "You are holding " <> description i <> " in your right hand") + r + + drawBackpack :: Vector Item -> Widget Name + drawBackpack Empty = txtWrap "Your backpack is empty right now." + drawBackpack backpackItems + = txtWrap ( "You are currently carrying the following items in your " + <> "backpack:") + <=> txt " " + <=> foldl' (<=>) emptyWidget + (map + (txtWrap . ((bullet <| " ") <>) . description) + backpackItems) drawCharacterInfo :: Character -> Widget Name drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml index 40a37cf59b..0d8ada8c57 100644 --- a/src/Xanthous/messages.yaml +++ b/src/Xanthous/messages.yaml @@ -37,8 +37,12 @@ combat: nothingToAttack: There's nothing to attack there. menu: Which creature would you like to attack? hit: - - You hit the {{creature.creatureType.name}}. - - You attack the {{creature.creatureType.name}}. + fists: + - You punch the {{creature.creatureType.name}} with your bare fists! It hurts. A lot. + - You strike the {{creature.creatureType.name}} with your bare fists! It leaves a bit of a bruise on your knuckles. + generic: + - You hit the {{creature.creatureType.name}}. + - You attack the {{creature.creatureType.name}}. creatureAttack: - The {{creature.creatureType.name}} hits you! - The {{creature.creatureType.name}} attacks you! -- cgit 1.4.1