{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Server.HandleEffectM
( applyItem, meleeEffectAndDestroy, effectAndDestroy, itemEffectEmbedded
, dropCStoreItem, highestImpression, dominateFidSfx, pickDroppable
, refillHP, cutCalm
#ifdef EXPOSE_INTERNAL
, UseResult(..)
, applyMeleeDamage, imperishableKit, itemEffectDisco, effectSem
, effectBurn, effectExplode, effectRefillHP, effectRefillCalm
, effectDominate, dominateFid, effectImpress, effectSummon
, effectAscend, findStairExit, switchLevels1, switchLevels2, effectEscape
, effectParalyze, effectInsertMove, effectTeleport, effectCreateItem
, effectDropItem, allGroupItems, effectPolyItem, effectIdentify, identifyIid
, effectDetect, effectDetectX
, effectSendFlying, sendFlyingVector, effectDropBestWeapon
, effectActivateInv, effectTransformContainer, effectApplyPerfume, effectOneOf
, effectRecharging, effectTemporary, effectComposite
#endif
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import Data.Bits (xor)
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified Data.HashMap.Strict as HM
import Data.Int (Int64)
import Data.Key (mapWithKeyM_)
import qualified Data.Ord as Ord
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import qualified Game.LambdaHack.Common.Dice as Dice
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.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.ReqFailure
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 qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Server.CommonM
import Game.LambdaHack.Server.ItemM
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.PeriodicM
import Game.LambdaHack.Server.ServerOptions
import Game.LambdaHack.Server.State
data UseResult = UseDud | UseId | UseUp
deriving (Eq, Ord)
applyItem :: MonadServerAtomic m => ActorId -> ItemId -> CStore -> m ()
applyItem aid iid cstore = do
execSfxAtomic $ SfxApply aid iid cstore
let c = CActor aid cstore
meleeEffectAndDestroy aid aid iid c
applyMeleeDamage :: MonadServerAtomic m
=> ActorId -> ActorId -> ItemId -> m Bool
applyMeleeDamage source target iid = do
itemKind <- getsState $ getIidKindServer iid
if IK.idamage itemKind == 0 then return False else do
sb <- getsState $ getActorBody source
hurtMult <- getsState $ armorHurtBonus source target
totalDepth <- getsState stotalDepth
Level{ldepth} <- getLevel (blid sb)
dmg <- rndToAction $ castDice ldepth totalDepth $ IK.idamage itemKind
let rawDeltaHP = fromIntegral hurtMult * xM dmg `divUp` 100
speedDeltaHP = case btrajectory sb of
Just (_, speed) -> - modifyDamageBySpeed rawDeltaHP speed
Nothing -> - rawDeltaHP
if speedDeltaHP < 0 then do
refillHP source target speedDeltaHP
return True
else return False
refillHP :: MonadServerAtomic m => ActorId -> ActorId -> Int64 -> m ()
refillHP source target speedDeltaHP = assert (speedDeltaHP /= 0) $ do
tbOld <- getsState $ getActorBody target
ar <- getsState $ getActorAspect target
let serious = speedDeltaHP < minusM && source /= target && not (bproj tbOld)
hpMax = IA.aMaxHP ar
deltaHP0 | serious =
min speedDeltaHP (xM hpMax - bhp tbOld)
| otherwise = speedDeltaHP
deltaHP = if | deltaHP0 > 0 && bhp tbOld > xM 999 ->
tenthM
| deltaHP0 < 0 && bhp tbOld < - xM 999 ->
-tenthM
| otherwise -> deltaHP0
execUpdAtomic $ UpdRefillHP target deltaHP
when serious $ cutCalm target
tb <- getsState $ getActorBody target
when (bhp tb <= 0 && bhp tbOld > 0) $ do
mleader <- getsState $ gleader . (EM.! bfid tb) . sfactionD
when (Just target == mleader) $ do
actorD <- getsState sactorD
let ours (_, b) = bfid b == bfid tb && not (bproj b) && bhp b > 0
positive = filter ours $ EM.assocs actorD
onLevel <- getsState $ fidActorRegularIds (bfid tb) (blid tb)
case onLevel ++ map fst positive of
[] -> return ()
aid : _ -> execUpdAtomic $ UpdLeadFaction (bfid tb) mleader $ Just aid
meleeEffectAndDestroy :: MonadServerAtomic m
=> ActorId -> ActorId -> ItemId -> Container -> m ()
meleeEffectAndDestroy source target iid c = do
meleePerformed <- applyMeleeDamage source target iid
bag <- getsState $ getContainerBag c
case iid `EM.lookup` bag of
Nothing -> error $ "" `showFailure` (source, target, iid, c)
Just kit -> do
itemFull <- getsState $ itemToFull iid
let IK.ItemKind{IK.ieffects} = itemKind itemFull
effectAndDestroy meleePerformed source target iid c False ieffects
(itemFull, kit)
effectAndDestroy :: MonadServerAtomic m
=> Bool -> ActorId -> ActorId -> ItemId -> Container -> Bool
-> [IK.Effect] -> ItemFullKit
-> m ()
effectAndDestroy meleePerformed _ _ iid container periodic []
(itemFull@ItemFull{itemBase}, kit@(_, itemTimer)) =
if meleePerformed then do
let (imperishable, kit2) =
imperishableKit True periodic itemTimer itemFull kit
unless imperishable $
execUpdAtomic $ UpdLoseItem False iid itemBase kit2 container
else return ()
effectAndDestroy meleePerformed source target iid container periodic effs
( itemFull@ItemFull{itemBase, itemDisco, itemKind}
, kit@(itemK, itemTimer) ) = do
let timeout = IA.aTimeout $ itemAspect itemDisco
permanent = let tmpEffect :: IK.Effect -> Bool
tmpEffect IK.Temporary{} = True
tmpEffect (IK.Recharging IK.Temporary{}) = True
tmpEffect (IK.OnSmash IK.Temporary{}) = True
tmpEffect _ = False
in not $ any tmpEffect effs
lid <- getsState $ lidFromC container
localTime <- getsState $ getLocalTime lid
let it1 = let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout
charging startT = timeShift startT timeoutTurns > localTime
in filter charging itemTimer
len = length it1
recharged = len < itemK
it2 = if timeout /= 0 && recharged
then if periodic && not permanent
then replicate (itemK - length it1) localTime ++ it1
else localTime : it1
else itemTimer
!_A = assert (len <= itemK `blame` (source, target, iid, container)) ()
unless (itemTimer == it2) $
execUpdAtomic $ UpdTimeItem iid container itemTimer it2
when (not periodic || recharged || meleePerformed) $ do
let (imperishable, kit2) =
imperishableKit permanent periodic it2 itemFull kit
unless imperishable $
execUpdAtomic $ UpdLoseItem False iid itemBase kit2 container
triggeredEffect <- itemEffectDisco source target iid itemKind container
recharged periodic effs
let triggered = if meleePerformed then UseUp else triggeredEffect
sb <- getsState $ getActorBody source
unless (triggered == UseUp
|| periodic
|| bproj sb
) $
execSfxAtomic $ SfxMsgFid (bfid sb) $
if any IK.forApplyEffect effs
then SfxFizzles
else SfxNothingHappens
unless (triggered == UseUp || imperishable) $
execUpdAtomic $ UpdSpotItem False iid itemBase kit2 container
imperishableKit :: Bool -> Bool -> ItemTimer -> ItemFull -> ItemQuant
-> (Bool, ItemQuant)
imperishableKit permanent periodic it2 ItemFull{itemKind} (itemK, _) =
let fragile = IK.Fragile `elem` IK.ifeature itemKind
durable = IK.Durable `elem` IK.ifeature itemKind
imperishable = durable && not fragile || periodic && permanent
kit = if permanent || periodic then (1, take 1 it2) else (itemK, it2)
in (imperishable, kit)
itemEffectEmbedded :: MonadServerAtomic m
=> ActorId -> LevelId -> Point -> ItemId -> m ()
itemEffectEmbedded aid lid tpos iid = do
let c = CEmbed lid tpos
meleeEffectAndDestroy aid aid iid c
itemEffectDisco :: MonadServerAtomic m
=> ActorId -> ActorId -> ItemId -> ItemKind -> Container
-> Bool -> Bool -> [IK.Effect]
-> m UseResult
itemEffectDisco source target iid itemKind c recharged periodic effs = do
urs <- mapM (effectSem source target iid c recharged periodic) effs
let ur = case urs of
[] -> UseDud
_ -> maximum urs
when (ur >= UseId && not (IK.onlyMinorEffects itemKind)) $ do
kindId <- getsState $ getIidKindIdServer iid
seed <- getsServer $ (EM.! iid) . sitemSeedD
execUpdAtomic $ UpdDiscover c iid kindId seed
return ur
effectSem :: MonadServerAtomic m
=> ActorId -> ActorId -> ItemId -> Container -> Bool -> Bool
-> IK.Effect
-> m UseResult
effectSem source target iid c recharged periodic effect = do
let recursiveCall = effectSem source target iid c recharged periodic
sb <- getsState $ getActorBody source
pos <- getsState $ posFromC c
let execSfx = execSfxAtomic $ SfxEffect (bfid sb) target effect 0
case effect of
IK.Burn nDm -> effectBurn nDm source target
IK.Explode t -> effectExplode execSfx t target
IK.RefillHP p -> effectRefillHP p source target
IK.RefillCalm p -> effectRefillCalm execSfx p source target
IK.Dominate -> effectDominate source target
IK.Impress -> effectImpress recursiveCall execSfx source target
IK.Summon grp nDm -> effectSummon grp nDm iid source target periodic
IK.Ascend p -> effectAscend recursiveCall execSfx p source target pos
IK.Escape{} -> effectEscape source target
IK.Paralyze nDm -> effectParalyze execSfx nDm source target
IK.InsertMove nDm -> effectInsertMove execSfx nDm source target
IK.Teleport nDm -> effectTeleport execSfx nDm source target
IK.CreateItem store grp tim ->
effectCreateItem (Just $ bfid sb) Nothing target store grp tim
IK.DropItem n k store grp -> effectDropItem execSfx n k store grp target
IK.PolyItem -> effectPolyItem execSfx source target
IK.Identify -> effectIdentify execSfx iid source target
IK.Detect d radius -> effectDetect execSfx d radius target pos
IK.SendFlying tmod ->
effectSendFlying execSfx tmod source target Nothing
IK.PushActor tmod ->
effectSendFlying execSfx tmod source target (Just True)
IK.PullActor tmod ->
effectSendFlying execSfx tmod source target (Just False)
IK.DropBestWeapon -> effectDropBestWeapon execSfx target
IK.ActivateInv symbol -> effectActivateInv execSfx target symbol
IK.ApplyPerfume -> effectApplyPerfume execSfx target
IK.OneOf l -> effectOneOf recursiveCall l
IK.OnSmash _ -> return UseDud
IK.Recharging e -> effectRecharging recursiveCall e recharged
IK.Temporary _ -> effectTemporary execSfx source iid c
IK.Composite l -> effectComposite recursiveCall l
effectBurn :: MonadServerAtomic m
=> Dice.Dice -> ActorId -> ActorId -> m UseResult
effectBurn nDm source target = do
tb <- getsState $ getActorBody target
totalDepth <- getsState stotalDepth
Level{ldepth} <- getLevel (blid tb)
n0 <- rndToAction $ castDice ldepth totalDepth nDm
let n = max 1 n0
deltaHP = - xM n
sb <- getsState $ getActorBody source
let reportedEffect = IK.Burn $ Dice.intToDice n
execSfxAtomic $ SfxEffect (bfid sb) target reportedEffect deltaHP
refillHP source target deltaHP
return UseUp
effectExplode :: MonadServerAtomic m
=> m () -> GroupName ItemKind -> ActorId -> m UseResult
effectExplode execSfx cgroup target = do
execSfx
tb <- getsState $ getActorBody target
let itemFreq = [(cgroup, 1)]
container = CActor target COrgan
m2 <- rollAndRegisterItem (blid tb) itemFreq container False Nothing
let (iid, ((ItemFull{itemBase}, (itemK, _)), _)) =
fromMaybe (error $ "" `showFailure` cgroup) m2
Point x y = bpos tb
semirandom = case jkind itemBase of
IdentityObvious ik -> fromEnum ik
IdentityCovered ix _ -> fromEnum ix
projectN k100 (n, _) = do
let veryrandom = (k100 `xor` (semirandom + n)) `mod` 5
fuzz = 5 + veryrandom
k | itemK >= 8 && n < 4 = 0
| n < 16 && n >= 12 = 12
| n < 12 && n >= 8 = 8
| n < 8 && n >= 4 = 4
| otherwise = min n 16
psDir4 =
[ Point (x - 12) (y + 12)
, Point (x + 12) (y + 12)
, Point (x - 12) (y - 12)
, Point (x + 12) (y - 12) ]
psDir8 =
[ Point (x - 12) y
, Point (x + 12) y
, Point x (y + 12)
, Point x (y - 12) ]
psFuzz =
[ Point (x - 12) $ y + fuzz
, Point (x + 12) $ y + fuzz
, Point (x - 12) $ y - fuzz
, Point (x + 12) $ y - fuzz
, flip Point (y - 12) $ x + fuzz
, flip Point (y + 12) $ x + fuzz
, flip Point (y - 12) $ x - fuzz
, flip Point (y + 12) $ x - fuzz ]
semireverse = if semirandom `mod` 2 == 0 then id else reverse
ps = take k $ concat $
semireverse
[ zip (repeat True)
$ take 4 (drop ((k100 + itemK + fuzz) `mod` 4) $ cycle psDir4)
, zip (repeat False)
$ take 4 (drop ((k100 + n) `mod` 4) $ cycle psDir8) ]
++ [zip (repeat True)
$ take 8 (drop ((k100 + fuzz) `mod` 8) $ cycle psFuzz)]
forM_ ps $ \(centerRaw, tpxy) -> do
let req = ReqProject tpxy veryrandom iid COrgan
center = centerRaw && itemK >= 8
mfail <- projectFail target tpxy veryrandom center iid COrgan True
case mfail of
Nothing -> return ()
Just ProjectBlockTerrain -> return ()
Just ProjectBlockActor | not $ bproj tb -> return ()
Just failMsg -> execFailure target req failMsg
tryFlying 0 = return ()
tryFlying k100 = do
bag2 <- getsState $ borgan . getActorBody target
let mn2 = EM.lookup iid bag2
case mn2 of
Nothing -> return ()
Just n2 -> do
projectN k100 n2
tryFlying $ k100 - 1
tryFlying 100
bag3 <- getsState $ borgan . getActorBody target
let mn3 = EM.lookup iid bag3
maybe (return ()) (\kit -> execUpdAtomic
$ UpdLoseItem False iid itemBase kit container) mn3
return UseUp
effectRefillHP :: MonadServerAtomic m
=> Int -> ActorId -> ActorId -> m UseResult
effectRefillHP power0 source target = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
curChalSer <- getsServer $ scurChalSer . soptions
fact <- getsState $ (EM.! bfid tb) . sfactionD
let power = if power0 <= -1 then power0 else max 1 power0
deltaHP = xM power
if | cfish curChalSer && deltaHP > 0
&& fhasUI (gplayer fact) && bfid sb /= bfid tb -> do
execSfxAtomic $ SfxMsgFid (bfid tb) SfxColdFish
return UseId
| otherwise -> do
let reportedEffect = IK.RefillHP power
execSfxAtomic $ SfxEffect (bfid sb) target reportedEffect deltaHP
refillHP source target deltaHP
return UseUp
cutCalm :: MonadServerAtomic m => ActorId -> m ()
cutCalm target = do
tb <- getsState $ getActorBody target
ar <- getsState $ getActorAspect target
let upperBound = if hpTooLow tb ar
then 0
else xM $ IA.aMaxCalm ar
deltaCalm = min minusM1 (upperBound - bcalm tb)
udpateCalm target deltaCalm
effectRefillCalm :: MonadServerAtomic m
=> m () -> Int -> ActorId -> ActorId -> m UseResult
effectRefillCalm execSfx power0 source target = do
tb <- getsState $ getActorBody target
ar <- getsState $ getActorAspect target
let power = if power0 <= -1 then power0 else max 1 power0
rawDeltaCalm = xM power
calmMax = IA.aMaxCalm ar
serious = rawDeltaCalm < minusM && source /= target && not (bproj tb)
deltaCalm0 | serious =
min rawDeltaCalm (xM calmMax - bcalm tb)
| otherwise = rawDeltaCalm
deltaCalm = if | deltaCalm0 > 0 && bcalm tb > xM 999 ->
tenthM
| deltaCalm0 < 0 && bcalm tb < - xM 999 ->
-tenthM
| otherwise -> deltaCalm0
execSfx
udpateCalm target deltaCalm
return UseUp
effectDominate :: MonadServerAtomic m => ActorId -> ActorId -> m UseResult
effectDominate source target = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
if | bproj tb -> return UseDud
| bfid tb == bfid sb -> return UseDud
| otherwise -> do
fact <- getsState $ (EM.! bfid tb) . sfactionD
hiImpression <- highestImpression target
permitted <-
if fleaderMode (gplayer fact) == LeaderNull
&& hiImpression /= Just (bfid sb)
then do
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxUnimpressed target
return False
else return True
if permitted then do
b <- dominateFidSfx target (bfid sb)
return $! if b then UseUp else UseDud
else return UseDud
highestImpression :: MonadServerAtomic m => ActorId -> m (Maybe FactionId)
highestImpression target = do
tb <- getsState $ getActorBody target
getKind <- getsState $ flip getIidKindServer
getItem <- getsState $ flip getItemBody
let isImpression iid =
maybe False (> 0) $ lookup "impressed" $ IK.ifreq $ getKind iid
impressions = EM.filterWithKey (\iid _ -> isImpression iid) $ borgan tb
f (_, (k, _)) = k
maxImpression = maximumBy (Ord.comparing f) $ EM.assocs impressions
if EM.null impressions
then return Nothing
else case jfid $ getItem $ fst maxImpression of
Nothing -> return Nothing
Just fid -> assert (fid /= bfid tb) $ return $ Just fid
dominateFidSfx :: MonadServerAtomic m => ActorId -> FactionId -> m Bool
dominateFidSfx target fid = do
tb <- getsState $ getActorBody target
canTra <- getsState $ canTraverse target
if canTra && not (bproj tb) && bhp tb > 0 then do
let execSfx = execSfxAtomic $ SfxEffect fid target IK.Dominate 0
execSfx
gameOver <- dominateFid fid target
unless gameOver
execSfx
return True
else
return False
dominateFid :: MonadServerAtomic m => FactionId -> ActorId -> m Bool
dominateFid fid target = do
tb0 <- getsState $ getActorBody target
deduceKilled target
electLeader (bfid tb0) (blid tb0) target
fact <- getsState $ (EM.! bfid tb0) . sfactionD
when (isNothing $ gleader fact) $ moveStores False target CSha CInv
tb <- getsState $ getActorBody target
ais <- getsState $ getCarriedAssocsAndTrunk tb
ar <- getsState $ getActorAspect target
getKind <- getsState $ flip getIidKindServer
let isImpression iid =
maybe False (> 0) $ lookup "impressed" $ IK.ifreq $ getKind iid
dropAllImpressions = EM.filterWithKey (\iid _ -> not $ isImpression iid)
borganNoImpression = dropAllImpressions $ borgan tb
btime <-
getsServer $ (EM.! target) . (EM.! blid tb) . (EM.! bfid tb) . sactorTime
execUpdAtomic $ UpdLoseActor target tb ais
let bNew = tb { bfid = fid
, bcalm = max (xM 10) $ xM (IA.aMaxCalm ar) `div` 2
, bhp = min (xM $ IA.aMaxHP ar) $ bhp tb + xM 10
, borgan = borganNoImpression}
aisNew <- getsState $ getCarriedAssocsAndTrunk bNew
modifyServer $ \ser ->
ser {sactorTime = updateActorTime fid (blid tb) target btime
$ sactorTime ser}
execUpdAtomic $ UpdSpotActor target bNew aisNew
factionD <- getsState sfactionD
let inGame fact2 = case gquit fact2 of
Nothing -> True
Just Status{stOutcome=Camping} -> True
_ -> False
gameOver = not $ any inGame $ EM.elems factionD
if gameOver
then return True
else do
void $ effectCreateItem (Just $ bfid tb) (Just 10) target COrgan
"impressed" IK.timerNone
getKindId <- getsState $ flip getIidKindIdServer
let discoverIf (iid, cstore) = do
let itemKindId = getKindId iid
c = CActor target cstore
discoverIfMinorEffects c iid itemKindId
aic = (btrunk tb, if bproj tb then CEqp else COrgan)
: filter ((/= btrunk tb) . fst) (getCarriedIidCStore tb)
mapM_ discoverIf aic
supplantLeader fid target
return False
effectImpress :: MonadServerAtomic m
=> (IK.Effect -> m UseResult) -> m () -> ActorId -> ActorId
-> m UseResult
effectImpress recursiveCall execSfx source target = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
if | bproj tb -> return UseDud
| bfid tb == bfid sb ->
recursiveCall $ IK.DropItem 1 1 COrgan "impressed"
| otherwise -> do
canTra <- getsState $ canTraverse target
if canTra then do
unless (bhp tb <= 0)
execSfx
effectCreateItem (Just $ bfid sb) (Just 1) target COrgan
"impressed" IK.timerNone
else return UseDud
effectSummon :: MonadServerAtomic m
=> GroupName ItemKind -> Dice.Dice -> ItemId
-> ActorId -> ActorId -> Bool
-> m UseResult
effectSummon grp nDm iid source target periodic = do
COps{coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
actorAspect <- getsState sactorAspect
totalDepth <- getsState stotalDepth
Level{ldepth} <- getLevel (blid tb)
itemKind <- getsState $ getIidKindServer iid
power0 <- rndToAction $ castDice ldepth totalDepth nDm
let power = max power0 1
effect = IK.Summon grp $ Dice.intToDice power
execSfx = execSfxAtomic $ SfxEffect (bfid sb) source effect 0
sar = actorAspect EM.! source
tar = actorAspect EM.! target
durable = IK.Durable `elem` IK.ifeature itemKind
deltaCalm = - xM 30
if | (periodic || durable) && not (bproj sb)
&& (bcalm sb < - deltaCalm || not (calmEnough sb sar)) -> do
unless (bproj sb) $
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxSummonLackCalm source
return UseId
| otherwise -> do
execSfx
unless (bproj sb) $ udpateCalm source deltaCalm
let validTile t = not $ Tile.isNoActor coTileSpeedup t
ps <- getsState $ nearbyFreePoints validTile (bpos tb) (blid tb)
localTime <- getsState $ getLocalTime (blid tb)
let actorTurn = ticksPerMeter $ momentarySpeed tb tar
targetTime = timeShift localTime actorTurn
afterTime = timeShift targetTime $ Delta timeClip
bs <- forM (take power ps) $ \p -> do
maid <- addAnyActor True [(grp, 1)] (blid tb) afterTime (Just p)
case maid of
Nothing -> return False
Just aid -> do
b <- getsState $ getActorBody aid
mleader <- getsState $ gleader . (EM.! bfid b) . sfactionD
when (isNothing mleader) $ supplantLeader (bfid b) aid
return True
return $! if or bs then UseUp else UseId
effectAscend :: MonadServerAtomic m
=> (IK.Effect -> m UseResult)
-> m () -> Bool -> ActorId -> ActorId -> Point
-> m UseResult
effectAscend recursiveCall execSfx up source target pos = do
b1 <- getsState $ getActorBody target
let lid1 = blid b1
(lid2, pos2) <- getsState $ whereTo lid1 pos (Just up) . sdungeon
sb <- getsState $ getActorBody source
if | braced b1 -> do
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target
return UseId
| lid2 == lid1 && pos2 == pos -> do
execSfxAtomic $ SfxMsgFid (bfid sb) SfxLevelNoMore
recursiveCall $ IK.Teleport 30
| otherwise -> do
execSfx
btime_bOld <- getsServer $ (EM.! target) . (EM.! lid1)
. (EM.! bfid b1) . sactorTime
pos3 <- findStairExit (bfid sb) up lid2 pos2
let switch1 = void $ switchLevels1 (target, b1)
switch2 = do
let mlead = if bproj b1 then Nothing else Just target
switchLevels2 lid2 pos3 (target, b1) btime_bOld mlead
inhabitants <- getsState $ posToAssocs pos3 lid2
case inhabitants of
[] -> do
switch1
switch2
(_, b2) : _ -> do
execSfxAtomic $ SfxMsgFid (bfid b2) SfxLevelPushed
switch1
let moveInh inh = do
btime_inh <-
getsServer $ (EM.! fst inh) . (EM.! lid2)
. (EM.! bfid (snd inh)) . sactorTime
inhMLead <- switchLevels1 inh
switchLevels2 lid1 (bpos b1) inh btime_inh inhMLead
mapM_ moveInh inhabitants
switch2
return UseUp
findStairExit :: MonadStateRead m
=> FactionId -> Bool -> LevelId -> Point -> m Point
findStairExit side moveUp lid pos = do
COps{coTileSpeedup} <- getsState scops
fact <- getsState $ (EM.! side) . sfactionD
lvl <- getLevel lid
let defLanding = uncurry Vector $ if moveUp then (1, 0) else (-1, 0)
center = uncurry Vector $ if moveUp then (-1, 0) else (1, 0)
(mvs2, mvs1) = break (== defLanding) moves
mvs = center : filter (/= center) (mvs1 ++ mvs2)
ps = filter (Tile.isWalkable coTileSpeedup . (lvl `at`))
$ map (shift pos) mvs
posOcc :: State -> Int -> Point -> Bool
posOcc s k p = case posToAssocs p lid s of
[] -> k == 0
(_, b) : _ | bproj b -> k == 3
(_, b) : _ | isFoe side fact (bfid b) -> k == 1
_ -> k == 2
unocc <- getsState posOcc
case concatMap (\k -> filter (unocc k) ps) [0..3] of
[] -> error $ "" `showFailure` ps
posRes : _ -> return posRes
switchLevels1 :: MonadServerAtomic m => (ActorId, Actor) -> m (Maybe ActorId)
switchLevels1 (aid, bOld) = do
let side = bfid bOld
mleader <- getsState $ gleader . (EM.! side) . sfactionD
mlead <-
if not (bproj bOld) && isJust mleader then do
execUpdAtomic $ UpdLeadFaction side mleader Nothing
return mleader
else return Nothing
ais <- getsState $ getCarriedAssocsAndTrunk bOld
execUpdAtomic $ UpdLoseActor aid bOld ais
return mlead
switchLevels2 ::MonadServerAtomic m
=> LevelId -> Point -> (ActorId, Actor) -> Time -> Maybe ActorId
-> m ()
switchLevels2 lidNew posNew (aid, bOld) btime_bOld mlead = do
let lidOld = blid bOld
side = bfid bOld
let !_A = assert (lidNew /= lidOld `blame` "stairs looped" `swith` lidNew) ()
timeOld <- getsState $ getLocalTime lidOld
timeLastActive <- getsState $ getLocalTime lidNew
let delta = timeLastActive `timeDeltaToFrom` timeOld
shiftByDelta = (`timeShift` delta)
computeNewTimeout :: ItemQuant -> ItemQuant
computeNewTimeout (k, it) = (k, map shiftByDelta it)
rebaseTimeout :: ItemBag -> ItemBag
rebaseTimeout = EM.map computeNewTimeout
bNew = bOld { blid = lidNew
, bpos = posNew
, boldpos = Just posNew
, borgan = rebaseTimeout $ borgan bOld
, beqp = rebaseTimeout $ beqp bOld
, binv = rebaseTimeout $ binv bOld }
ais <- getsState $ getCarriedAssocsAndTrunk bOld
let btime = shiftByDelta btime_bOld
modifyServer $ \ser ->
ser {sactorTime = updateActorTime (bfid bNew) lidNew aid btime
$ sactorTime ser}
execUpdAtomic $ UpdCreateActor aid bNew ais
case mlead of
Nothing -> return ()
Just leader -> supplantLeader side leader
effectEscape :: MonadServerAtomic m => ActorId -> ActorId -> m UseResult
effectEscape source target = do
sb <- getsState $ getActorBody source
b <- getsState $ getActorBody target
let fid = bfid b
fact <- getsState $ (EM.! fid) . sfactionD
if | bproj b ->
return UseDud
| not (fcanEscape $ gplayer fact) -> do
execSfxAtomic $ SfxMsgFid (bfid sb) SfxEscapeImpossible
return UseId
| otherwise -> do
deduceQuits (bfid b) $ Status Escape (fromEnum $ blid b) Nothing
return UseUp
effectParalyze :: MonadServerAtomic m
=> m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult
effectParalyze execSfx nDm source target = do
tb <- getsState $ getActorBody target
totalDepth <- getsState stotalDepth
Level{ldepth} <- getLevel (blid tb)
actorStasis <- getsServer sactorStasis
power0 <- rndToAction $ castDice ldepth totalDepth nDm
let power = max power0 1
t = timeDeltaScale (Delta timeClip) power
if | bproj tb -> return UseDud
| ES.member target actorStasis -> do
sb <- getsState $ getActorBody source
execSfxAtomic $ SfxMsgFid (bfid sb) SfxStasisProtects
return UseId
| otherwise -> do
execSfx
modifyServer $ \ser ->
ser { sactorTime = ageActor (bfid tb) (blid tb) target t
$ sactorTime ser
, sactorStasis = ES.insert target (sactorStasis ser) }
return UseUp
effectInsertMove :: MonadServerAtomic m
=> m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult
effectInsertMove execSfx nDm source target = do
tb <- getsState $ getActorBody target
ar <- getsState $ getActorAspect target
totalDepth <- getsState stotalDepth
Level{ldepth} <- getLevel (blid tb)
actorStasis <- getsServer sactorStasis
power0 <- rndToAction $ castDice ldepth totalDepth nDm
let power = max power0 1
actorTurn = ticksPerMeter $ momentarySpeed tb ar
t = timeDeltaScale actorTurn (-power)
if | ES.member target actorStasis -> do
sb <- getsState $ getActorBody source
execSfxAtomic $ SfxMsgFid (bfid sb) SfxStasisProtects
return UseId
| otherwise -> do
execSfx
modifyServer $ \ser ->
ser { sactorTime = ageActor (bfid tb) (blid tb) target t
$ sactorTime ser
, sactorStasis = ES.insert target (sactorStasis ser) }
return UseUp
effectTeleport :: MonadServerAtomic m
=> m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult
effectTeleport execSfx nDm source target = do
COps{coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
totalDepth <- getsState stotalDepth
lvl@Level{ldepth, ltile} <- getLevel (blid tb)
range <- rndToAction $ castDice ldepth totalDepth nDm
let spos = bpos tb
dMinMax delta pos =
let d = chessDist spos pos
in d >= range - delta && d <= range + delta
dist delta pos _ = dMinMax delta pos
tpos <- rndToAction $ findPosTry 200 ltile
(\p t -> Tile.isWalkable coTileSpeedup t
&& (not (dMinMax 9 p)
|| not (Tile.isNoActor coTileSpeedup t)
&& null (posToAidsLvl p lvl)))
[ dist 1
, dist $ 1 + range `div` 9
, dist $ 1 + range `div` 7
, dist $ 1 + range `div` 5
, dist 5
, dist 7
, dist 9
]
if | braced tb -> do
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target
return UseId
| not (dMinMax 9 tpos) -> do
execSfxAtomic $ SfxMsgFid (bfid sb) SfxTransImpossible
return UseId
| otherwise -> do
execSfx
execUpdAtomic $ UpdMoveActor target spos tpos
return UseUp
effectCreateItem :: MonadServerAtomic m
=> Maybe FactionId -> Maybe Int -> ActorId -> CStore
-> GroupName ItemKind -> IK.TimerDice
-> m UseResult
effectCreateItem jfidRaw mcount target store grp tim = do
tb <- getsState $ getActorBody target
totalDepth <- getsState stotalDepth
Level{ldepth} <- getLevel (blid tb)
let fscale unit nDm = do
k0 <- rndToAction $ castDice ldepth totalDepth nDm
let k = max 1 k0
return $! timeDeltaScale unit k
fgame = fscale (Delta timeTurn)
factor nDm = do
ar <- getsState $ getActorAspect target
let actorTurn =
timeDeltaPercent (ticksPerMeter $ momentarySpeed tb ar) 101
fscale actorTurn nDm
delta <- IK.foldTimer (return $ Delta timeZero) fgame factor tim
let c = CActor target store
bagBefore <- getsState $ getBodyStoreBag tb store
let litemFreq = [(grp, 1)]
m4 <- rollItem 0 (blid tb) litemFreq
let (itemKnownRaw, (itemFullRaw, kitRaw), seed, _) =
fromMaybe (error $ "" `showFailure` (blid tb, litemFreq, c)) m4
jfid = if store == COrgan && not (IK.isTimerNone tim)
|| grp == "impressed"
then jfidRaw
else Nothing
(itemKnown, itemFull) =
let (kindIx, ar, _) = itemKnownRaw
in ( (kindIx, ar, jfid)
, itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}} )
kitNew = case mcount of
Just itemK -> (itemK, [])
Nothing -> kitRaw
itemRev <- getsServer sitemRev
let mquant = case HM.lookup itemKnown itemRev of
Nothing -> Nothing
Just iid -> (iid,) <$> iid `EM.lookup` bagBefore
case mquant of
Just (iid, (_, afterIt@(timer : rest))) | not $ IK.isTimerNone tim -> do
let newIt = timer `timeShift` delta : rest
if afterIt /= newIt then do
execUpdAtomic $ UpdTimeItem iid c afterIt newIt
execSfxAtomic $ SfxMsgFid (bfid tb)
$ SfxTimerExtended (blid tb) target iid store
return UseUp
else return UseDud
_ -> do
iid <- registerItem (itemFull, kitNew) itemKnown seed c True
when (store /= CGround) $
discoverIfMinorEffects c iid (itemKindId itemFull)
when (not $ IK.isTimerNone tim) $ do
tb2 <- getsState $ getActorBody target
bagAfter <- getsState $ getBodyStoreBag tb2 store
localTime <- getsState $ getLocalTime (blid tb)
let newTimer = localTime `timeShift` delta
(afterK, afterIt) =
fromMaybe (error $ "" `showFailure` (iid, bagAfter, c))
(iid `EM.lookup` bagAfter)
newIt = replicate afterK newTimer
when (afterIt /= newIt) $
execUpdAtomic $ UpdTimeItem iid c afterIt newIt
return UseUp
effectDropItem :: MonadServerAtomic m
=> m () -> Int -> Int -> CStore -> GroupName ItemKind -> ActorId
-> m UseResult
effectDropItem execSfx ngroup kcopy store grp target = do
b <- getsState $ getActorBody target
is <- allGroupItems store grp target
if null is
then return UseDud
else do
unless (store == COrgan) execSfx
mapM_ (uncurry (dropCStoreItem True store target b kcopy)) $ take ngroup is
return UseUp
allGroupItems :: MonadServerAtomic m
=> CStore -> GroupName ItemKind -> ActorId
-> m [(ItemId, ItemQuant)]
allGroupItems store grp target = do
b <- getsState $ getActorBody target
getKind <- getsState $ flip getIidKindServer
let hasGroup (iid, _) =
maybe False (> 0) $ lookup grp $ IK.ifreq $ getKind iid
assocsCStore <- getsState $ EM.assocs . getBodyStoreBag b store
return $! filter hasGroup assocsCStore
dropCStoreItem :: MonadServerAtomic m
=> Bool -> CStore -> ActorId -> Actor -> Int
-> ItemId -> ItemQuant
-> m ()
dropCStoreItem verbose store aid b kMax iid kit@(k, _) = do
itemFull@ItemFull{itemKind} <- getsState $ itemToFull iid
let c = CActor aid store
fragile = IK.Fragile `elem` IK.ifeature itemKind
durable = IK.Durable `elem` IK.ifeature itemKind
isDestroyed = bproj b && (bhp b <= 0 && not durable || fragile)
|| fragile && durable
if isDestroyed then do
let effs = IK.strengthOnSmash itemKind
effectAndDestroy False aid aid iid c False effs (itemFull, kit)
else do
cDrop <- pickDroppable aid b
mvCmd <- generalMoveItem verbose iid (min kMax k) (CActor aid store) cDrop
mapM_ execUpdAtomic mvCmd
pickDroppable :: MonadStateRead m => ActorId -> Actor -> m Container
pickDroppable aid b = do
COps{coTileSpeedup} <- getsState scops
lvl <- getLevel (blid b)
let validTile t = not $ Tile.isNoItem coTileSpeedup t
if validTile $ lvl `at` bpos b
then return $! CActor aid CGround
else do
ps <- getsState $ nearbyFreePoints validTile (bpos b) (blid b)
return $! case filter (adjacent $ bpos b) $ take 8 ps of
[] -> CActor aid CGround
pos : _ -> CFloor (blid b) pos
effectPolyItem :: MonadServerAtomic m
=> m () -> ActorId -> ActorId -> m UseResult
effectPolyItem execSfx source target = do
sb <- getsState $ getActorBody source
let cstore = CGround
kitAss <- getsState $ kitAssocs target [cstore]
case kitAss of
[] -> do
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxPurposeNothing cstore
return UseId
(iid, ( ItemFull{itemBase, itemKindId, itemKind}
, (itemK, itemTimer) )) : _ -> do
let maxCount = Dice.maxDice $ IK.icount itemKind
if | IK.Unique `elem` IK.ifeature itemKind -> do
execSfxAtomic $ SfxMsgFid (bfid sb) SfxPurposeUnique
return UseId
| maybe True (<= 0) $ lookup "common item" $ IK.ifreq itemKind -> do
execSfxAtomic $ SfxMsgFid (bfid sb) SfxPurposeNotCommon
return UseId
| itemK < maxCount -> do
execSfxAtomic $ SfxMsgFid (bfid sb)
$ SfxPurposeTooFew maxCount itemK
return UseId
| otherwise -> do
let c = CActor target cstore
kit = (maxCount, take maxCount itemTimer)
execSfx
identifyIid iid c itemKindId
execUpdAtomic $ UpdDestroyItem iid itemBase kit c
effectCreateItem (Just $ bfid sb) Nothing
target cstore "common item" IK.timerNone
effectIdentify :: MonadServerAtomic m
=> m () -> ItemId -> ActorId -> ActorId -> m UseResult
effectIdentify execSfx iidId source target = do
COps{coItemSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
s <- getsServer $ (EM.! bfid sb) . sclientStates
let tryFull store as = case as of
[] -> return False
(iid, _) : rest | iid == iidId -> tryFull store rest
(iid, ItemFull{itemBase, itemKindId, itemKind}) : rest -> do
let kindIsKnown = case jkind itemBase of
IdentityObvious _ -> True
IdentityCovered ix _ -> ix `EM.member` sdiscoKind s
if iid `EM.member` sdiscoAspect s
|| IK.isHumanTrinket itemKind
|| store == CGround && IK.onlyMinorEffects itemKind
|| IA.kmConst (IK.getKindMean itemKindId coItemSpeedup)
&& kindIsKnown
then tryFull store rest
else do
let c = CActor target store
execSfx
identifyIid iid c itemKindId
return True
tryStore stores = case stores of
[] -> do
execSfxAtomic $ SfxMsgFid (bfid sb) SfxIdentifyNothing
return UseId
store : rest -> do
allAssocs <- getsState $ fullAssocs target [store]
go <- tryFull store allAssocs
if go then return UseUp else tryStore rest
tryStore [CGround, CEqp, CInv, CSha]
identifyIid :: MonadServerAtomic m
=> ItemId -> Container -> ContentId ItemKind -> m ()
identifyIid iid c itemKindId = do
seed <- getsServer $ (EM.! iid) . sitemSeedD
execUpdAtomic $ UpdDiscover c iid itemKindId seed
effectDetect :: MonadServerAtomic m
=> m () -> IK.DetectKind -> Int -> ActorId -> Point -> m UseResult
effectDetect execSfx d radius target pos = do
COps{coTileSpeedup} <- getsState scops
b <- getsState $ getActorBody target
lvl <- getLevel $ blid b
let (predicate, action) = case d of
IK.DetectAll -> (const True, const $ return False)
IK.DetectActor -> ((`EM.member` lactor lvl), const $ return False)
IK.DetectItem -> ((`EM.member` lfloor lvl), const $ return False)
IK.DetectExit ->
let (ls1, ls2) = lstair lvl
in ((`elem` ls1 ++ ls2 ++ lescape lvl), const $ return False)
IK.DetectHidden ->
let predicateH p = Tile.isHideAs coTileSpeedup $ lvl `at` p
revealEmbed p = do
embeds <- getsState $ getEmbedBag (blid b) p
unless (EM.null embeds) $ do
s <- getState
let ais = map (\iid -> (iid, getItemBody iid s))
(EM.keys embeds)
execUpdAtomic $ UpdSpotItemBag (CEmbed (blid b) p) embeds ais
actionH l = do
let f p = when (p /= pos) $ do
let t = lvl `at` p
execUpdAtomic $ UpdSearchTile target p t
revealEmbed p
mapM_ f l
return $! not $ null l
in (predicateH, actionH)
IK.DetectEmbed -> ((`EM.member` lembed lvl), const $ return False)
effectDetectX d predicate action execSfx radius target
effectDetectX :: MonadServerAtomic m
=> IK.DetectKind -> (Point -> Bool) -> ([Point] -> m Bool)
-> m () -> Int -> ActorId -> m UseResult
effectDetectX d predicate action execSfx radius target = do
b <- getsState $ getActorBody target
Level{lxsize, lysize} <- getLevel $ blid b
sperFidOld <- getsServer sperFid
let perOld = sperFidOld EM.! bfid b EM.! blid b
Point x0 y0 = bpos b
perList = filter predicate
[ Point x y
| y <- [max 0 (y0 - radius) .. min (lysize - 1) (y0 + radius)]
, x <- [max 0 (x0 - radius) .. min (lxsize - 1) (x0 + radius)]
]
extraPer = emptyPer {psight = PerVisible $ ES.fromDistinctAscList perList}
inPer = diffPer extraPer perOld
unless (nullPer inPer) $ do
let perNew = addPer inPer perOld
fper = EM.adjust (EM.insert (blid b) perNew) (bfid b)
modifyServer $ \ser -> ser {sperFid = fper $ sperFid ser}
execSendPer (bfid b) (blid b) emptyPer inPer perNew
pointsModified <- action perList
if not (nullPer inPer) || pointsModified then do
execSfx
unless (nullPer inPer) $ do
modifyServer $ \ser -> ser {sperFid = sperFidOld}
execSendPer (bfid b) (blid b) inPer emptyPer perOld
else
execSfxAtomic $ SfxMsgFid (bfid b) $ SfxVoidDetection d
return UseUp
effectSendFlying :: MonadServerAtomic m
=> m () -> IK.ThrowMod -> ActorId -> ActorId -> Maybe Bool
-> m UseResult
effectSendFlying execSfx IK.ThrowMod{..} source target modePush = do
v <- sendFlyingVector source target modePush
tb <- getsState $ getActorBody target
Level{lxsize, lysize} <- getLevel (blid tb)
let eps = 0
fpos = bpos tb `shift` v
if braced tb then do
sb <- getsState $ getActorBody source
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target
return UseId
else case bla lxsize lysize eps (bpos tb) fpos of
Nothing -> error $ "" `showFailure` (fpos, tb)
Just [] -> error $ "projecting from the edge of level"
`showFailure` (fpos, tb)
Just (pos : rest) -> do
weightAssocs <- getsState $ fullAssocs target [CInv, CEqp, COrgan]
let weight = sum $ map (IK.iweight . itemKind . snd) weightAssocs
path = bpos tb : pos : rest
(trajectory, (speed, range)) =
computeTrajectory weight throwVelocity throwLinger path
ts = Just (trajectory, speed)
if null trajectory || btrajectory tb == ts
then return UseId
else do
execSfx
execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts
let delta = timeDeltaScale (ticksPerMeter speed) (-range)
modifyServer $ \ser ->
ser {sactorTime = ageActor (bfid tb) (blid tb) target delta
$ sactorTime ser}
return UseUp
sendFlyingVector :: MonadServerAtomic m
=> ActorId -> ActorId -> Maybe Bool -> m Vector
sendFlyingVector source target modePush = do
sb <- getsState $ getActorBody source
let boldpos_sb = fromMaybe (bpos sb) (boldpos sb)
if source == target then
if boldpos_sb == bpos sb then rndToAction $ do
z <- randomR (-10, 10)
oneOf [Vector 10 z, Vector (-10) z, Vector z 10, Vector z (-10)]
else
return $! vectorToFrom (bpos sb) boldpos_sb
else do
tb <- getsState $ getActorBody target
let pushV = vectorToFrom (bpos tb) (bpos sb)
pullV = vectorToFrom (bpos sb) (bpos tb)
return $! case modePush of
Just True -> pushV
Just False -> pullV
Nothing | adjacent (bpos sb) (bpos tb) -> pushV
Nothing -> pullV
effectDropBestWeapon :: MonadServerAtomic m => m () -> ActorId -> m UseResult
effectDropBestWeapon execSfx target = do
tb <- getsState $ getActorBody target
localTime <- getsState $ getLocalTime (blid tb)
kitAssRaw <- getsState $ kitAssocs target [CEqp]
let kitAss = filter (IK.isMelee . itemKind . fst . snd) kitAssRaw
case strongestMelee Nothing localTime kitAss of
(_, (iid, _)) : _ -> do
execSfx
let kit = beqp tb EM.! iid
dropCStoreItem True CEqp target tb 1 iid kit
return UseUp
[] ->
return UseDud
effectActivateInv :: MonadServerAtomic m
=> m () -> ActorId -> Char -> m UseResult
effectActivateInv execSfx target symbol = do
let c = CActor target CInv
effectTransformContainer execSfx symbol c $ \iid _ ->
meleeEffectAndDestroy target target iid c
effectTransformContainer :: forall m. MonadServerAtomic m
=> m () -> Char -> Container
-> (ItemId -> ItemQuant -> m ())
-> m UseResult
effectTransformContainer execSfx symbol c m = do
getKind <- getsState $ flip getIidKindServer
let hasSymbol (iid, _kit) = do
let jsymbol = IK.isymbol $ getKind iid
return $! jsymbol == symbol
assocsCStore <- getsState $ EM.assocs . getContainerBag c
is <- if symbol == ' '
then return assocsCStore
else filterM hasSymbol assocsCStore
if null is
then return UseDud
else do
execSfx
mapM_ (uncurry m) is
return UseUp
effectApplyPerfume :: MonadServerAtomic m => m () -> ActorId -> m UseResult
effectApplyPerfume execSfx target = do
tb <- getsState $ getActorBody target
Level{lsmell} <- getLevel $ blid tb
unless (EM.null lsmell) $ do
execSfx
let f p fromSm = execUpdAtomic $ UpdAlterSmell (blid tb) p fromSm timeZero
mapWithKeyM_ f lsmell
return UseUp
effectOneOf :: MonadServerAtomic m
=> (IK.Effect -> m UseResult) -> [IK.Effect] -> m UseResult
effectOneOf recursiveCall l = do
let call1 = do
ef <- rndToAction $ oneOf l
recursiveCall ef
call99 = replicate 99 call1
f call result = do
ur <- call
if ur == UseDud then result else return ur
foldr f (return UseDud) call99
effectRecharging :: MonadServerAtomic m
=> (IK.Effect -> m UseResult) -> IK.Effect -> Bool
-> m UseResult
effectRecharging recursiveCall e recharged =
if recharged
then recursiveCall e
else return UseDud
effectTemporary :: MonadServerAtomic m
=> m () -> ActorId -> ItemId -> Container -> m UseResult
effectTemporary execSfx source iid c = do
case c of
CActor _ COrgan -> do
b <- getsState $ getActorBody source
case iid `EM.lookup` borgan b of
Just _ -> return ()
Nothing -> execSfx
_ ->
execSfx
return UseUp
effectComposite :: forall m. MonadServerAtomic m
=> (IK.Effect -> m UseResult) -> [IK.Effect] -> m UseResult
effectComposite recursiveCall l = do
let f :: IK.Effect -> m UseResult -> m UseResult
f eff result = do
ur <- recursiveCall eff
when (ur == UseUp) $ void result
return ur
foldr f (return UseDud) l