refactor(gs/xanthous): Break out inventory into a common module
Creatures are going to have an inventory too now in addition to characters, so all the data types and lenses and stuff that define inventory need to be broken out into a separate module so the Creature entity can use them. Change-Id: I83f1c70d316afaaf2e75901f9dc28f79fd2cd31f Reviewed-on: https://cl.tvl.fyi/c/depot/+/3901 Tested-by: BuildkiteCI Reviewed-by: grfn <grfn@gws.fyi>
This commit is contained in:
Griffin Smith
grfn
parent
3a01398672
commit
95ee86225b
8 changed files with 293 additions and 247 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
245
users/grfn/xanthous/src/Xanthous/Entities/Common.hs
Normal file
245
users/grfn/xanthous/src/Xanthous/Entities/Common.hs
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
]
|
||||
]
|
||||
|
|
|
|||
32
users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs
Normal file
32
users/grfn/xanthous/test/Xanthous/Entities/CommonSpec.hs
Normal file
|
|
@ -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
|
||||
]
|
||||
]
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue