module Game.LambdaHack.Atomic.HandleAtomicWrite
( handleUpdAtomic
#ifdef EXPOSE_INTERNAL
, updCreateActor, updDestroyActor, updCreateItem, updDestroyItem
, updMoveActor, updWaitActor, updDisplaceActor, updMoveItem
, updRefillHP, updRefillCalm
, updTrajectory, updQuitFaction, updLeadFaction
, updDiplFaction, updTacticFaction, updAutoFaction, updRecordKill
, updAlterTile, updAlterExplorable, updSpotTile, updLoseTile
, updAlterSmell, updSpotSmell, updLoseSmell, updTimeItem
, updAgeGame, updUnAgeGame, updRestart, updRestartServer, updResumeServer
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import qualified Data.EnumMap.Strict as EM
import Data.Int (Int64)
import Game.LambdaHack.Atomic.CmdAtomic
import Game.LambdaHack.Atomic.MonadStateWrite
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.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
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.Time
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.ItemKind (ItemKind)
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.TileKind (TileKind, unknownId)
handleUpdAtomic :: MonadStateWrite m => UpdAtomic -> m ()
handleUpdAtomic cmd = case cmd of
UpdCreateActor aid body ais -> updCreateActor aid body ais
UpdDestroyActor aid body ais -> updDestroyActor aid body ais
UpdCreateItem iid item kit c -> updCreateItem iid item kit c
UpdDestroyItem iid item kit c -> updDestroyItem iid item kit c
UpdSpotActor aid body ais -> updCreateActor aid body ais
UpdLoseActor aid body ais -> updDestroyActor aid body ais
UpdSpotItem _ iid item kit c -> updCreateItem iid item kit c
UpdLoseItem _ iid item kit c -> updDestroyItem iid item kit c
UpdMoveActor aid fromP toP -> updMoveActor aid fromP toP
UpdWaitActor aid toWait -> updWaitActor aid toWait
UpdDisplaceActor source target -> updDisplaceActor source target
UpdMoveItem iid k aid c1 c2 -> updMoveItem iid k aid c1 c2
UpdRefillHP aid n -> updRefillHP aid n
UpdRefillCalm aid n -> updRefillCalm aid n
UpdTrajectory aid fromT toT -> updTrajectory aid fromT toT
UpdQuitFaction fid fromSt toSt -> updQuitFaction fid fromSt toSt
UpdLeadFaction fid source target -> updLeadFaction fid source target
UpdDiplFaction fid1 fid2 fromDipl toDipl ->
updDiplFaction fid1 fid2 fromDipl toDipl
UpdTacticFaction fid toT fromT -> updTacticFaction fid toT fromT
UpdAutoFaction fid st -> updAutoFaction fid st
UpdRecordKill aid ikind k -> updRecordKill aid ikind k
UpdAlterTile lid p fromTile toTile -> updAlterTile lid p fromTile toTile
UpdAlterExplorable lid delta -> updAlterExplorable lid delta
UpdSearchTile{} -> return ()
UpdHideTile{} -> return ()
UpdSpotTile lid ts -> updSpotTile lid ts
UpdLoseTile lid ts -> updLoseTile lid ts
UpdAlterSmell lid p fromSm toSm -> updAlterSmell lid p fromSm toSm
UpdSpotSmell lid sms -> updSpotSmell lid sms
UpdLoseSmell lid sms -> updLoseSmell lid sms
UpdTimeItem iid c fromIt toIt -> updTimeItem iid c fromIt toIt
UpdAgeGame lids -> updAgeGame lids
UpdUnAgeGame lids -> updUnAgeGame lids
UpdDiscover{} -> return ()
UpdCover{} -> return ()
UpdDiscoverKind{} -> return ()
UpdCoverKind{} -> return ()
UpdDiscoverSeed{} -> return ()
UpdCoverSeed{} -> return ()
UpdPerception _ outPer inPer ->
assert (not (nullPer outPer && nullPer inPer)) (return ())
UpdRestart _ _ _ s _ _ -> updRestart s
UpdRestartServer s -> updRestartServer s
UpdResume{} -> return ()
UpdResumeServer s -> updResumeServer s
UpdKillExit{} -> return ()
UpdWriteSave -> return ()
UpdMsgAll{} -> return ()
updCreateActor :: MonadStateWrite m
=> ActorId -> Actor -> [(ItemId, Item)] -> m ()
updCreateActor aid body ais = do
let f Nothing = Just body
f (Just b) = error $ "actor already added"
`showFailure` (aid, body, b)
modifyState $ updateActorD $ EM.alter f aid
let g Nothing = Just [aid]
g (Just l) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
assert (aid `notElem` l `blame` "actor already added"
`swith` (aid, body, l))
#endif
(Just $ aid : l)
updateLevel (blid body) $ updateActorMap (EM.alter g (bpos body))
forM_ ais $ \(iid, item) -> do
let h item1 item2 =
assert (itemsMatch item1 item2
`blame` "inconsistent created actor items"
`swith` (aid, body, iid, item1, item2))
item2
modifyState $ updateItemD $ EM.insertWith h iid item
itemsMatch :: Item -> Item -> Bool
itemsMatch item1 item2 =
jkindIx item1 == jkindIx item2
updDestroyActor :: MonadStateWrite m
=> ActorId -> Actor -> [(ItemId, Item)] -> m ()
updDestroyActor aid body ais = do
itemD <- getsState sitemD
let match (iid, item) = itemsMatch (itemD EM.! iid) item
let !_A = assert (allB match ais `blame` "destroyed actor items not found"
`swith` (aid, body, ais, itemD)) ()
let f Nothing = error $ "actor already removed" `showFailure` (aid, body)
f (Just b) = assert (b == body `blame` "inconsistent destroyed actor body"
`swith` (aid, body, b)) Nothing
modifyState $ updateActorD $ EM.alter f aid
let g Nothing = error $ "actor already removed" `showFailure` (aid, body)
g (Just l) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
assert (aid `elem` l `blame` "actor already removed"
`swith` (aid, body, l))
#endif
(let l2 = delete aid l
in if null l2 then Nothing else Just l2)
updateLevel (blid body) $ updateActorMap (EM.alter g (bpos body))
updCreateItem :: MonadStateWrite m
=> ItemId -> Item -> ItemQuant -> Container -> m ()
updCreateItem iid item kit@(k, _) c = assert (k > 0) $ do
let f item1 item2 =
assert (itemsMatch item1 item2)
item2
modifyState $ updateItemD $ EM.insertWith f iid item
insertItemContainer iid kit c
updDestroyItem :: MonadStateWrite m
=> ItemId -> Item -> ItemQuant -> Container -> m ()
updDestroyItem iid item kit@(k, _) c = assert (k > 0) $ do
itemD <- getsState sitemD
let !_A = assert ((case iid `EM.lookup` itemD of
Nothing -> False
Just item0 -> itemsMatch item0 item)
`blame` "item already removed"
`swith` (iid, item, itemD)) ()
deleteItemContainer iid kit c
updMoveActor :: MonadStateWrite m => ActorId -> Point -> Point -> m ()
updMoveActor aid fromP toP = assert (fromP /= toP) $ do
body <- getsState $ getActorBody aid
let !_A = assert (fromP == bpos body
`blame` "unexpected moved actor position"
`swith` (aid, fromP, toP, bpos body, body)) ()
newBody = body {bpos = toP, boldpos = Just fromP}
updateActor aid $ const newBody
moveActorMap aid body newBody
updWaitActor :: MonadStateWrite m => ActorId -> Bool -> m ()
updWaitActor aid toWait = do
b <- getsState $ getActorBody aid
let !_A = assert (toWait /= bwait b
`blame` "unexpected waited actor time"
`swith` (aid, toWait, bwait b, b)) ()
updateActor aid $ \body -> body {bwait = toWait}
updDisplaceActor :: MonadStateWrite m => ActorId -> ActorId -> m ()
updDisplaceActor source target = assert (source /= target) $ do
sbody <- getsState $ getActorBody source
tbody <- getsState $ getActorBody target
let spos = bpos sbody
tpos = bpos tbody
snewBody = sbody {bpos = tpos, boldpos = Just spos}
tnewBody = tbody {bpos = spos, boldpos = Just tpos}
updateActor source $ const snewBody
updateActor target $ const tnewBody
moveActorMap source sbody snewBody
moveActorMap target tbody tnewBody
updMoveItem :: MonadStateWrite m
=> ItemId -> Int -> ActorId -> CStore -> CStore
-> m ()
updMoveItem iid k aid c1 c2 = assert (k > 0 && c1 /= c2) $ do
b <- getsState $ getActorBody aid
bag <- getsState $ getBodyStoreBag b c1
case iid `EM.lookup` bag of
Nothing -> error $ "" `showFailure` (iid, k, aid, c1, c2)
Just (_, it) -> do
deleteItemActor iid (k, take k it) aid c1
insertItemActor iid (k, take k it) aid c2
updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m ()
updRefillHP aid n =
updateActor aid $ \b ->
b { bhp = bhp b + n
, bhpDelta = let oldD = bhpDelta b
in case compare n 0 of
EQ -> ResDelta { resCurrentTurn = (0, 0)
, resPreviousTurn = resCurrentTurn oldD }
LT -> oldD {resCurrentTurn =
( fst (resCurrentTurn oldD) + n
, snd (resCurrentTurn oldD) )}
GT -> oldD {resCurrentTurn =
( fst (resCurrentTurn oldD)
, snd (resCurrentTurn oldD) + n )}
}
updRefillCalm :: MonadStateWrite m => ActorId -> Int64 -> m ()
updRefillCalm aid n =
updateActor aid $ \b ->
b { bcalm = max 0 $ bcalm b + n
, bcalmDelta = let oldD = bcalmDelta b
in case compare n 0 of
EQ -> ResDelta { resCurrentTurn = (0, 0)
, resPreviousTurn = resCurrentTurn oldD }
LT -> oldD {resCurrentTurn =
( fst (resCurrentTurn oldD) + n
, snd (resCurrentTurn oldD) )}
GT -> oldD {resCurrentTurn =
( fst (resCurrentTurn oldD)
, snd (resCurrentTurn oldD) + n )}
}
updTrajectory :: MonadStateWrite m
=> ActorId
-> Maybe ([Vector], Speed)
-> Maybe ([Vector], Speed)
-> m ()
updTrajectory aid fromT toT = assert (fromT /= toT) $ do
body <- getsState $ getActorBody aid
let !_A = assert (fromT == btrajectory body
`blame` "unexpected actor trajectory"
`swith` (aid, fromT, toT, body)) ()
updateActor aid $ \b -> b {btrajectory = toT}
updQuitFaction :: MonadStateWrite m
=> FactionId -> Maybe Status -> Maybe Status -> m ()
updQuitFaction fid fromSt toSt = do
let !_A = assert (fromSt /= toSt `blame` (fid, fromSt, toSt)) ()
fact <- getsState $ (EM.! fid) . sfactionD
let !_A = assert (fromSt == gquit fact
`blame` "unexpected actor quit status"
`swith` (fid, fromSt, toSt, fact)) ()
let adj fa = fa {gquit = toSt}
updateFaction fid adj
updLeadFaction :: MonadStateWrite m
=> FactionId
-> Maybe ActorId
-> Maybe ActorId
-> m ()
updLeadFaction fid source target = assert (source /= target) $ do
fact <- getsState $ (EM.! fid) . sfactionD
let !_A = assert (fleaderMode (gplayer fact) /= LeaderNull) ()
mtb <- getsState $ \s -> flip getActorBody s <$> target
let !_A = assert (maybe True (not . bproj) mtb
`blame` (fid, source, target, mtb, fact)) ()
let !_A = assert (source == _gleader fact
`blame` "unexpected actor leader"
`swith` (fid, source, target, mtb, fact)) ()
let adj fa = fa {_gleader = target}
updateFaction fid adj
updDiplFaction :: MonadStateWrite m
=> FactionId -> FactionId -> Diplomacy -> Diplomacy -> m ()
updDiplFaction fid1 fid2 fromDipl toDipl =
assert (fid1 /= fid2 && fromDipl /= toDipl) $ do
fact1 <- getsState $ (EM.! fid1) . sfactionD
fact2 <- getsState $ (EM.! fid2) . sfactionD
let !_A = assert (fromDipl == EM.findWithDefault Unknown fid2 (gdipl fact1)
&& fromDipl == EM.findWithDefault Unknown fid1 (gdipl fact2)
`blame` "unexpected actor diplomacy status"
`swith` (fid1, fid2, fromDipl, toDipl, fact1, fact2)) ()
let adj fid fact = fact {gdipl = EM.insert fid toDipl (gdipl fact)}
updateFaction fid1 (adj fid2)
updateFaction fid2 (adj fid1)
updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m ()
updAutoFaction fid st =
updateFaction fid (\fact ->
assert (isAIFact fact == not st)
$ fact {gplayer = automatePlayer st (gplayer fact)})
updTacticFaction :: MonadStateWrite m => FactionId -> Tactic -> Tactic -> m ()
updTacticFaction fid toT fromT = do
let adj fact =
let player = gplayer fact
in assert (ftactic player == fromT)
$ fact {gplayer = player {ftactic = toT}}
updateFaction fid adj
updRecordKill :: MonadStateWrite m => ActorId -> Kind.Id ItemKind -> Int -> m ()
updRecordKill aid ikind k = do
b <- getsState $ getActorBody aid
let !_A = assert (not (bproj b) `blame` (aid, b))
let alterKind mn = let n = fromMaybe 0 mn + k
in if n == 0 then Nothing else Just n
adjFact fact = fact {gvictims = EM.alter alterKind ikind
$ gvictims fact}
updateFaction (bfid b) adjFact
updAlterTile :: MonadStateWrite m
=> LevelId -> Point -> Kind.Id TileKind -> Kind.Id TileKind
-> m ()
updAlterTile lid p fromTile toTile = assert (fromTile /= toTile) $ do
Kind.COps{cotile, coTileSpeedup} <- getsState scops
lvl <- getLevel lid
let adj ts = assert (ts PointArray.! p == fromTile
|| ts PointArray.! p == Tile.hideAs cotile fromTile
`blame` "unexpected altered tile kind"
`swith` (lid, p, fromTile, toTile, ts PointArray.! p))
$ ts PointArray.// [(p, toTile)]
updateLevel lid $ updateTile adj
case ( Tile.isExplorable coTileSpeedup fromTile
, Tile.isExplorable coTileSpeedup toTile ) of
(False, True) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl + 1}
(True, False) -> updateLevel lid $ \lvl2 -> lvl2 {lseen = lseen lvl - 1}
_ -> return ()
updAlterExplorable :: MonadStateWrite m => LevelId -> Int -> m ()
updAlterExplorable lid delta = assert (delta /= 0) $
updateLevel lid $ \lvl -> lvl {lexplorable = lexplorable lvl + delta}
updSpotTile :: MonadStateWrite m
=> LevelId -> [(Point, Kind.Id TileKind)] -> m ()
updSpotTile lid ts = assert (not $ null ts) $ do
Kind.COps{coTileSpeedup} <- getsState scops
Level{ltile} <- getLevel lid
let adj tileMap = tileMap PointArray.// ts
updateLevel lid $ updateTile adj
let f (p, t2) = do
let t1 = ltile PointArray.! p
case (Tile.isExplorable coTileSpeedup t1, Tile.isExplorable coTileSpeedup t2) of
(False, True) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl+1}
(True, False) -> updateLevel lid $ \lvl -> lvl {lseen = lseen lvl-1}
_ -> return ()
mapM_ f ts
updLoseTile :: MonadStateWrite m
=> LevelId -> [(Point, Kind.Id TileKind)] -> m ()
updLoseTile lid ts = assert (not $ null ts) $ do
Kind.COps{coTileSpeedup} <- getsState scops
let matches _ [] = True
matches tileMap ((p, ov) : rest) =
tileMap PointArray.! p == ov && matches tileMap rest
tu = map (second (const unknownId)) ts
adj tileMap = assert (matches tileMap ts) $ tileMap PointArray.// tu
updateLevel lid $ updateTile adj
let f (_, t1) =
when (Tile.isExplorable coTileSpeedup t1) $
updateLevel lid $ \lvl -> lvl {lseen = lseen lvl - 1}
mapM_ f ts
updAlterSmell :: MonadStateWrite m => LevelId -> Point -> Time -> Time -> m ()
updAlterSmell lid p fromSm' toSm' = do
let fromSm = if fromSm' == timeZero then Nothing else Just fromSm'
toSm = if toSm' == timeZero then Nothing else Just toSm'
alt sm = assert (sm == fromSm `blame` "unexpected tile smell"
`swith` (lid, p, fromSm, toSm, sm)) toSm
updateLevel lid $ updateSmell $ EM.alter alt p
updSpotSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()
updSpotSmell lid sms = assert (not $ null sms) $ do
let alt sm Nothing = Just sm
alt sm (Just oldSm) = error $ "smell already added"
`showFailure` (lid, sms, sm, oldSm)
f (p, sm) = EM.alter (alt sm) p
upd m = foldr f m sms
updateLevel lid $ updateSmell upd
updLoseSmell :: MonadStateWrite m => LevelId -> [(Point, Time)] -> m ()
updLoseSmell lid sms = assert (not $ null sms) $ do
let alt sm Nothing = error $ "smell already removed"
`showFailure` (lid, sms, sm)
alt sm (Just oldSm) =
assert (sm == oldSm `blame` "unexpected lost smell"
`swith` (lid, sms, sm, oldSm)) Nothing
f (p, sm) = EM.alter (alt sm) p
upd m = foldr f m sms
updateLevel lid $ updateSmell upd
updTimeItem :: MonadStateWrite m
=> ItemId -> Container -> ItemTimer -> ItemTimer
-> m ()
updTimeItem iid c fromIt toIt = assert (fromIt /= toIt) $ do
bag <- getsState $ getContainerBag c
case iid `EM.lookup` bag of
Just (k, it) -> do
let !_A = assert (fromIt == it `blame` (k, it, iid, c, fromIt, toIt)) ()
deleteItemContainer iid (k, fromIt) c
insertItemContainer iid (k, toIt) c
Nothing -> error $ "" `showFailure` (bag, iid, c, fromIt, toIt)
updAgeGame :: MonadStateWrite m => [LevelId] -> m ()
updAgeGame lids = do
modifyState $ updateTime $ flip timeShift (Delta timeClip)
mapM_ (ageLevel (Delta timeClip)) lids
updUnAgeGame :: MonadStateWrite m => [LevelId] -> m ()
updUnAgeGame lids = do
modifyState $ updateTime $ flip timeShift (timeDeltaReverse $ Delta timeClip)
mapM_ (ageLevel (timeDeltaReverse $ Delta timeClip)) lids
ageLevel :: MonadStateWrite m => Delta Time -> LevelId -> m ()
ageLevel delta lid =
updateLevel lid $ \lvl -> lvl {ltime = timeShift (ltime lvl) delta}
updRestart :: MonadStateWrite m => State -> m ()
updRestart = putState
updRestartServer :: MonadStateWrite m => State -> m ()
updRestartServer = putState
updResumeServer :: MonadStateWrite m => State -> m ()
updResumeServer = putState