{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Server.HandleEffectM
( applyItem, kineticEffectAndDestroy, effectAndDestroyAndAddKill
, itemEffectEmbedded, highestImpression, dominateFidSfx
, dropAllItems, pickDroppable
#ifdef EXPOSE_INTERNAL
, UseResult(..)
, applyKineticDamage, refillHP, cutCalm, effectAndDestroy, imperishableKit
, itemEffectDisco, effectSem
, effectBurn, effectExplode, effectRefillHP, effectRefillCalm, effectDominate
, dominateFid, effectImpress, effectPutToSleep, effectYell, effectSummon
, effectAscend, findStairExit, switchLevels1, switchLevels2, effectEscape
, effectParalyze, paralyze, effectParalyzeInWater, effectInsertMove
, effectTeleport, effectCreateItem, effectDropItem, dropCStoreItem
, effectPolyItem, effectRerollItem, effectDupItem, effectIdentify
, identifyIid, effectDetect, effectDetectX, effectSendFlying
, sendFlyingVector, effectDropBestWeapon, effectActivateInv
, effectTransformContainer, effectApplyPerfume, effectOneOf
, effectVerbNoLonger, effectVerbMsg, effectComposite
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.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 qualified Data.Text as T
import Game.LambdaHack.Atomic
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Analytics
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.ReqFailure
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 qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import qualified Game.LambdaHack.Core.Dice as Dice
import Game.LambdaHack.Core.Random
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
import Game.LambdaHack.Server.CommonM
import Game.LambdaHack.Server.ItemM
import Game.LambdaHack.Server.ItemRev
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
kineticEffectAndDestroy True aid aid aid iid c True
applyKineticDamage :: MonadServerAtomic m
=> ActorId -> ActorId -> ItemId -> m Bool
applyKineticDamage 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) | bproj sb -> - modifyDamageBySpeed rawDeltaHP speed
_ -> - 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
actorMaxSk <- getsState $ getActorMaxSkills target
let serious = source /= target && not (bproj tbOld)
hpMax = Ability.getSk Ability.SkMaxHP actorMaxSk
deltaHP0 | serious && speedDeltaHP < minusM =
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
fact <- getsState $ (EM.! bfid tb) . sfactionD
unless (bproj tb || fleaderMode (gplayer fact) == LeaderNull) $
when (bhp tb <= 0 && bhp tbOld > 0) $ do
electLeader (bfid tb) (blid tb) target
mleader <- getsState $ gleader . (EM.! bfid tb) . sfactionD
when (isNothing mleader) $
execUpdAtomic $ UpdLeadFaction (bfid tb) Nothing $ Just target
cutCalm :: MonadServerAtomic m => ActorId -> m ()
cutCalm target = do
tb <- getsState $ getActorBody target
actorMaxSk <- getsState $ getActorMaxSkills target
let upperBound = if hpTooLow tb actorMaxSk
then 2
else xM $ Ability.getSk Ability.SkMaxCalm actorMaxSk
deltaCalm = min minusM2 (upperBound - bcalm tb)
updateCalm target deltaCalm
kineticEffectAndDestroy :: MonadServerAtomic m
=> Bool -> ActorId -> ActorId -> ActorId
-> ItemId -> Container -> Bool
-> m ()
kineticEffectAndDestroy voluntary killer source target iid c mayDestroy = do
bag <- getsState $ getContainerBag c
case iid `EM.lookup` bag of
Nothing -> error $ "" `showFailure` (source, target, iid, c)
Just kit -> do
itemFull <- getsState $ itemToFull iid
tbOld <- getsState $ getActorBody target
localTime <- getsState $ getLocalTime (blid tbOld)
let recharged = hasCharge localTime itemFull kit
when recharged $ do
kineticPerformed <- applyKineticDamage source target iid
tb <- getsState $ getActorBody target
when (kineticPerformed
&& bhp tb <= 0 && bhp tbOld > 0) $ do
sb <- getsState $ getActorBody source
arWeapon <- getsState $ (EM.! iid) . sdiscoAspect
let killHow | not (bproj sb) =
if voluntary then KillKineticMelee else KillKineticPush
| IA.checkFlag Ability.Blast arWeapon = KillKineticBlast
| otherwise = KillKineticRanged
addKillToAnalytics killer killHow (bfid tbOld) (btrunk tbOld)
effectAndDestroyAndAddKill
voluntary killer False (fst kit <= 1) kineticPerformed
source target iid c False itemFull mayDestroy
effectAndDestroyAndAddKill :: MonadServerAtomic m
=> Bool -> ActorId -> Bool -> Bool
-> Bool -> ActorId -> ActorId -> ItemId -> Container
-> Bool -> ItemFull -> Bool
-> m ()
effectAndDestroyAndAddKill voluntary killer onSmashOnly useAllCopies
kineticPerformed source target iid container
periodic itemFull mayDestroy = do
tbOld <- getsState $ getActorBody target
effectAndDestroy onSmashOnly useAllCopies kineticPerformed source target
iid container periodic itemFull mayDestroy
tb <- getsState $ getActorBody target
when (bhp tb <= 0 && bhp tbOld > 0) $ do
sb <- getsState $ getActorBody source
arWeapon <- getsState $ (EM.! iid) . sdiscoAspect
let killHow | not (bproj sb) =
if voluntary then KillOtherMelee else KillOtherPush
| IA.checkFlag Ability.Blast arWeapon = KillOtherBlast
| otherwise = KillOtherRanged
addKillToAnalytics killer killHow (bfid tbOld) (btrunk tbOld)
effectAndDestroy :: MonadServerAtomic m
=> Bool -> Bool -> Bool
-> ActorId -> ActorId -> ItemId -> Container
-> Bool -> ItemFull -> Bool
-> m ()
effectAndDestroy onSmashOnly useAllCopies kineticPerformed
source target iid container periodic
itemFull@ItemFull{itemBase, itemDisco, itemKindId, itemKind}
mayDestroy = do
bag <- getsState $ getContainerBag container
let (itemK, itemTimer) = bag EM.! iid
effs = if onSmashOnly
then IK.strengthOnSmash itemKind
else IK.ieffects itemKind
arItem = case itemDisco of
ItemDiscoFull itemAspect -> itemAspect
_ -> error "effectAndDestroy: server ignorant about an item"
timeout = IA.aTimeout arItem
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 || onSmashOnly
when recharged $ do
let it2 = if timeout /= 0 && recharged
then if periodic && IA.checkFlag Ability.Fragile arItem
then replicate (itemK - length it1) localTime ++ it1
else localTime : it1
else itemTimer
kit2 = (1, take 1 it2)
!_A = assert (len <= itemK `blame` (source, target, iid, container)) ()
unless (itemTimer == it2) $
execUpdAtomic $ UpdTimeItem iid container itemTimer it2
let imperishable = not mayDestroy || imperishableKit periodic itemFull
unless imperishable $
execUpdAtomic $ UpdLoseItem False iid itemBase kit2 container
let effsManual = if not periodic
&& IA.checkFlag Ability.Periodic arItem
&& not (IA.checkFlag Ability.Condition arItem)
then take 1 effs
else effs
triggeredEffect <- itemEffectDisco useAllCopies kineticPerformed
source target iid itemKindId itemKind
container periodic effsManual
let triggered = if kineticPerformed then UseUp else triggeredEffect
sb <- getsState $ getActorBody source
unless (triggered == UseUp
|| periodic
|| bproj sb
) $
execSfxAtomic $ SfxMsgFid (bfid sb) $
if any IK.forApplyEffect effsManual
then SfxFizzles
else SfxNothingHappens
unless (imperishable || triggered == UseUp) $
execUpdAtomic $ UpdSpotItem False iid itemBase kit2 container
imperishableKit :: Bool -> ItemFull -> Bool
imperishableKit periodic itemFull =
let arItem = aspectRecordFull itemFull
in IA.checkFlag Ability.Durable arItem
|| periodic && not (IA.checkFlag Ability.Fragile arItem)
itemEffectEmbedded :: MonadServerAtomic m
=> Bool -> ActorId -> LevelId -> Point -> ItemId -> m ()
itemEffectEmbedded voluntary aid lid tpos iid = do
let c = CEmbed lid tpos
kineticEffectAndDestroy voluntary aid aid aid iid c True
itemEffectDisco :: MonadServerAtomic m
=> Bool -> Bool-> ActorId -> ActorId -> ItemId
-> ContentId ItemKind -> ItemKind
-> Container -> Bool -> [IK.Effect]
-> m UseResult
itemEffectDisco useAllCopies kineticPerformed
source target iid itemKindId itemKind
c periodic effs = do
urs <- mapM (effectSem useAllCopies source target iid c periodic) effs
let ur = case urs of
[] -> UseDud
_ -> maximum urs
when (ur >= UseId || kineticPerformed) $
identifyIid iid c itemKindId itemKind
return ur
effectSem :: MonadServerAtomic m
=> Bool -> ActorId -> ActorId -> ItemId -> Container -> Bool
-> IK.Effect
-> m UseResult
effectSem useAllCopies source target iid c periodic effect = do
let recursiveCall = effectSem useAllCopies source target iid c periodic
sb <- getsState $ getActorBody source
pos <- getsState $ posFromC c
let execSfx = execSfxAtomic $ SfxEffect (bfid sb) target effect 0
execSfxSource = execSfxAtomic $ SfxEffect (bfid sb) source effect 0
case effect of
IK.Burn nDm -> effectBurn nDm source target
IK.Explode t -> effectExplode execSfx t source 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.PutToSleep -> effectPutToSleep execSfx target
IK.Yell -> effectYell execSfx 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 execSfx source target
IK.Paralyze nDm -> effectParalyze execSfx nDm source target
IK.ParalyzeInWater nDm -> effectParalyzeInWater 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 source target store grp tim
IK.DropItem n k store grp -> effectDropItem execSfx iid n k store grp target
IK.PolyItem -> effectPolyItem execSfx iid target
IK.RerollItem -> effectRerollItem execSfx iid target
IK.DupItem -> effectDupItem execSfx iid target
IK.Identify -> effectIdentify execSfx iid target
IK.Detect d radius -> effectDetect execSfx d radius target pos
IK.SendFlying tmod ->
effectSendFlying execSfx tmod source target c Nothing
IK.PushActor tmod ->
effectSendFlying execSfx tmod source target c (Just True)
IK.PullActor tmod ->
effectSendFlying execSfx tmod source target c (Just False)
IK.DropBestWeapon -> effectDropBestWeapon execSfx iid target
IK.ActivateInv symbol -> effectActivateInv execSfx iid source target symbol
IK.ApplyPerfume -> effectApplyPerfume execSfx target
IK.OneOf l -> effectOneOf recursiveCall l
IK.OnSmash _ -> return UseDud
IK.VerbNoLonger _ -> effectVerbNoLonger useAllCopies execSfxSource source
IK.VerbMsg _ -> effectVerbMsg execSfxSource source
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 -> ActorId -> m UseResult
effectExplode execSfx cgroup source 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, itemKind}, (itemK, _))) =
fromMaybe (error $ "" `showFailure` cgroup) m2
Point x y = bpos tb
semirandom = T.length (IK.idesc itemKind)
projectN k100 n = do
let veryrandom = (k100 `xor` (semirandom + n)) `mod` 5
fuzz = 5 + veryrandom
k | 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 ]
randomReverse = if veryrandom `mod` 2 == 0 then id else reverse
ps = take k $ concat $
randomReverse
[ 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 center = centerRaw && itemK >= 8
mfail <- projectFail source target tpxy veryrandom center
iid COrgan True
case mfail of
Nothing -> return ()
Just ProjectBlockTerrain -> return ()
Just ProjectBlockActor | not $ bproj tb -> return ()
Just failMsg ->
execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxUnexpected failMsg
tryFlying 0 = return ()
tryFlying k100 = do
bag2 <- getsState $ borgan . getActorBody target
case EM.lookup iid bag2 of
Just (n2, _) | n2 >= itemK `div` 2 -> do
projectN k100 n2
tryFlying $ k100 - 1
_ -> return ()
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
effectRefillCalm :: MonadServerAtomic m
=> m () -> Int -> ActorId -> ActorId -> m UseResult
effectRefillCalm execSfx power0 source target = do
tb <- getsState $ getActorBody target
actorMaxSk <- getsState $ getActorMaxSkills target
let power = if power0 <= -1 then power0 else max 1 power0
rawDeltaCalm = xM power
calmMax = Ability.getSk Ability.SkMaxCalm actorMaxSk
serious = rawDeltaCalm <= minusM2 && 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
updateCalm 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 tb
let permitted = case hiImpression of
Nothing -> False
Just (hiImpressionFid, hiImpressionK) ->
hiImpressionFid == bfid sb
&& (fleaderMode (gplayer fact) /= LeaderNull
|| hiImpressionK >= 10)
if permitted then do
b <- dominateFidSfx source target (bfid sb)
return $! if b then UseUp else UseDud
else do
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxUnimpressed target
when (source /= target) $
execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxUnimpressed target
return UseDud
highestImpression :: MonadServerAtomic m
=> Actor -> m (Maybe (FactionId, Int))
highestImpression tb = do
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, fst $ snd maxImpression)
dominateFidSfx :: MonadServerAtomic m
=> ActorId -> ActorId -> FactionId -> m Bool
dominateFidSfx source target fid = do
tb <- getsState $ getActorBody target
let !_A = assert (not $ bproj tb) ()
canTra <- getsState $ canTraverse target
if isNothing (btrajectory tb) && canTra && bhp tb > 0 then do
let execSfx = execSfxAtomic $ SfxEffect fid target IK.Dominate 0
execSfx
dominateFid fid source target
execSfx
return True
else
return False
dominateFid :: MonadServerAtomic m => FactionId -> ActorId -> ActorId -> m ()
dominateFid fid source 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
dropAllItems target tb0
tb <- getsState $ getActorBody target
ais <- getsState $ getCarriedAssocsAndTrunk tb
actorMaxSk <- getsState $ getActorMaxSkills 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 maxCalm = Ability.getSk Ability.SkMaxCalm actorMaxSk
maxHp = Ability.getSk Ability.SkMaxHP actorMaxSk
bNew = tb { bfid = fid
, bcalm = max (xM 10) $ xM maxCalm `div` 2
, bhp = min (xM maxHp) $ 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
setFreshLeader fid target
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
unless gameOver $ do
void $ effectCreateItem (Just $ bfid tb) (Just 10) source target COrgan
"impressed" IK.timerNone
getKindId <- getsState $ flip getIidKindIdServer
let discoverIf (iid, cstore) = do
let itemKindId = getKindId iid
c = CActor target cstore
assert (cstore /= CGround) $
discoverIfMinorEffects c iid itemKindId
aic = (btrunk tb, COrgan)
: filter ((/= btrunk tb) . fst) (getCarriedIidCStore tb)
mapM_ discoverIf aic
dropAllItems :: MonadServerAtomic m => ActorId -> Actor -> m ()
dropAllItems aid b = do
mapActorCStore_ CInv (dropCStoreItem False CInv aid b maxBound) b
mapActorCStore_ CEqp (dropCStoreItem False CEqp aid b maxBound) b
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) source target COrgan
"impressed" IK.timerNone
else return UseDud
effectPutToSleep :: MonadServerAtomic m => m () -> ActorId -> m UseResult
effectPutToSleep execSfx target = do
tb <- getsState $ getActorBody target
if | bproj tb -> return UseDud
| bwatch tb `elem` [WSleep, WWake] -> return UseId
| otherwise -> do
actorMaxSk <- getsState $ getActorMaxSkills target
let maxCalm = xM $ Ability.getSk Ability.SkMaxCalm actorMaxSk
deltaCalm = maxCalm - bcalm tb
when (deltaCalm > 0) $
updateCalm target deltaCalm
execSfx
case bwatch tb of
WWait n | n > 0 -> do
nAll <- removeConditionSingle "braced" target
let !_A = assert (nAll == 0) ()
return ()
_ -> return ()
addSleep target
return UseUp
effectYell :: MonadServerAtomic m => m () -> ActorId -> m UseResult
effectYell execSfx target = do
tb <- getsState $ getActorBody target
if bproj tb || bhp tb <= 0 then
return UseDud
else do
execSfx
execSfxAtomic $ SfxTaunt False target
when (deltaBenign $ bcalmDelta tb) $
execUpdAtomic $ UpdRefillCalm target minusM
return UseUp
effectSummon :: MonadServerAtomic m
=> GroupName ItemKind -> Dice.Dice -> ItemId
-> ActorId -> ActorId -> Bool
-> m UseResult
effectSummon grp nDm iid source target periodic = do
cops@COps{coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
sMaxSk <- getsState $ getActorMaxSkills source
tMaxSk <- getsState $ getActorMaxSkills target
totalDepth <- getsState stotalDepth
lvl@Level{ldepth, lbig} <- getLevel (blid tb)
nFriends <- getsState $ length . friendRegularAssocs (bfid sb) (blid sb)
discoAspect <- getsState sdiscoAspect
power0 <- rndToAction $ castDice ldepth totalDepth nDm
let arItem = discoAspect EM.! iid
power = max power0 1
effect = IK.Summon grp $ Dice.intToDice power
durable = IA.checkFlag Ability.Durable arItem
warnBothActors warning =
unless (bproj sb) $ do
execSfxAtomic $ SfxMsgFid (bfid sb) warning
when (source /= target) $
execSfxAtomic $ SfxMsgFid (bfid tb) warning
deltaCalm = - xM 30
if | (periodic || durable) && not (bproj sb)
&& (bcalm sb < - deltaCalm || not (calmEnough sb sMaxSk)) -> do
warnBothActors $ SfxSummonLackCalm source
return UseId
| nFriends >= 20 -> do
warnBothActors $ SfxSummonTooManyOwn source
return UseId
| EM.size lbig >= 200 -> do
warnBothActors $ SfxSummonTooManyAll source
return UseId
| otherwise -> do
unless (bproj sb) $ updateCalm source deltaCalm
let validTile t = not $ Tile.isNoActor coTileSpeedup t
ps = nearbyFreePoints cops lvl validTile (bpos tb)
localTime <- getsState $ getLocalTime (blid tb)
let actorTurn = ticksPerMeter $ gearSpeed tMaxSk
targetTime = timeShift localTime actorTurn
afterTime = timeShift targetTime $ Delta timeClip
when (length (take power ps) < power) $
debugPossiblyPrint
"Server: effectSummon: failed to find enough free positions"
bs <- forM (take power ps) $ \p -> do
maid <- addAnyActor True 0 [(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) $ setFreshLeader (bfid b) aid
return True
if or bs then do
execSfxAtomic $ SfxEffect (bfid sb) source effect 0
return UseUp
else do
warnBothActors $ SfxSummonFailure source
return 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
destinations <- getsState $ whereTo lid1 pos up . sdungeon
sb <- getsState $ getActorBody source
if | actorWaits b1 && source /= target -> do
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target
when (source /= target) $
execSfxAtomic $ SfxMsgFid (bfid b1) $ SfxBracedImmune target
return UseId
| null destinations -> do
execSfxAtomic $ SfxMsgFid (bfid sb) SfxLevelNoMore
when (source /= target) $
execSfxAtomic $ SfxMsgFid (bfid b1) SfxLevelNoMore
recursiveCall $ IK.Teleport 30
| otherwise -> do
(lid2, pos2) <- rndToAction $ oneOf destinations
execSfx
mbtime_bOld <-
getsServer $ lookupActorTime (bfid b1) lid1 target . sactorTime
mbtimeTraj_bOld <-
getsServer $ lookupActorTime (bfid b1) lid1 target . strajTime
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)
mbtime_bOld mbtimeTraj_bOld mlead
inhabitants <- getsState $ posToAidAssocs pos3 lid2
case inhabitants of
[] -> do
switch1
switch2
(_, b2) : _ -> do
execSfxAtomic $ SfxMsgFid (bfid sb) SfxLevelPushed
when (source /= target) $
execSfxAtomic $ SfxMsgFid (bfid b2) SfxLevelPushed
switch1
let moveInh inh = do
mbtime_inh <-
getsServer $ lookupActorTime (bfid (snd inh)) lid2 (fst inh)
. sactorTime
mbtimeTraj_inh <-
getsServer $ lookupActorTime (bfid (snd inh)) lid2 (fst inh)
. strajTime
inhMLead <- switchLevels1 inh
switchLevels2 lid1 (bpos b1) inh
mbtime_inh mbtimeTraj_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 posToAidAssocs 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)
-> Maybe Time -> Maybe Time -> Maybe ActorId
-> m ()
switchLevels2 lidNew posNew (aid, bOld) mbtime_bOld mbtimeTraj_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
maybe (return ())
(\btime_bOld ->
modifyServer $ \ser ->
ser {sactorTime = updateActorTime (bfid bNew) lidNew aid
(shiftByDelta btime_bOld)
$ sactorTime ser})
mbtime_bOld
maybe (return ())
(\btime_bOld ->
modifyServer $ \ser ->
ser {strajTime = updateActorTime (bfid bNew) lidNew aid
(shiftByDelta btime_bOld)
$ strajTime ser})
mbtimeTraj_bOld
execUpdAtomic $ UpdCreateActor aid bNew ais
case mlead of
Nothing -> return ()
Just leader ->
setFreshLeader side leader
effectEscape :: MonadServerAtomic m => m () -> ActorId -> ActorId -> m UseResult
effectEscape execSfx source target = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
let fid = bfid tb
fact <- getsState $ (EM.! fid) . sfactionD
if | bproj tb ->
return UseDud
| not (fcanEscape $ gplayer fact) -> do
execSfxAtomic $ SfxMsgFid (bfid sb) SfxEscapeImpossible
when (source /= target) $
execSfxAtomic $ SfxMsgFid (bfid tb) SfxEscapeImpossible
return UseId
| otherwise -> do
execSfx
deduceQuits (bfid tb) $ Status Escape (fromEnum $ blid tb) Nothing
return UseUp
effectParalyze :: MonadServerAtomic m
=> m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult
effectParalyze execSfx nDm source target = do
tb <- getsState $ getActorBody target
if bproj tb then return UseDud else
paralyze execSfx nDm source target
paralyze :: MonadServerAtomic m
=> m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult
paralyze execSfx nDm source target = do
tb <- getsState $ getActorBody target
totalDepth <- getsState stotalDepth
Level{ldepth} <- getLevel (blid tb)
power0 <- rndToAction $ castDice ldepth totalDepth nDm
let power = max power0 1
actorStasis <- getsServer sactorStasis
if | ES.member target actorStasis -> do
sb <- getsState $ getActorBody source
execSfxAtomic $ SfxMsgFid (bfid sb) SfxStasisProtects
when (source /= target) $
execSfxAtomic $ SfxMsgFid (bfid tb) SfxStasisProtects
return UseId
| otherwise -> do
execSfx
let t = timeDeltaScale (Delta timeClip) power
modifyServer $ \ser ->
ser { sactorTime = ageActor (bfid tb) (blid tb) target t
$ sactorTime ser
, sactorStasis = ES.insert target (sactorStasis ser) }
return UseUp
effectParalyzeInWater :: MonadServerAtomic m
=> m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult
effectParalyzeInWater execSfx nDm source target = do
tb <- getsState $ getActorBody target
if bproj tb then return UseDud else do
actorMaxSk <- getsState $ getActorMaxSkills target
let swimmingOrFlying = max (Ability.getSk Ability.SkSwimming actorMaxSk)
(Ability.getSk Ability.SkFlying actorMaxSk)
if Dice.supDice nDm > swimmingOrFlying
then paralyze execSfx nDm source target
else
return UseId
effectInsertMove :: MonadServerAtomic m
=> m () -> Dice.Dice -> ActorId -> ActorId -> m UseResult
effectInsertMove execSfx nDm source target = do
tb <- getsState $ getActorBody target
actorMaxSk <- getsState $ getActorMaxSkills 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 $ gearSpeed actorMaxSk
t = timeDeltaScale (timeDeltaPercent actorTurn 10) (-power)
if | bproj tb -> return UseDud
| ES.member target actorStasis -> do
sb <- getsState $ getActorBody source
execSfxAtomic $ SfxMsgFid (bfid sb) SfxStasisProtects
when (source /= target) $
execSfxAtomic $ SfxMsgFid (bfid tb) 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
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
if actorWaits tb && source /= target
then do
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target
when (source /= target) $
execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxBracedImmune target
return UseId
else do
COps{coTileSpeedup} <- getsState scops
totalDepth <- getsState stotalDepth
lvl@Level{ldepth} <- 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
mtpos <- rndToAction $ findPosTry 200 lvl
(\p !t -> Tile.isWalkable coTileSpeedup t
&& not (Tile.isNoActor coTileSpeedup t)
&& not (occupiedBigLvl p lvl)
&& not (occupiedProjLvl 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
]
case mtpos of
Nothing -> do
debugPossiblyPrint
"Server: effectTeleport: failed to find any free position"
execSfxAtomic $ SfxMsgFid (bfid sb) SfxTransImpossible
when (source /= target) $
execSfxAtomic $ SfxMsgFid (bfid tb) SfxTransImpossible
return UseId
Just tpos -> do
execSfx
execUpdAtomic $ UpdMoveActor target spos tpos
return UseUp
effectCreateItem :: MonadServerAtomic m
=> Maybe FactionId -> Maybe Int -> ActorId -> ActorId -> CStore
-> GroupName ItemKind -> IK.TimerDice
-> m UseResult
effectCreateItem jfidRaw mcount source target store grp tim = do
sb <- getsState $ getActorBody source
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
actorMaxSk <- getsState $ getActorMaxSkills target
let actorTurn =
timeDeltaPercent (ticksPerMeter $ gearSpeed actorMaxSk) 101
fscale actorTurn nDm
delta <- IK.foldTimer (return $ Delta timeZero) fgame factor tim
let c = CActor target store
bagBefore <- getsState $ getBodyStoreBag tb store
freq <- prepareItemKind 0 (blid tb) [(grp, 1)]
m2 <- rollItemAspect freq (blid tb)
let (itemKnownRaw, (itemFullRaw, kitRaw)) =
fromMaybe (error $ "" `showFailure` (blid tb, freq, c)) m2
jfid = if store == COrgan && not (IK.isTimerNone tim)
|| grp == "impressed"
then jfidRaw
else Nothing
(itemKnown, itemFull) =
let ItemKnown kindIx ar _ = itemKnownRaw
in ( ItemKnown 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 sb)
$ SfxTimerExtended (blid tb) target iid store delta
when (bfid sb /= bfid tb) $
execSfxAtomic $ SfxMsgFid (bfid tb)
$ SfxTimerExtended (blid tb) target iid store delta
return UseUp
else return UseDud
_ -> do
iid <- registerItem (itemFull, kitNew) itemKnown 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 () -> ItemId -> Int -> Int -> CStore
-> GroupName ItemKind -> ActorId
-> m UseResult
effectDropItem execSfx iidId ngroup kcopy store grp target = do
tb <- getsState $ getActorBody target
fact <- getsState $ (EM.! bfid tb) . sfactionD
isRaw <- allGroupItems store grp target
curChalSer <- getsServer $ scurChalSer . soptions
factionD <- getsState sfactionD
let is = filter ((/= iidId) . fst) isRaw
if | bproj tb || null is -> return UseDud
| ngroup == maxBound && kcopy == maxBound
&& store `elem` [CEqp, CInv, CSha]
&& fhasGender (gplayer fact)
&& (cdiff curChalSer == 1
&& any (fhasUI . gplayer . snd)
(filter (\(fi, fa) -> isFriend fi fa (bfid tb))
(EM.assocs factionD))
|| cdiff curChalSer == difficultyBound
&& any (fhasUI . gplayer . snd)
(filter (\(fi, fa) -> isFoe fi fa (bfid tb))
(EM.assocs factionD))) ->
return UseUp
| otherwise -> do
unless (store == COrgan) execSfx
mapM_ (uncurry (dropCStoreItem True store target tb kcopy))
(take ngroup is)
return UseUp
dropCStoreItem :: MonadServerAtomic m
=> Bool -> CStore -> ActorId -> Actor -> Int
-> ItemId -> ItemQuant
-> m ()
dropCStoreItem verbose store aid b kMax iid (k, _) = do
itemFull@ItemFull{itemBase} <- getsState $ itemToFull iid
let arItem = aspectRecordFull itemFull
c = CActor aid store
fragile = IA.checkFlag Ability.Fragile arItem
durable = IA.checkFlag Ability.Durable arItem
isDestroyed = bproj b && (bhp b <= 0 && not durable || fragile)
|| IA.checkFlag Ability.Condition arItem
if isDestroyed then do
let
voluntary = True
onSmashOnly = True
useAllCopies = kMax >= k
effectAndDestroyAndAddKill voluntary aid onSmashOnly useAllCopies False
aid aid iid c False itemFull True
bag <- getsState $ getContainerBag c
maybe (return ())
(\(k1, it) ->
let destroyedSoFar = k - k1
k2 = min (kMax - destroyedSoFar) k1
kit2 = (k2, take k2 it)
in when (k2 > 0)
$ execUpdAtomic $ UpdLoseItem False iid itemBase kit2 c)
(EM.lookup iid bag)
else do
cDrop <- pickDroppable False aid b
mvCmd <- generalMoveItem verbose iid (min kMax k) (CActor aid store) cDrop
mapM_ execUpdAtomic mvCmd
pickDroppable :: MonadStateRead m => Bool -> ActorId -> Actor -> m Container
pickDroppable respectNoItem aid b = do
cops@COps{coTileSpeedup} <- getsState scops
lvl <- getLevel (blid b)
let validTile t = not (respectNoItem && Tile.isNoItem coTileSpeedup t)
if validTile $ lvl `at` bpos b
then return $! CActor aid CGround
else do
let ps = nearbyFreePoints cops lvl validTile (bpos b)
return $! case filter (adjacent $ bpos b) $ take 8 ps of
[] -> CActor aid CGround
pos : _ -> CFloor (blid b) pos
effectPolyItem :: MonadServerAtomic m
=> m () -> ItemId -> ActorId -> m UseResult
effectPolyItem execSfx iidId target = do
tb <- getsState $ getActorBody target
let cstore = CGround
kitAss <- getsState $ kitAssocs target [cstore]
case filter ((/= iidId) . fst) kitAss of
[] -> do
execSfxAtomic $ SfxMsgFid (bfid tb) SfxPurposeNothing
return UseId
(iid, ( itemFull@ItemFull{itemBase, itemKindId, itemKind}
, (itemK, itemTimer) )) : _ -> do
let arItem = aspectRecordFull itemFull
maxCount = Dice.supDice $ IK.icount itemKind
if | IA.checkFlag Ability.Unique arItem -> do
execSfxAtomic $ SfxMsgFid (bfid tb) SfxPurposeUnique
return UseId
| maybe True (<= 0) $ lookup "common item" $ IK.ifreq itemKind -> do
execSfxAtomic $ SfxMsgFid (bfid tb) SfxPurposeNotCommon
return UseId
| itemK < maxCount -> do
execSfxAtomic $ SfxMsgFid (bfid tb)
$ SfxPurposeTooFew maxCount itemK
return UseId
| otherwise -> do
let c = CActor target cstore
kit = (maxCount, take maxCount itemTimer)
execSfx
identifyIid iid c itemKindId itemKind
execUpdAtomic $ UpdDestroyItem iid itemBase kit c
effectCreateItem (Just $ bfid tb) Nothing
target target cstore "common item" IK.timerNone
effectRerollItem :: forall m . MonadServerAtomic m
=> m () -> ItemId -> ActorId -> m UseResult
effectRerollItem execSfx iidId target = do
COps{coItemSpeedup} <- getsState scops
tb <- getsState $ getActorBody target
let cstore = CGround
kitAss <- getsState $ kitAssocs target [cstore]
case filter ((/= iidId) . fst) kitAss of
[] -> do
execSfxAtomic $ SfxMsgFid (bfid tb) SfxRerollNothing
return UseId
(iid, ( ItemFull{ itemBase, itemKindId, itemKind
, itemDisco=ItemDiscoFull itemAspect }
, (_, itemTimer) )) : _ ->
if | IA.kmConst $ getKindMean itemKindId coItemSpeedup -> do
execSfxAtomic $ SfxMsgFid (bfid tb) SfxRerollNotRandom
return UseId
| otherwise -> do
let c = CActor target cstore
kit = (1, take 1 itemTimer)
freq = pure (itemKindId, itemKind)
execSfx
identifyIid iid c itemKindId itemKind
execUpdAtomic $ UpdDestroyItem iid itemBase kit c
dungeon <- getsState sdungeon
let maxLid = fst $ maximumBy (Ord.comparing (ldepth . snd))
$ EM.assocs dungeon
roll100 :: Int -> m (ItemKnown, ItemFullKit)
roll100 n = do
m2 <- rollItemAspect freq maxLid
case m2 of
Nothing ->
error "effectRerollItem: can't create rerolled item"
Just i2@(ItemKnown _ ar2 _, _) ->
if ar2 == itemAspect && n > 0
then roll100 (n - 1)
else return i2
(itemKnown, (itemFull, _)) <- roll100 100
void $ registerItem (itemFull, kit) itemKnown c True
return UseUp
_ -> error "effectRerollItem: server ignorant about an item"
effectDupItem :: MonadServerAtomic m => m () -> ItemId -> ActorId -> m UseResult
effectDupItem execSfx iidId target = do
tb <- getsState $ getActorBody target
let cstore = CGround
kitAss <- getsState $ kitAssocs target [cstore]
case filter ((/= iidId) . fst) kitAss of
[] -> do
execSfxAtomic $ SfxMsgFid (bfid tb) SfxDupNothing
return UseId
(iid, ( itemFull@ItemFull{itemBase, itemKindId, itemKind}
, _ )) : _ -> do
let arItem = aspectRecordFull itemFull
if | IA.checkFlag Ability.Unique arItem -> do
execSfxAtomic $ SfxMsgFid (bfid tb) SfxDupUnique
return UseId
| maybe False (> 0) $ lookup "valuable" $ IK.ifreq itemKind -> do
execSfxAtomic $ SfxMsgFid (bfid tb) SfxDupValuable
return UseId
| otherwise -> do
let c = CActor target cstore
execSfx
identifyIid iid c itemKindId itemKind
execUpdAtomic $ UpdCreateItem iid itemBase (1, []) c
return UseUp
effectIdentify :: MonadServerAtomic m
=> m () -> ItemId -> ActorId -> m UseResult
effectIdentify execSfx iidId target = do
COps{coItemSpeedup} <- getsState scops
discoAspect <- getsState sdiscoAspect
tb <- getsState $ getActorBody target
sClient <- getsServer $ (EM.! bfid tb) . 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 arItem = discoAspect EM.! iid
kindIsKnown = case jkind itemBase of
IdentityObvious _ -> True
IdentityCovered ix _ -> ix `EM.member` sdiscoKind sClient
if iid `EM.member` sdiscoAspect sClient
|| IA.isHumanTrinket itemKind
|| store == CGround && IA.onlyMinorEffects arItem itemKind
|| IA.kmConst (getKindMean itemKindId coItemSpeedup)
&& kindIsKnown
then tryFull store rest
else do
let c = CActor target store
execSfx
identifyIid iid c itemKindId itemKind
return True
tryStore stores = case stores of
[] -> do
execSfxAtomic $ SfxMsgFid (bfid tb) 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 -> ItemKind -> m ()
identifyIid iid c itemKindId itemKind =
unless (IA.isHumanTrinket itemKind) $ do
discoAspect <- getsState sdiscoAspect
execUpdAtomic $ UpdDiscover c iid itemKindId $ discoAspect EM.! iid
effectDetect :: MonadServerAtomic m
=> m () -> IK.DetectKind -> Int -> ActorId -> Point -> m UseResult
effectDetect execSfx d radius target pos = do
COps{coitem, coTileSpeedup} <- getsState scops
b <- getsState $ getActorBody target
lvl <- getLevel $ blid b
s <- getState
getKind <- getsState $ flip getIidKindServer
let lootPredicate p =
p `EM.member` lfloor lvl
|| (case posToBigAssoc p (blid b) s of
Nothing -> False
Just (_, body) ->
let belongings = EM.keys (beqp body) ++ EM.keys (binv body)
in any belongingIsLoot belongings)
|| any embedHasLoot (EM.keys $ getEmbedBag (blid b) p s)
itemKindIsLoot = isNothing . lookup "unreported inventory" . IK.ifreq
belongingIsLoot iid = itemKindIsLoot $ getKind iid
embedHasLoot iid = any effectHasLoot $ IK.ieffects $ getKind iid
reported acc _ _ itemKind = acc && itemKindIsLoot itemKind
effectHasLoot (IK.CreateItem cstore grp _) =
cstore `elem` [CGround, CEqp, CInv, CSha]
&& ofoldlGroup' coitem grp reported True
effectHasLoot IK.PolyItem = True
effectHasLoot IK.RerollItem = True
effectHasLoot IK.DupItem = True
effectHasLoot (IK.OneOf l) = any effectHasLoot l
effectHasLoot (IK.OnSmash eff) = effectHasLoot eff
effectHasLoot (IK.Composite l) = any effectHasLoot l
effectHasLoot _ = False
(predicate, action) = case d of
IK.DetectAll -> (const True, const $ return False)
IK.DetectActor -> ((`EM.member` lbig lvl), const $ return False)
IK.DetectLoot -> (lootPredicate, 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
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
case EM.lookup p $ lentry lvl of
Nothing -> return ()
Just entry ->
execUpdAtomic $ UpdSpotEntry (blid b) [(p, entry)]
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
COps{corule=RuleContent{rXmax, rYmax}} <- getsState scops
b <- getsState $ getActorBody target
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 (rYmax - 1) (y0 + radius)]
, x <- [max 0 (x0 - radius) .. min (rXmax - 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 -> Container
-> Maybe Bool
-> m UseResult
effectSendFlying execSfx IK.ThrowMod{..} source target c modePush = do
v <- sendFlyingVector source target modePush
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
let eps = 0
fpos = bpos tb `shift` v
isEmbed = case c of
CEmbed{} -> True
_ -> False
if bhp tb <= 0
|| bproj tb && isEmbed then
return UseDud
else if actorWaits tb
&& source /= target
&& isNothing (btrajectory tb) then do
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target
when (source /= target) $
execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxBracedImmune target
return UseUp
else do
COps{corule=RuleContent{rXmax, rYmax}} <- getsState scops
case bla rXmax rYmax 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, _)) =
computeTrajectory weight throwVelocity throwLinger path
ts = Just (trajectory, speed)
if null trajectory
then return UseId
else do
execSfx
unless (btrajectory tb == ts) $
execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts
originator <- if bproj sb
then getsServer $ EM.findWithDefault source source
. strajPushedBy
else return source
modifyServer $ \ser ->
ser {strajPushedBy = EM.insert target originator $ strajPushedBy ser}
when (isNothing $ btrajectory tb) $ do
localTime <- getsState $ getLocalTime (blid tb)
let overheadTime = timeShift localTime (Delta timeClip)
modifyServer $ \ser ->
ser {strajTime =
updateActorTime (bfid tb) (blid tb) target overheadTime
$ strajTime 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 () -> ItemId -> ActorId -> m UseResult
effectDropBestWeapon execSfx iidId target = do
tb <- getsState $ getActorBody target
if bproj tb then return UseDud else do
localTime <- getsState $ getLocalTime (blid tb)
kitAssRaw <- getsState $ kitAssocs target [CEqp]
let kitAss = filter (\(iid, (i, _)) ->
IA.checkFlag Ability.Meleeable (aspectRecordFull i)
&& iid /= iidId) kitAssRaw
ignoreCharges = True
case strongestMelee ignoreCharges 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 () -> ItemId -> ActorId -> ActorId -> Char -> m UseResult
effectActivateInv execSfx iidId source target symbol = do
let c = CActor target CInv
effectTransformContainer execSfx iidId symbol c $ \iid _ ->
kineticEffectAndDestroy True source target target iid c True
effectTransformContainer :: forall m. MonadServerAtomic m
=> m () -> ItemId -> Char -> Container
-> (ItemId -> ItemQuant -> m ())
-> m UseResult
effectTransformContainer execSfx iidId 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 <- filter ((/= iidId) . fst) <$> 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
effectVerbNoLonger :: MonadServerAtomic m
=> Bool -> m () -> ActorId -> m UseResult
effectVerbNoLonger useAllCopies execSfx source = do
b <- getsState $ getActorBody source
when (useAllCopies
&& not (bproj b)) $
execSfx
return UseUp
effectVerbMsg :: MonadServerAtomic m => m () -> ActorId -> m UseResult
effectVerbMsg execSfx source = do
b <- getsState $ getActorBody source
unless (bproj b) 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