about summary refs log tree commit diff
path: root/users/grfn/xanthous/src/Xanthous/Entities/Common.hs
blob: 1444f3ce1639bff0690e21a80ac85aa62d5301b2 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
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