about summary refs log tree commit diff
path: root/users/grfn/xanthous/src/Xanthous/Entities/Character.hs
blob: f27ed1e475d602ce8a9cf86cc07414b83f4493c9 (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
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
{-# LANGUAGE TemplateHaskell #-}
module Xanthous.Entities.Character
  ( Character(..)
  , characterName
  , inventory
  , characterDamage
  , characterHitpoints'
  , characterHitpoints
  , hitpointRecoveryRate
  , speed

    -- * Inventory
  , Inventory(..)
  , backpack
  , wielded
  , items
    -- ** Wielded items
  , Wielded(..)
  , hands
  , leftHand
  , rightHand
  , inLeftHand
  , inRightHand
  , doubleHanded
  , wieldedItems
  , WieldedItem(..)
  , wieldedItem
  , wieldableItem
  , asWieldedItem

    -- *
  , mkCharacter
  , pickUpItem
  , isDead
  , isFullyHealed
  , damage
  ) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import           Brick
import           Data.Aeson.Generic.DerivingVia
import           Data.Aeson (ToJSON, FromJSON)
import           Data.Coerce (coerce)
import           Test.QuickCheck
import           Test.QuickCheck.Instances.Vector ()
import           Test.QuickCheck.Arbitrary.Generic
--------------------------------------------------------------------------------
import           Xanthous.Util.QuickCheck
import           Xanthous.Game.State
import           Xanthous.Entities.Item
import           Xanthous.Data
                 ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned
                 , Positioned(..)
                 )
import           Xanthous.Entities.RawTypes (WieldableItem, wieldable)
import qualified Xanthous.Entities.RawTypes as Raw
--------------------------------------------------------------------------------

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

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

inLeftHand :: WieldedItem -> Wielded
inLeftHand wi = Hands (Just wi) Nothing

rightHand :: Traversal' Wielded WieldedItem
rightHand = hands . _2 . _Just

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

--------------------------------------------------------------------------------

data Character = Character
  { _inventory :: !Inventory
  , _characterName :: !(Maybe Text)
  , _characterHitpoints' :: !Double
  , _speed :: TicksPerTile
  }
  deriving stock (Show, Eq, Ord, Generic)
  deriving anyclass (NFData, CoArbitrary, Function)
  deriving (ToJSON, FromJSON)
       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
           Character
makeLenses ''Character

characterHitpoints :: Character -> Hitpoints
characterHitpoints = views characterHitpoints' floor

scrollOffset :: Int
scrollOffset = 5

instance Draw Character where
  draw _ = visibleRegion rloc rreg $ str "@"
    where
      rloc = Location (negate scrollOffset, negate scrollOffset)
      rreg = (2 * scrollOffset, 2 * scrollOffset)
  drawPriority = const maxBound -- Character should always be on top, for now

instance Brain Character where
  step ticks = (pure .) $ positioned . characterHitpoints' %~ \hp ->
    if hp > fromIntegral initialHitpoints
    then hp
    else hp + hitpointRecoveryRate |*| ticks

instance Entity Character where
  description _ = "yourself"
  entityChar _ = "@"

instance Arbitrary Character where
  arbitrary = genericArbitrary

initialHitpoints :: Hitpoints
initialHitpoints = 10

hitpointRecoveryRate :: Double `Per` Ticks
hitpointRecoveryRate = 1.0 / (15 * coerce defaultSpeed)

defaultSpeed :: TicksPerTile
defaultSpeed = 100

mkCharacter :: Character
mkCharacter = Character
  { _inventory = mempty
  , _characterName = Nothing
  , _characterHitpoints' = fromIntegral initialHitpoints
  , _speed = defaultSpeed
  }

defaultCharacterDamage :: Hitpoints
defaultCharacterDamage = 1

-- | Returns the damage that the character currently does with an attack
-- TODO use double-handed/left-hand/right-hand here
characterDamage :: Character -> Hitpoints
characterDamage
  = fromMaybe defaultCharacterDamage
  . preview (inventory . wielded . wieldedItems . wieldableItem . Raw.damage)

-- | Is the character fully healed up to or past their initial hitpoints?
isFullyHealed :: Character -> Bool
isFullyHealed = (>= initialHitpoints) . characterHitpoints

-- | Is the character dead?
isDead :: Character -> Bool
isDead = (== 0) . characterHitpoints

pickUpItem :: Item -> Character -> Character
pickUpItem it = inventory . backpack %~ (it <|)

damage :: Hitpoints -> Character -> Character
damage (fromIntegral -> amount) = characterHitpoints' %~ \case
  n | n <= amount -> 0
    | otherwise  -> n - amount