diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index f663186a3..c7d9e3935 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 a14a4d071..7b689c646 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 dd14390df..5ddf33c29 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 6f97c128d..19c783422 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 822b93f2d..4b31524ad 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(..) - , ItemType(..) - , isEdible - , EntityRaw(..) - + ( + EntityRaw(..) , _Creature + , _Item + + -- * Creatures + , CreatureType(..) + + -- * Items + , ItemType(..) + -- ** Item sub-types + -- *** Edible + , EdibleItem(..) + , isEdible + -- *** Wieldable + , WieldableItem(..) + , isWieldable + -- * Lens classes + , HasAttackMessage(..) , HasChar(..) - , HasName(..) + , HasDamage(..) , HasDescription(..) + , HasEatMessage(..) + , HasEdible(..) + , HasFriendly(..) + , HasHitpointsHealed(..) , HasLongDescription(..) , HasMaxHitpoints(..) - , HasFriendly(..) - , HasEatMessage(..) - , HasHitpointsHealed(..) - , HasEdible(..) + , 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 000000000..bc7fde4d8 --- /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 e2390c47b..09015d068 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 40a37cf59..0d8ada8c5 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!