{-# LANGUAGE FlexibleContexts #-}
module Game.LambdaHack.Atomic.HandleAtomicWrite
( handleUpdAtomic
#ifdef EXPOSE_INTERNAL
, updCreateActor, updDestroyActor, updCreateItem, updDestroyItem
, updSpotItemBag, updLoseItemBag
, updMoveActor, updWaitActor, updDisplaceActor, updMoveItem
, updRefillHP, updRefillCalm
, updTrajectory, updQuitFaction, updLeadFaction
, updDiplFaction, updTacticFaction, updAutoFaction, updRecordKill
, updAlterTile, updAlterExplorable, updSearchTile, updSpotTile, updLoseTile
, updAlterSmell, updSpotSmell, updLoseSmell, updTimeItem
, updAgeGame, updUnAgeGame, ageLevel, updDiscover, updCover
, updDiscoverKind, discoverKind, updCoverKind
, updDiscoverAspect, discoverAspect, updCoverAspect
, updDiscoverServer, updCoverServer
, updRestart, updRestartServer, updResumeServer
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.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.ItemAspect as IA
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Common.Vector
import Game.LambdaHack.Content.ItemKind (ItemKind)
import Game.LambdaHack.Content.ModeKind
import qualified Game.LambdaHack.Content.PlaceKind as PK
import Game.LambdaHack.Content.TileKind (TileKind, unknownId)
import Game.LambdaHack.Common.Point
import qualified Game.LambdaHack.Common.PointArray as PointArray
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
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
UpdSpotItemBag c bag ais -> updSpotItemBag c bag ais
UpdLoseItemBag c bag ais -> updLoseItemBag c bag ais
UpdMoveActor aid fromP toP -> updMoveActor aid fromP toP
UpdWaitActor aid fromWS toWS -> updWaitActor aid fromWS toWS
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
UpdAlterGold delta -> updAlterGold delta
UpdSearchTile aid p toTile -> updSearchTile aid p toTile
UpdHideTile{} -> undefined
UpdSpotTile lid ts -> updSpotTile lid ts
UpdLoseTile lid ts -> updLoseTile lid ts
UpdSpotEntry lid ts -> updSpotEntry lid ts
UpdLoseEntry lid ts -> updLoseEntry 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 c iid ik arItem -> updDiscover c iid ik arItem
UpdCover c iid ik arItem -> updCover c iid ik arItem
UpdDiscoverKind c ix ik -> updDiscoverKind c ix ik
UpdCoverKind c ix ik -> updCoverKind c ix ik
UpdDiscoverAspect c iid arItem -> updDiscoverAspect c iid arItem
UpdCoverAspect c iid arItem -> updCoverAspect c iid arItem
UpdDiscoverServer iid arItem -> updDiscoverServer iid arItem
UpdCoverServer iid arItem -> updCoverServer iid arItem
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 ()
UpdHearFid{} -> return ()
updCreateActor :: MonadStateWrite m
=> ActorId -> Actor -> [(ItemId, Item)] -> m ()
updCreateActor aid body ais = do
let f Nothing = Just body
f (Just b) = assert (body == b `blame` (aid, body, b)) $
atomicFail $ "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)
let h Nothing = Just aid
h (Just aid2) = error $ "an actor already present there"
`showFailure` (aid, body, aid2)
updateLevel (blid body) $ if bproj body
then updateProjMap (EM.alter g (bpos body))
else updateBigMap (EM.alter h (bpos body))
addAis ais
actorMaxSk <- getsState $ maxSkillsFromActor body
modifyState $ updateActorMaxSkills $ EM.insert aid actorMaxSk
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)
let h Nothing = error $ "actor already removed" `showFailure` (aid, body)
h (Just _aid2) =
#ifdef WITH_EXPENSIVE_ASSERTIONS
assert (aid == _aid2 `blame` "actor already removed"
`swith` (aid, body, _aid2))
#endif
Nothing
updateLevel (blid body) $ if bproj body
then updateProjMap (EM.alter g (bpos body))
else updateBigMap (EM.alter h (bpos body))
modifyState $ updateActorMaxSkills $ EM.delete aid
updCreateItem :: MonadStateWrite m
=> ItemId -> Item -> ItemQuant -> Container -> m ()
updCreateItem iid item kit@(k, _) c = do
addAis [(iid, item)]
when (k > 0) $ do
insertItemContainer iid kit c
case c of
CActor aid store -> when (store `elem` [CEqp, COrgan])
$ addItemToActorMaxSkills iid item k aid
_ -> return ()
updDestroyItem :: MonadStateWrite m
=> ItemId -> Item -> ItemQuant -> Container -> m ()
updDestroyItem iid item kit@(k, _) c = assert (k > 0) $ do
deleteItemContainer iid kit c
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)) ()
case c of
CActor aid store -> when (store `elem` [CEqp, COrgan])
$ addItemToActorMaxSkills iid item (-k) aid
_ -> return ()
updSpotItemBag :: MonadStateWrite m
=> Container -> ItemBag -> [(ItemId, Item)] -> m ()
updSpotItemBag c bag ais = do
addAis ais
when (not $ EM.null bag) $ do
let !_A = assert (EM.size bag == length ais) ()
insertBagContainer bag c
case c of
CActor aid store ->
when (store `elem` [CEqp, COrgan]) $
forM_ ais $ \(iid, item) ->
addItemToActorMaxSkills iid item (fst $ bag EM.! iid) aid
_ -> return ()
updLoseItemBag :: MonadStateWrite m
=> Container -> ItemBag -> [(ItemId, Item)] -> m ()
updLoseItemBag c bag ais = assert (EM.size bag > 0
&& EM.size bag == length ais) $ do
deleteBagContainer bag c
itemD <- getsState sitemD
let match (iid, item) = itemsMatch (itemD EM.! iid) item
let !_A = assert (allB match ais `blame` "items already removed"
`swith` (c, bag, ais, itemD)) ()
case c of
CActor aid store ->
when (store `elem` [CEqp, COrgan]) $
forM_ ais $ \(iid, item) ->
addItemToActorMaxSkills iid item (- (fst $ bag EM.! iid)) aid
_ -> return ()
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 -> Watchfulness -> Watchfulness -> m ()
updWaitActor aid fromWS toWS = assert (fromWS /= toWS) $ do
body <- getsState $ getActorBody aid
let !_A = assert (fromWS == bwatch body
`blame` "unexpected actor wait state"
`swith` (aid, fromWS, bwatch body, body)) ()
updateActor aid $ \b -> b {bwatch = toWS}
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
swapActorMap source sbody target tbody
updMoveItem :: MonadStateWrite m
=> ItemId -> Int -> ActorId -> CStore -> CStore
-> m ()
updMoveItem iid k aid s1 s2 = assert (k > 0 && s1 /= s2) $ do
b <- getsState $ getActorBody aid
bag <- getsState $ getBodyStoreBag b s1
case iid `EM.lookup` bag of
Nothing -> error $ "" `showFailure` (iid, k, aid, s1, s2)
Just (_, it) -> do
deleteItemActor iid (k, take k it) aid s1
insertItemActor iid (k, take k it) aid s2
case s1 of
CEqp -> case s2 of
COrgan -> return ()
_ -> do
itemBase <- getsState $ getItemBody iid
addItemToActorMaxSkills iid itemBase (-k) aid
COrgan -> case s2 of
CEqp -> return ()
_ -> do
itemBase <- getsState $ getItemBody iid
addItemToActorMaxSkills iid itemBase (-k) aid
_ ->
when (s2 `elem` [CEqp, COrgan]) $ do
itemBase <- getsState $ getItemBody iid
addItemToActorMaxSkills iid itemBase k aid
updRefillHP :: MonadStateWrite m => ActorId -> Int64 -> m ()
updRefillHP aid nRaw =
updateActor aid $ \b ->
let newRawHP = bhp b + nRaw
newHP = if bhp b <= 0 then newRawHP else max 0 newRawHP
n = newHP - bhp b
in b { bhp = newHP
, 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)
updTacticFaction :: MonadStateWrite m
=> FactionId -> Ability.Tactic -> Ability.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
updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m ()
updAutoFaction fid st =
updateFaction fid (\fact ->
assert (isAIFact fact == not st)
$ fact {gplayer = automatePlayer st (gplayer fact)})
updRecordKill :: MonadStateWrite m
=> ActorId -> ContentId 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 -> ContentId TileKind -> ContentId TileKind
-> m ()
updAlterTile lid p fromTile toTile = assert (fromTile /= toTile) $ do
COps{coTileSpeedup} <- getsState scops
lvl <- getLevel lid
let t = lvl `at` p
if t /= fromTile
then atomicFail "tile to alter is different than assumed"
else do
let adj ts = 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 {lexpl = lexpl lvl + delta}
updAlterGold :: MonadStateWrite m => Int -> m ()
updAlterGold delta = assert (delta /= 0) $
modifyState $ updateGold (+ delta)
updSearchTile :: MonadStateWrite m
=> ActorId -> Point -> ContentId TileKind -> m ()
updSearchTile aid p toTile = do
COps{cotile} <- getsState scops
b <- getsState $ getActorBody aid
lvl <- getLevel $ blid b
let t = lvl `at` p
if t == toTile
then atomicFail "tile already searched"
else assert (Just t == Tile.hideAs cotile toTile) $ do
updLoseTile (blid b) [(p, t)]
updSpotTile (blid b) [(p, toTile)]
updSpotTile :: MonadStateWrite m
=> LevelId -> [(Point, ContentId TileKind)] -> m ()
updSpotTile lid ts = assert (not $ null ts) $ do
COps{coTileSpeedup} <- getsState scops
let unk tileMap (p, _) = tileMap PointArray.! p == unknownId
adj tileMap = assert (all (unk tileMap) ts) $ tileMap PointArray.// ts
updateLevel lid $ updateTile adj
let f (_, t1) = when (Tile.isExplorable coTileSpeedup t1) $
updateLevel lid $ \lvl -> lvl {lseen = lseen lvl + 1}
mapM_ f ts
updLoseTile :: MonadStateWrite m
=> LevelId -> [(Point, ContentId TileKind)] -> m ()
updLoseTile lid ts = assert (not $ null ts) $ do
COps{coTileSpeedup} <- getsState scops
let matches tileMap (p, ov) = tileMap PointArray.! p == ov
tu = map (second (const unknownId)) ts
adj tileMap = assert (all (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
updSpotEntry :: MonadStateWrite m => LevelId -> [(Point, PK.PlaceEntry)] -> m ()
updSpotEntry lid ts = assert (not $ null ts) $ do
let alt en Nothing = Just en
alt en (Just oldEn) = atomicFail $ "entry already added"
`showFailure` (lid, ts, en, oldEn)
f (p, en) = EM.alter (alt en) p
upd m = foldr f m ts
updateLevel lid $ updateEntry upd
updLoseEntry :: MonadStateWrite m => LevelId -> [(Point, PK.PlaceEntry)] -> m ()
updLoseEntry lid ts = assert (not $ null ts) $ do
let alt en Nothing = error $ "entry already removed"
`showFailure` (lid, ts, en)
alt en (Just oldEn) =
assert (en == oldEn `blame` "unexpected lost entry"
`swith` (lid, ts, en, oldEn)) Nothing
f (p, en) = EM.alter (alt en) p
upd m = foldr f m ts
updateLevel lid $ updateEntry upd
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}
updDiscover :: MonadStateWrite m
=> Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord
-> m ()
updDiscover _c iid ik arItem = do
itemD <- getsState sitemD
COps{coItemSpeedup} <- getsState scops
let kmIsConst = IA.kmConst $ getKindMean ik coItemSpeedup
discoKind <- getsState sdiscoKind
let discoverAtMostAspect = do
discoAspect <- getsState sdiscoAspect
if kmIsConst || iid `EM.member` discoAspect
then atomicFail "item already fully discovered"
else discoverAspect iid arItem
case EM.lookup iid itemD of
Nothing -> atomicFail "discovered item unheard of"
Just item -> case jkind item of
IdentityObvious _ -> discoverAtMostAspect
IdentityCovered ix _ik -> case EM.lookup ix discoKind of
Just{} -> discoverAtMostAspect
Nothing -> do
discoverKind ix ik
unless kmIsConst $ discoverAspect iid arItem
resetActorMaxSkills
updCover :: Container -> ItemId -> ContentId ItemKind -> IA.AspectRecord -> m ()
updCover _c _iid _ik _arItem = undefined
updDiscoverKind :: MonadStateWrite m
=> Container -> ItemKindIx -> ContentId ItemKind -> m ()
updDiscoverKind _c ix kmKind = do
discoKind <- getsState sdiscoKind
if ix `EM.member` discoKind
then atomicFail "item kind already discovered"
else do
discoverKind ix kmKind
resetActorMaxSkills
discoverKind :: MonadStateWrite m => ItemKindIx -> ContentId ItemKind -> m ()
discoverKind ix kindId = do
let f Nothing = Just kindId
f Just{} = error $ "already discovered" `showFailure` (ix, kindId)
modifyState $ updateDiscoKind $ \discoKind1 ->
EM.alter f ix discoKind1
updCoverKind :: Container -> ItemKindIx -> ContentId ItemKind -> m ()
updCoverKind _c _ix _ik = undefined
updDiscoverAspect :: MonadStateWrite m
=> Container -> ItemId -> IA.AspectRecord -> m ()
updDiscoverAspect _c iid arItem = do
COps{coItemSpeedup} <- getsState scops
itemD <- getsState sitemD
case EM.lookup iid itemD of
Nothing -> atomicFail "discovered item unheard of"
Just item -> do
kindId <- getsState $ getItemKindIdServer item
discoAspect <- getsState sdiscoAspect
let kmIsConst = IA.kmConst $ getKindMean kindId coItemSpeedup
if kmIsConst || iid `EM.member` discoAspect
then atomicFail "item arItem already discovered"
else do
discoverAspect iid arItem
resetActorMaxSkills
discoverAspect :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()
discoverAspect iid arItem = do
let f Nothing = Just arItem
f Just{} = error $ "already discovered" `showFailure` (iid, arItem)
modifyState $ updateDiscoAspect $ \discoAspect1 ->
EM.alter f iid discoAspect1
updCoverAspect :: Container -> ItemId -> IA.AspectRecord -> m ()
updCoverAspect _c _iid _arItem = undefined
updDiscoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()
updDiscoverServer iid arItem =
modifyState $ updateDiscoAspect $ \discoAspect1 ->
EM.insert iid arItem discoAspect1
updCoverServer :: MonadStateWrite m => ItemId -> IA.AspectRecord -> m ()
updCoverServer iid arItem =
modifyState $ updateDiscoAspect $ \discoAspect1 ->
assert (discoAspect1 EM.! iid == arItem)
$ EM.delete iid discoAspect1
updRestart :: MonadStateWrite m => State -> m ()
updRestart = putState
updRestartServer :: MonadStateWrite m => State -> m ()
updRestartServer = putState
updResumeServer :: MonadStateWrite m => State -> m ()
updResumeServer = putState