about summary refs log tree commit diff
path: root/users
diff options
context:
space:
mode:
Diffstat (limited to 'users')
-rw-r--r--users/grfn/xanthous/src/Xanthous/App.hs6
-rw-r--r--users/grfn/xanthous/src/Xanthous/Entities/Character.hs230
-rw-r--r--users/grfn/xanthous/src/Xanthous/Entities/Common.hs245
-rw-r--r--users/grfn/xanthous/src/Xanthous/Game/Draw.hs1
-rw-r--r--users/grfn/xanthous/test/Spec.hs2
-rw-r--r--users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs18
-rw-r--r--users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs32
-rw-r--r--users/grfn/xanthous/xanthous.cabal6
8 files changed, 293 insertions, 247 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs
index 78f9e76775d9..b29614383bcd 100644
--- a/users/grfn/xanthous/src/Xanthous/App.hs
+++ b/users/grfn/xanthous/src/Xanthous/App.hs
@@ -54,6 +54,12 @@ import           Xanthous.Physics (throwDistance, bluntThrowDamage)
 import           Xanthous.Data.EntityMap.Graphics (lineOfSight)
 import           Xanthous.Data.EntityMap (EntityID)
 --------------------------------------------------------------------------------
+import           Xanthous.Entities.Common
+                 ( InventoryPosition, describeInventoryPosition, backpack
+                 , wieldableItem, wieldedItems, wielded, itemsWithPosition
+                 , removeItemFromPosition, asWieldedItem, inRightHand
+                 , wieldedItem
+                 )
 import qualified Xanthous.Entities.Character as Character
 import           Xanthous.Entities.Character hiding (pickUpItem)
 import           Xanthous.Entities.Item (Item, weight)
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs
index 4d641e46dc48..b86e9e17d3f9 100644
--- a/users/grfn/xanthous/src/Xanthous/Entities/Character.hs
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Character.hs
@@ -14,30 +14,6 @@ module Xanthous.Entities.Character
   , speed
   , body
 
-    -- ** Inventory
-  , Inventory(..)
-  , backpack
-  , wielded
-  , items
-  , InventoryPosition(..)
-  , describeInventoryPosition
-  , inventoryPosition
-  , itemsWithPosition
-  , removeItemFromPosition
-    -- *** Wielded items
-  , Wielded(..)
-  , hands
-  , leftHand
-  , rightHand
-  , inLeftHand
-  , inRightHand
-  , doubleHanded
-  , wieldedItems
-  , WieldedItem(..)
-  , wieldedItem
-  , wieldableItem
-  , asWieldedItem
-
     -- *** Body
   , Body(..)
   , initialBody
@@ -72,214 +48,14 @@ import           Control.Monad.Trans.State.Lazy (execStateT)
 import           Xanthous.Util.QuickCheck
 import           Xanthous.Game.State
 import           Xanthous.Entities.Item
+import           Xanthous.Entities.Common
 import           Xanthous.Data
-                 ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned
-                 , Positioned(..)
-                 )
-import           Xanthous.Entities.RawTypes (WieldableItem, wieldable)
+                 ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned )
 import qualified Xanthous.Entities.RawTypes as Raw
-import           Xanthous.Util (EqEqProp(EqEqProp), modifyKL, removeFirst)
+import           Xanthous.Util (EqEqProp(EqEqProp), modifyKL)
 import           Xanthous.Monad (say_)
 --------------------------------------------------------------------------------
 
-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
-
-asWieldedItem :: Prism' Item WieldedItem
-asWieldedItem = prism' hither yon
- where
-   yon item = WieldedItem item <$> item ^. itemType . wieldable
-   hither (WieldedItem item _) = item
-
-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
-  entityAttributes = entityAttributes . 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
-
-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 (Maybe WieldedItem)
-leftHand = hands . _1
-
-inLeftHand :: WieldedItem -> Wielded
-inLeftHand wi = Hands (Just wi) Nothing
-
-rightHand :: Traversal' Wielded (Maybe WieldedItem)
-rightHand = hands . _2
-
-inRightHand :: WieldedItem -> Wielded
-inRightHand wi = Hands Nothing (Just wi)
-
-doubleHanded :: Prism' Wielded WieldedItem
-doubleHanded = prism' DoubleHanded $ \case
-  DoubleHanded i -> Just i
-  _ -> Nothing
-
-wieldedItems :: Traversal' Wielded WieldedItem
-wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> k wielded
-wieldedItems k (Hands l r) = Hands <$> _Just k l <*> _Just 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 . wieldedItem) 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 . wieldedItem))
-          (wielded₁, wielded₂@(Hands (Just _) (Just _))) ->
-            (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem))
-          (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 . wieldedItem))
-          (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
-
--- | 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
 --
 -- This struct is used to track the damage and then eventual build-up of
diff --git a/users/grfn/xanthous/src/Xanthous/Entities/Common.hs b/users/grfn/xanthous/src/Xanthous/Entities/Common.hs
new file mode 100644
index 000000000000..1444f3ce1639
--- /dev/null
+++ b/users/grfn/xanthous/src/Xanthous/Entities/Common.hs
@@ -0,0 +1,245 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      : Xanthous.Entities.Common
+-- Description : Common data type definitions and utilities for entities
+--
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Common
+  ( -- * Inventory
+    Inventory(..)
+  , backpack
+  , wielded
+  , items
+  , InventoryPosition(..)
+  , describeInventoryPosition
+  , inventoryPosition
+  , itemsWithPosition
+  , removeItemFromPosition
+
+    -- ** Wielded items
+  , Wielded(..)
+  , hands
+  , leftHand
+  , rightHand
+  , inLeftHand
+  , inRightHand
+  , doubleHanded
+  , wieldedItems
+  , WieldedItem(..)
+  , wieldedItem
+  , wieldableItem
+  , asWieldedItem
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Aeson.Generic.DerivingVia
+import           Test.QuickCheck
+import           Test.QuickCheck.Checkers (EqProp)
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Positioned(..), positioned)
+import           Xanthous.Util.QuickCheck
+import           Xanthous.Game.State
+import           Xanthous.Entities.Item
+import           Xanthous.Entities.RawTypes (WieldableItem, wieldable)
+import           Xanthous.Util (removeFirst, EqEqProp(..))
+--------------------------------------------------------------------------------
+
+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
+
+asWieldedItem :: Prism' Item WieldedItem
+asWieldedItem = prism' hither yon
+ where
+   yon item = WieldedItem item <$> item ^. itemType . wieldable
+   hither (WieldedItem item _) = item
+
+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
+  entityAttributes = entityAttributes . 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
+
+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 (Maybe WieldedItem)
+leftHand = hands . _1
+
+inLeftHand :: WieldedItem -> Wielded
+inLeftHand wi = Hands (Just wi) Nothing
+
+rightHand :: Traversal' Wielded (Maybe WieldedItem)
+rightHand = hands . _2
+
+inRightHand :: WieldedItem -> Wielded
+inRightHand wi = Hands Nothing (Just wi)
+
+doubleHanded :: Prism' Wielded WieldedItem
+doubleHanded = prism' DoubleHanded $ \case
+  DoubleHanded i -> Just i
+  _ -> Nothing
+
+wieldedItems :: Traversal' Wielded WieldedItem
+wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> k wielded
+wieldedItems k (Hands l r) = Hands <$> _Just k l <*> _Just 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 EqProp via EqEqProp 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 . wieldedItem) 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 . wieldedItem))
+          (wielded₁, wielded₂@(Hands (Just _) (Just _))) ->
+            (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem))
+          (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 . wieldedItem))
+          (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
+
+-- | 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
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs
index 5b51ca67292b..53ea1c96f8af 100644
--- a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs
+++ b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs
@@ -17,6 +17,7 @@ import           Xanthous.Data.App (ResourceName, Panel(..))
 import qualified Xanthous.Data.App as Resource
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Game.State
+import           Xanthous.Entities.Common (Wielded(..), wielded, backpack)
 import           Xanthous.Entities.Character
 import           Xanthous.Entities.Item (Item)
 import           Xanthous.Game
diff --git a/users/grfn/xanthous/test/Spec.hs b/users/grfn/xanthous/test/Spec.hs
index 80826053866a..64c10cf21e20 100644
--- a/users/grfn/xanthous/test/Spec.hs
+++ b/users/grfn/xanthous/test/Spec.hs
@@ -9,6 +9,7 @@ import qualified Xanthous.Data.LevelsSpec
 import qualified Xanthous.Data.MemoSpec
 import qualified Xanthous.Data.NestedMapSpec
 import qualified Xanthous.DataSpec
+import qualified Xanthous.Entities.CommonSpec
 import qualified Xanthous.Entities.RawsSpec
 import qualified Xanthous.Entities.RawTypesSpec
 import qualified Xanthous.Entities.CharacterSpec
@@ -38,6 +39,7 @@ test = testGroup "Xanthous"
   , Xanthous.Data.MemoSpec.test
   , Xanthous.Data.NestedMapSpec.test
   , Xanthous.DataSpec.test
+  , Xanthous.Entities.CommonSpec.test
   , Xanthous.Entities.RawsSpec.test
   , Xanthous.Entities.CharacterSpec.test
   , Xanthous.Entities.RawTypesSpec.test
diff --git a/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs
index 9210355d2dbb..734cce1efbbe 100644
--- a/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs
+++ b/users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs
@@ -3,7 +3,6 @@
 module Xanthous.Entities.CharacterSpec (main, test) where
 --------------------------------------------------------------------------------
 import           Test.Prelude
-import           Data.Vector.Lens (toVectorOf)
 --------------------------------------------------------------------------------
 import           Xanthous.Entities.Character
 import           Xanthous.Util (endoTimes)
@@ -22,21 +21,4 @@ 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/Entities/CommonSpec.hs b/users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs
new file mode 100644
index 000000000000..ba27e3cbca4e
--- /dev/null
+++ b/users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs
@@ -0,0 +1,32 @@
+--------------------------------------------------------------------------------
+module Xanthous.Entities.CommonSpec (main, test) where
+--------------------------------------------------------------------------------
+import           Test.Prelude
+import           Data.Vector.Lens (toVectorOf)
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.Common
+--------------------------------------------------------------------------------
+
+main :: IO ()
+main = defaultMain test
+
+test :: TestTree
+test = testGroup "Xanthous.Entities.CommonSpec"
+  [ 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/xanthous.cabal b/users/grfn/xanthous/xanthous.cabal
index e23f3968ee44..987e1f48f693 100644
--- a/users/grfn/xanthous/xanthous.cabal
+++ b/users/grfn/xanthous/xanthous.cabal
@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.34.4.
+-- This file has been generated from package.yaml by hpack version 0.34.5.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 96c5446afd429c3e2166158e317c18a69be9bad8ce76de85f69abda4f9aa162c
+-- hash: 8cae8550487b6092c18c82a0dc29bf22980d416771c66f6fca3e151875c66495
 
 name:           xanthous
 version:        0.1.0.0
@@ -47,6 +47,7 @@ library
       Xanthous.Data.NestedMap
       Xanthous.Data.VectorBag
       Xanthous.Entities.Character
+      Xanthous.Entities.Common
       Xanthous.Entities.Creature
       Xanthous.Entities.Creature.Hippocampus
       Xanthous.Entities.Draw.Util
@@ -301,6 +302,7 @@ test-suite test
       Xanthous.Data.NestedMapSpec
       Xanthous.DataSpec
       Xanthous.Entities.CharacterSpec
+      Xanthous.Entities.CommonSpec
       Xanthous.Entities.RawsSpec
       Xanthous.Entities.RawTypesSpec
       Xanthous.Game.PromptSpec
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-05T19·10+0000