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
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
|
-- | Handle atomic commands on the server, after they are executed
-- to change server 'State' and before they are sent to clients.
module Game.LambdaHack.Server.HandleAtomicM
( cmdAtomicSemSer
#ifdef EXPOSE_INTERNAL
-- * Internal operations
, validateFloor, validateFloorBag, levelOfStash
, invalidateArenas, updateSclear, updateSlit
, invalidateLucidLid, invalidateLucidAid
, actorHasShine, itemAffectsShineRadius, itemAffectsPerRadius
, addPerActor, addPerActorAny, deletePerActor, deletePerActorAny
, invalidatePerActor, reconsiderPerActor, invalidatePerLid
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import Game.LambdaHack.Atomic
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Content.TileKind (TileKind)
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
import Game.LambdaHack.Server.Fov
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.State
-- | Effect of atomic actions on server state is calculated
-- with the global state from after the command is executed
-- (except where the supplied @oldState@ is used).
cmdAtomicSemSer :: MonadServer m => State -> UpdAtomic -> m ()
cmdAtomicSemSer oldState cmd = case cmd of
UpdRegisterItems{} -> return ()
UpdCreateActor aid b _ -> do
actorMaxSkills <- getsState sactorMaxSkills
when (actorHasShine actorMaxSkills aid) $ invalidateLucidLid $ blid b
addPerActor aid b
UpdDestroyActor aid b _ -> do
let actorMaxSkillsOld = sactorMaxSkills oldState
when (actorHasShine actorMaxSkillsOld aid) $ invalidateLucidLid $ blid b
deletePerActor actorMaxSkillsOld aid b
modifyServer $ \ser ->
ser { sactorTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)
(sactorTime ser)
, strajTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)
(strajTime ser)
, strajPushedBy = EM.delete aid (strajPushedBy ser)
, sactorAn = EM.delete aid (sactorAn ser)
, sactorStasis = ES.delete aid (sactorStasis ser) }
UpdCreateItem _ iid _ _ (CFloor lid _) -> validateFloor iid lid
UpdCreateItem _ iid _ _ (CActor aid CStash) -> do
lid <- levelOfStash aid
validateFloor iid lid
UpdCreateItem _ iid _ _ (CActor aid CGround) -> do
lid <- getsState $ blid . getActorBody aid
validateFloor iid lid
UpdCreateItem _ iid _ _ (CActor aid _) -> do
discoAspect <- getsState sdiscoAspect
when (itemAffectsShineRadius discoAspect iid) $
invalidateLucidAid aid
when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid
UpdCreateItem{} -> return ()
UpdDestroyItem _ iid _ _ (CFloor lid _) -> validateFloor iid lid
UpdDestroyItem _ iid _ _ (CActor aid CStash) -> do
lid <- levelOfStash aid
validateFloor iid lid
UpdDestroyItem _ iid _ _ (CActor aid CGround) -> do
lid <- getsState $ blid . getActorBody aid
validateFloor iid lid
UpdDestroyItem _ iid _ _ (CActor aid _) -> do
discoAspect <- getsState sdiscoAspect
when (itemAffectsShineRadius discoAspect iid) $
invalidateLucidAid aid
when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid
UpdDestroyItem{} -> return ()
UpdSpotActor aid b -> do
-- On server, it does't affect aspects, but does affect lucid (Ascend).
actorMaxSkills <- getsState sactorMaxSkills
when (actorHasShine actorMaxSkills aid) $ invalidateLucidLid $ blid b
addPerActor aid b
UpdLoseActor aid b -> do
-- On server, it does't affect aspects, but does affect lucid (Ascend).
let actorMaxSkillsOld = sactorMaxSkills oldState
when (actorHasShine actorMaxSkillsOld aid) $ invalidateLucidLid $ blid b
deletePerActor actorMaxSkillsOld aid b
modifyServer $ \ser ->
ser { sactorTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)
(sactorTime ser)
, strajTime = EM.adjust (EM.adjust (EM.delete aid) (blid b)) (bfid b)
(strajTime ser)
, strajPushedBy = EM.delete aid (strajPushedBy ser)
, sactorAn = EM.delete aid (sactorAn ser)
, sactorStasis = ES.delete aid (sactorStasis ser) }
UpdSpotItem _ iid _ (CFloor lid _) -> validateFloor iid lid
UpdSpotItem _ iid _ (CActor aid CStash) -> do
lid <- levelOfStash aid
validateFloor iid lid
UpdSpotItem _ iid _ (CActor aid CGround) -> do
lid <- getsState $ blid . getActorBody aid
validateFloor iid lid
UpdSpotItem _ iid _ (CActor aid _) -> do
discoAspect <- getsState sdiscoAspect
when (itemAffectsShineRadius discoAspect iid) $
invalidateLucidAid aid
when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid
UpdSpotItem{} -> return ()
UpdLoseItem _ iid _ (CFloor lid _) -> validateFloor iid lid
UpdLoseItem _ iid _ (CActor aid CStash) -> do
lid <- levelOfStash aid
validateFloor iid lid
UpdLoseItem _ iid _ (CActor aid CGround) -> do
lid <- getsState $ blid . getActorBody aid
validateFloor iid lid
UpdLoseItem _ iid _ (CActor aid _) -> do
discoAspect <- getsState sdiscoAspect
when (itemAffectsShineRadius discoAspect iid) $
invalidateLucidAid aid
when (itemAffectsPerRadius discoAspect iid) $ reconsiderPerActor aid
UpdLoseItem{} -> return ()
UpdSpotItemBag _ (CFloor lid _) bag -> validateFloorBag bag lid
UpdSpotItemBag _ (CActor aid CStash) bag -> do
lid <- levelOfStash aid
validateFloorBag bag lid
UpdSpotItemBag _ (CActor aid CGround) bag -> do
lid <- getsState $ blid . getActorBody aid
validateFloorBag bag lid
UpdSpotItemBag _ (CActor aid _) bag -> do
discoAspect <- getsState sdiscoAspect
let iids = EM.keys bag
when (any (itemAffectsShineRadius discoAspect) iids) $
invalidateLucidAid aid
when (any (itemAffectsPerRadius discoAspect) iids) $
reconsiderPerActor aid
UpdSpotItemBag{} -> return ()
UpdLoseItemBag _ (CFloor lid _) bag -> validateFloorBag bag lid
UpdLoseItemBag _ (CActor aid CStash) bag -> do
lid <- levelOfStash aid
validateFloorBag bag lid
UpdLoseItemBag _ (CActor aid CGround) bag -> do
lid <- levelOfStash aid
validateFloorBag bag lid
UpdLoseItemBag _ (CActor aid _) bag -> do
discoAspect <- getsState sdiscoAspect
let iids = EM.keys bag
when (any (itemAffectsShineRadius discoAspect) iids) $
invalidateLucidAid aid
when (any (itemAffectsPerRadius discoAspect) iids) $
reconsiderPerActor aid
UpdLoseItemBag{} -> return ()
UpdMoveActor aid _ _ -> do
actorMaxSkills <- getsState sactorMaxSkills
when (actorHasShine actorMaxSkills aid) $ invalidateLucidAid aid
invalidatePerActor aid
UpdWaitActor{} -> return ()
UpdDisplaceActor aid1 aid2 -> do
actorMaxSkills <- getsState sactorMaxSkills
when (actorHasShine actorMaxSkills aid1
|| actorHasShine actorMaxSkills aid2) $
invalidateLucidAid aid1 -- the same lid as aid2
invalidatePerActor aid1
invalidatePerActor aid2
UpdMoveItem iid _k aid s1 s2 -> do
let dummyVerbose = False
dummyKit = quantSingle
cmdAtomicSemSer oldState $
UpdLoseItem dummyVerbose iid dummyKit (CActor aid s1)
cmdAtomicSemSer oldState $
UpdSpotItem dummyVerbose iid dummyKit (CActor aid s2)
UpdRefillHP{} -> return ()
UpdRefillCalm aid _ -> do
actorMaxSk <- getsState $ getActorMaxSkills aid
body <- getsState $ getActorBody aid
let sight = Ability.getSk Ability.SkSight actorMaxSk
oldBody = getActorBody aid oldState
radiusOld = boundSightByCalm sight (bcalm oldBody)
radiusNew = boundSightByCalm sight (bcalm body)
when (radiusOld /= radiusNew) $ invalidatePerActor aid
UpdTrajectory{} -> return ()
UpdQuitFaction{} -> return ()
UpdSpotStashFaction _ fid lid _ -> invalidatePerFidLid fid lid
UpdLoseStashFaction _ fid lid _ -> invalidatePerFidLid fid lid
UpdLeadFaction{} -> invalidateArenas
UpdDiplFaction{} -> return ()
UpdDoctrineFaction{} -> return ()
UpdAutoFaction{} -> return ()
UpdRecordKill{} -> invalidateArenas
UpdAlterTile lid pos fromTile toTile -> do
clearChanged <- updateSclear lid pos fromTile toTile
litChanged <- updateSlit lid pos fromTile toTile
when (clearChanged || litChanged) $ invalidateLucidLid lid
when clearChanged $ invalidatePerLid lid
UpdAlterExplorable{} -> return ()
UpdAlterGold{} -> return ()
UpdSearchTile{} -> return ()
UpdHideTile{} -> return ()
UpdSpotTile{} -> return ()
UpdLoseTile{} -> return ()
UpdSpotEntry{} -> return ()
UpdLoseEntry{} -> return ()
UpdAlterSmell{} -> return ()
UpdSpotSmell{} -> return ()
UpdLoseSmell{} -> return ()
UpdTimeItem{} -> return ()
UpdAgeGame{} -> return ()
UpdUnAgeGame{} -> return ()
UpdDiscover{} -> return ()
UpdCover{} -> return ()
UpdDiscoverKind{} -> return ()
UpdCoverKind{} -> return ()
UpdDiscoverAspect{} -> return ()
UpdCoverAspect{} -> return ()
UpdDiscoverServer{} -> return ()
UpdCoverServer{} -> return ()
UpdPerception{} -> return ()
UpdRestart{} -> return ()
UpdRestartServer{} -> return ()
UpdResume{} -> return ()
UpdResumeServer{} -> return ()
UpdKillExit{} -> return ()
UpdWriteSave{} -> return ()
UpdHearFid{} -> return ()
UpdMuteMessages{} -> return ()
validateFloor :: MonadServer m => ItemId -> LevelId -> m ()
validateFloor iid lid = do
discoAspect <- getsState sdiscoAspect
when (itemAffectsShineRadius discoAspect iid) $ invalidateLucidLid lid
validateFloorBag :: MonadServer m => ItemBag -> LevelId -> m ()
validateFloorBag bag lid = do
discoAspect <- getsState sdiscoAspect
let iids = EM.keys bag
when (any (itemAffectsShineRadius discoAspect) iids) $
invalidateLucidLid lid
levelOfStash :: MonadStateRead m => ActorId -> m LevelId
levelOfStash aid = do
b <- getsState $ getActorBody aid
mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b
case mstash of
Just (lid, _) -> return lid
Nothing -> error $ "" `showFailure` (aid, b)
invalidateArenas :: MonadServer m => m ()
invalidateArenas = modifyServer $ \ser -> ser {svalidArenas = False}
updateSclear :: MonadServer m
=> LevelId -> Point -> ContentId TileKind -> ContentId TileKind
-> m Bool
updateSclear lid pos fromTile toTile = do
COps{coTileSpeedup} <- getsState scops
let fromClear = Tile.isClear coTileSpeedup fromTile
toClear = Tile.isClear coTileSpeedup toTile
if fromClear == toClear then return False else do
let f FovClear{fovClear} =
FovClear $ fovClear PointArray.// [(pos, toClear)]
modifyServer $ \ser ->
ser {sfovClearLid = EM.adjust f lid $ sfovClearLid ser}
return True
updateSlit :: MonadServer m
=> LevelId -> Point -> ContentId TileKind -> ContentId TileKind
-> m Bool
updateSlit lid pos fromTile toTile = do
COps{coTileSpeedup} <- getsState scops
let fromLit = Tile.isLit coTileSpeedup fromTile
toLit = Tile.isLit coTileSpeedup toTile
if fromLit == toLit then return False else do
let f (FovLit set) =
FovLit $ if toLit then ES.insert pos set else ES.delete pos set
modifyServer $ \ser -> ser {sfovLitLid = EM.adjust f lid $ sfovLitLid ser}
return True
invalidateLucidLid :: MonadServer m => LevelId -> m ()
invalidateLucidLid lid =
modifyServer $ \ser ->
ser { sfovLucidLid = EM.insert lid FovInvalid $ sfovLucidLid ser
, sperValidFid = EM.map (EM.insert lid False) $ sperValidFid ser }
invalidateLucidAid :: MonadServer m => ActorId -> m ()
invalidateLucidAid aid = do
lid <- getsState $ blid . getActorBody aid
invalidateLucidLid lid
actorHasShine :: ActorMaxSkills -> ActorId -> Bool
actorHasShine actorMaxSkills aid = case EM.lookup aid actorMaxSkills of
Just actorMaxSk -> Ability.getSk Ability.SkShine actorMaxSk > 0
Nothing -> error $ "" `showFailure` aid
itemAffectsShineRadius :: DiscoveryAspect -> ItemId -> Bool
itemAffectsShineRadius discoAspect iid = case EM.lookup iid discoAspect of
Just arItem -> IA.getSkill Ability.SkShine arItem /= 0
Nothing -> error $ "" `showFailure` iid
itemAffectsPerRadius :: DiscoveryAspect -> ItemId -> Bool
itemAffectsPerRadius discoAspect iid =
case EM.lookup iid discoAspect of
Just arItem -> IA.getSkill Ability.SkSight arItem /= 0
|| IA.getSkill Ability.SkSmell arItem /= 0
|| IA.getSkill Ability.SkNocto arItem /= 0
Nothing -> error $ "" `showFailure` iid
addPerActor :: MonadServer m => ActorId -> Actor -> m ()
addPerActor aid b = do
actorMaxSk <- getsState $ getActorMaxSkills aid
unless (Ability.getSk Ability.SkSight actorMaxSk <= 0
&& Ability.getSk Ability.SkNocto actorMaxSk <= 0
&& Ability.getSk Ability.SkSmell actorMaxSk <= 0) $
addPerActorAny aid b
addPerActorAny :: MonadServer m => ActorId -> Actor -> m ()
addPerActorAny aid b = do
let fid = bfid b
lid = blid b
f PerceptionCache{perActor} = PerceptionCache
{ ptotal = FovInvalid
, perActor = EM.insert aid FovInvalid perActor }
modifyServer $ \ser ->
ser { sperCacheFid = EM.adjust (EM.adjust f lid) fid $ sperCacheFid ser
, sperValidFid = EM.adjust (EM.insert lid False) fid
$ sperValidFid ser }
deletePerActor :: MonadServer m => ActorMaxSkills -> ActorId -> Actor -> m ()
deletePerActor actorMaxSkillsOld aid b = do
let actorMaxSk = actorMaxSkillsOld EM.! aid
unless (Ability.getSk Ability.SkSight actorMaxSk <= 0
&& Ability.getSk Ability.SkNocto actorMaxSk <= 0
&& Ability.getSk Ability.SkSmell actorMaxSk <= 0) $
deletePerActorAny aid b
deletePerActorAny :: MonadServer m => ActorId -> Actor -> m ()
deletePerActorAny aid b = do
let fid = bfid b
lid = blid b
f PerceptionCache{perActor} = PerceptionCache
{ ptotal = FovInvalid
, perActor = EM.delete aid perActor }
modifyServer $ \ser ->
ser { sperCacheFid = EM.adjust (EM.adjust f lid) fid $ sperCacheFid ser
, sperValidFid = EM.adjust (EM.insert lid False) fid
$ sperValidFid ser }
invalidatePerActor :: MonadServer m => ActorId -> m ()
invalidatePerActor aid = do
actorMaxSk <- getsState $ getActorMaxSkills aid
unless (Ability.getSk Ability.SkSight actorMaxSk <= 0
&& Ability.getSk Ability.SkNocto actorMaxSk <= 0
&& Ability.getSk Ability.SkSmell actorMaxSk <= 0) $ do
b <- getsState $ getActorBody aid
addPerActorAny aid b
reconsiderPerActor :: MonadServer m => ActorId -> m ()
reconsiderPerActor aid = do
b <- getsState $ getActorBody aid
actorMaxSk <- getsState $ getActorMaxSkills aid
if Ability.getSk Ability.SkSight actorMaxSk <= 0
&& Ability.getSk Ability.SkNocto actorMaxSk <= 0
&& Ability.getSk Ability.SkSmell actorMaxSk <= 0
then do
perCacheFid <- getsServer sperCacheFid
when (EM.member aid $ perActor ((perCacheFid EM.! bfid b) EM.! blid b)) $
deletePerActorAny aid b
else addPerActorAny aid b
invalidatePerLid :: MonadServer m => LevelId -> m ()
invalidatePerLid lid = do
let f pc@PerceptionCache{perActor}
| EM.null perActor = pc
| otherwise = PerceptionCache
{ ptotal = FovInvalid
, perActor = EM.map (const FovInvalid) perActor }
modifyServer $ \ser ->
let perCacheFidNew = EM.map (EM.adjust f lid) $ sperCacheFid ser
g fid valid |
ptotal ((perCacheFidNew EM.! fid) EM.! lid) == FovInvalid =
EM.insert lid False valid
g _ valid = valid
in ser { sperCacheFid = perCacheFidNew
, sperValidFid = EM.mapWithKey g $ sperValidFid ser }
invalidatePerFidLid :: MonadServer m => FactionId -> LevelId -> m ()
invalidatePerFidLid fid lid = do
let adj = EM.insert lid False
modifyServer $ \ser ->
ser {sperValidFid = EM.adjust adj fid $ sperValidFid ser}
|
