diff options
Diffstat (limited to '')
-rw-r--r-- | users/grfn/xanthous/src/Xanthous/App.hs | 6 | ||||
-rw-r--r-- | users/grfn/xanthous/src/Xanthous/Entities/Character.hs | 230 | ||||
-rw-r--r-- | users/grfn/xanthous/src/Xanthous/Entities/Common.hs | 245 | ||||
-rw-r--r-- | users/grfn/xanthous/src/Xanthous/Game/Draw.hs | 1 | ||||
-rw-r--r-- | users/grfn/xanthous/test/Spec.hs | 2 | ||||
-rw-r--r-- | users/grfn/xanthous/test/Xanthous/Entities/CharacterSpec.hs | 18 | ||||
-rw-r--r-- | users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs | 32 | ||||
-rw-r--r-- | users/grfn/xanthous/xanthous.cabal | 6 |
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 |