about summary refs log tree commit diff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Xanthous/App.hs21
-rw-r--r--src/Xanthous/Command.hs4
-rw-r--r--src/Xanthous/Entities/Character.hs157
-rw-r--r--src/Xanthous/Entities/Creature.hs3
-rw-r--r--src/Xanthous/Entities/RawTypes.hs67
-rw-r--r--src/Xanthous/Entities/Raws/stick.yaml14
-rw-r--r--src/Xanthous/Game/Draw.hs41
-rw-r--r--src/Xanthous/messages.yaml8
8 files changed, 268 insertions, 47 deletions
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!
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-07-09T05·00+0000