{-# LANGUAGE TupleSections #-}
module Game.LambdaHack.Server.HandleEffectM
( applyItem, meleeEffectAndDestroy, effectAndDestroy, itemEffectEmbedded
, dropCStoreItem, dominateFidSfx, pickDroppable, cutCalm
) 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.Key (mapWithKeyM_)
import Game.LambdaHack.Atomic
import qualified Game.LambdaHack.Common.Ability as Ability
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 Game.LambdaHack.Common.ItemStrongest
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Perception
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.Request
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 qualified Game.LambdaHack.Content.TileKind as TK
import Game.LambdaHack.Server.CommonM
import Game.LambdaHack.Server.ItemM
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.PeriodicM
import Game.LambdaHack.Server.State
applyItem :: (MonadAtomic m, MonadServer 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 :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> ItemId -> m Bool
applyMeleeDamage source target iid = do
itemBase <- getsState $ getItemBody iid
if jdamage itemBase <= 0 then return False else do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
actorAspect <- getsServer sactorAspect
hurtMult <- getsState $ armorHurtBonus actorAspect source target
dmg <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) $ jdamage itemBase
let ar = actorAspect EM.! target
hpMax = aMaxHP ar
rawDeltaHP = fromIntegral hurtMult * xM dmg `divUp` 100
speedDeltaHP = case btrajectory sb of
Just (_, speed) -> - modifyDamageBySpeed rawDeltaHP speed
Nothing -> - rawDeltaHP
serious = speedDeltaHP < 0 && source /= target && not (bproj tb)
deltaHP | serious =
min speedDeltaHP (xM hpMax - bhp tb)
| otherwise = speedDeltaHP
if deltaHP < 0 then do
execUpdAtomic $ UpdRefillHP target deltaHP
when serious $ cutCalm target
return True
else return False
meleeEffectAndDestroy :: (MonadAtomic m, MonadServer 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
itemToF <- itemToFullServer
let itemFull = itemToF iid kit
case itemDisco itemFull of
Just ItemDisco {itemKind=IK.ItemKind{IK.ieffects}} ->
effectAndDestroy meleePerformed source target iid c False ieffects
itemFull
_ -> error $ "" `showFailure` (source, target, iid, c)
effectAndDestroy :: (MonadAtomic m, MonadServer m)
=> Bool -> ActorId -> ActorId -> ItemId -> Container -> Bool
-> [IK.Effect] -> ItemFull
-> m ()
effectAndDestroy meleePerformed _ _ iid container periodic []
itemFull@ItemFull{..} =
if meleePerformed then do
let (imperishable, kit) = imperishableKit [] periodic itemTimer itemFull
unless imperishable $
execUpdAtomic $ UpdLoseItem False iid itemBase kit container
else return ()
effectAndDestroy meleePerformed source target iid container periodic effs
itemFull@ItemFull{..} = do
let timeout = case itemDisco of
Just ItemDisco{itemAspect=Just ar} -> aTimeout ar
_ -> error $ "" `showFailure` itemDisco
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 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, kit) = imperishableKit effs periodic it2 itemFull
unless imperishable $
execUpdAtomic $ UpdLoseItem False iid itemBase kit container
triggeredEffect <-
itemEffectDisco source target iid container recharged periodic effs
let triggered = triggeredEffect || meleePerformed
sb <- getsState $ getActorBody source
unless (triggered
|| periodic
|| bproj sb
) $
execSfxAtomic $ SfxMsgFid (bfid sb) $
if any IK.forApplyEffect effs
then SfxFizzles
else SfxNothingHappens
unless (triggered || imperishable) $
execUpdAtomic $ UpdSpotItem False iid itemBase kit container
imperishableKit :: [IK.Effect] -> Bool -> ItemTimer -> ItemFull
-> (Bool, ItemQuant)
imperishableKit effs periodic it2 ItemFull{..} =
let 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
fragile = IK.Fragile `elem` jfeature itemBase
durable = IK.Durable `elem` jfeature itemBase
imperishable = durable && not fragile || periodic && permanent
kit = if permanent || periodic then (1, take 1 it2) else (itemK, it2)
in (imperishable, kit)
itemEffectEmbedded :: (MonadAtomic m, MonadServer m)
=> ActorId -> Point -> ItemBag -> m ()
itemEffectEmbedded aid tpos bag = do
sb <- getsState $ getActorBody aid
let c = CEmbed (blid sb) tpos
f iid = do
execSfxAtomic $ SfxTrigger aid tpos
meleeEffectAndDestroy aid aid iid c
mapM_ f $ EM.keys bag
itemEffectDisco :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> ItemId -> Container -> Bool -> Bool
-> [IK.Effect]
-> m Bool
itemEffectDisco source target iid c recharged periodic effs = do
discoKind <- getsServer sdiscoKind
item <- getsState $ getItemBody iid
case EM.lookup (jkindIx item) discoKind of
Just KindMean{kmKind} -> do
seed <- getsServer $ (EM.! iid) . sitemSeedD
execUpdAtomic $ UpdDiscover c iid kmKind seed
trs <- mapM (effectSem source target iid c recharged periodic) effs
let triggered = or trs
return triggered
_ -> error $ "" `showFailure` (source, target, iid, item)
effectSem :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> ItemId -> Container -> Bool -> Bool
-> IK.Effect
-> m Bool
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.ELabel _ -> return False
IK.EqpSlot _ -> return False
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 recursiveCall source target
IK.Impress -> effectImpress recursiveCall execSfx source target
IK.Summon grp p -> effectSummon execSfx grp p iid source target periodic
IK.Ascend p -> effectAscend recursiveCall execSfx p source target pos
IK.Escape{} -> effectEscape source target
IK.Paralyze p -> effectParalyze execSfx p target
IK.InsertMove p -> effectInsertMove execSfx p target
IK.Teleport p -> effectTeleport execSfx p 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 radius -> effectDetect execSfx radius target
IK.DetectActor radius -> effectDetectActor execSfx radius target
IK.DetectItem radius -> effectDetectItem execSfx radius target
IK.DetectExit radius -> effectDetectExit execSfx radius target
IK.DetectHidden radius -> effectDetectHidden execSfx 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 False
IK.Recharging e -> effectRecharging recursiveCall e recharged
IK.Temporary _ -> effectTemporary execSfx source iid c
IK.Unique -> return False
IK.Periodic -> return False
effectBurn :: (MonadAtomic m, MonadServer m)
=> Dice.Dice -> ActorId -> ActorId
-> m Bool
effectBurn nDm source target = do
tb <- getsState $ getActorBody target
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! target
hpMax = aMaxHP ar
n <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm
let rawDeltaHP = - xM n
serious = not (bproj tb) && source /= target && n > 1
deltaHP | serious =
min rawDeltaHP (xM hpMax - bhp tb)
| otherwise = rawDeltaHP
if deltaHP == 0
then return False
else do
sb <- getsState $ getActorBody source
let reportedEffect = IK.Burn $ Dice.intToDice n
execSfxAtomic $ SfxEffect (bfid sb) target reportedEffect deltaHP
execUpdAtomic $ UpdRefillHP target deltaHP
when serious $ cutCalm target
return True
effectExplode :: (MonadAtomic m, MonadServer m)
=> m () -> GroupName ItemKind -> ActorId -> m Bool
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 = fromEnum (jkindIx itemBase)
projectN k100 (n, _) = do
let veryrandom = k100 `xor` (semirandom + n)
fuzz = 5 + veryrandom `mod` 5
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
psAll =
[ Point (x - 12) (y + 12)
, Point (x + 12) (y + 12)
, Point (x - 12) (y - 12)
, Point (x + 12) (y - 12)
, Point (x - 12) y
, Point (x + 12) y
, Point x (y + 12)
, Point x (y - 12)
, 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
]
ps = take k psAll
forM_ ps $ \tpxy -> do
let req = ReqProject tpxy veryrandom iid COrgan
mfail <- projectFail target tpxy veryrandom 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 True
effectRefillHP :: (MonadAtomic m, MonadServer m)
=> Int -> ActorId -> ActorId -> m Bool
effectRefillHP power source target = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! target
hpMax = aMaxHP ar
serious = not (bproj tb) && source /= target && abs power > 1
deltaHP | power < 0 && serious =
min (xM power) (xM hpMax - bhp tb)
| otherwise = min (xM power) (max 0 $ xM 999 - bhp tb)
curChalSer <- getsServer $ scurChalSer . sdebugSer
fact <- getsState $ (EM.! bfid tb) . sfactionD
if | cfish curChalSer && power > 0
&& fhasUI (gplayer fact) && bfid sb /= bfid tb -> do
execSfxAtomic $ SfxMsgFid (bfid tb) SfxColdFish
return False
| deltaHP == 0 -> return False
| otherwise -> do
execSfxAtomic $ SfxEffect (bfid sb) target (IK.RefillHP power) deltaHP
execUpdAtomic $ UpdRefillHP target deltaHP
when (deltaHP < 0 && serious) $ cutCalm target
return True
cutCalm :: (MonadAtomic m, MonadServer m) => ActorId -> m ()
cutCalm target = do
tb <- getsState $ getActorBody target
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! target
upperBound = if hpTooLow tb ar
then 0
else xM $ aMaxCalm ar
deltaCalm = min minusM1 (upperBound - bcalm tb)
udpateCalm target deltaCalm
effectRefillCalm :: (MonadAtomic m, MonadServer m)
=> m () -> Int -> ActorId -> ActorId -> m Bool
effectRefillCalm execSfx power source target = do
tb <- getsState $ getActorBody target
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! target
calmMax = aMaxCalm ar
serious = not (bproj tb) && source /= target && power > 1
deltaCalm | power < 0 && serious =
min (xM power) (xM calmMax - bcalm tb)
| otherwise = min (xM power) (max 0 $ xM 999 - bcalm tb)
if deltaCalm == 0 then return False
else do
execSfx
udpateCalm target deltaCalm
return True
effectDominate :: (MonadAtomic m, MonadServer m)
=> (IK.Effect -> m Bool)
-> ActorId -> ActorId
-> m Bool
effectDominate recursiveCall source target = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
if | bproj tb -> return False
| bfid tb == bfid sb ->
recursiveCall IK.Impress
| otherwise -> dominateFidSfx (bfid sb) target
dominateFidSfx :: (MonadAtomic m, MonadServer m)
=> FactionId -> ActorId -> m Bool
dominateFidSfx fid target = do
tb <- getsState $ getActorBody target
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! target
actorMaxSk = aSkills ar
canMove = EM.findWithDefault 0 Ability.AbMove actorMaxSk > 0
&& EM.findWithDefault 0 Ability.AbAlter actorMaxSk
>= fromEnum TK.talterForStairs
if canMove && not (bproj tb) 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 :: (MonadAtomic m, MonadServer m) => FactionId -> ActorId -> m Bool
dominateFid fid target = do
Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops
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 $ getCarriedAssocs tb
actorAspect <- getsServer sactorAspect
getItem <- getsState $ flip getItemBody
discoKind <- getsServer sdiscoKind
let ar = actorAspect EM.! target
isImpression iid = case EM.lookup (jkindIx $ getItem iid) discoKind of
Just KindMean{kmKind} ->
maybe False (> 0) $ lookup "impressed" $ IK.ifreq (okind kmKind)
Nothing -> error $ "" `showFailure` 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 (aMaxCalm ar) `div` 2
, bhp = min (xM $ aMaxHP ar) $ bhp tb + xM 10
, borgan = borganNoImpression}
aisNew <- getsState $ getCarriedAssocs bNew
execUpdAtomic $ UpdSpotActor target bNew aisNew
modifyServer $ \ser ->
ser {sactorTime = updateActorTime fid (blid tb) target btime
$ sactorTime ser}
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
itemToF <- itemToFullServer
let discoverIf (iid, cstore) = do
let itemFull = itemToF iid (1, [])
c = CActor target cstore
discoverIfNoEffects c iid itemFull
aic = getCarriedIidCStore tb
mapM_ discoverIf aic
supplantLeader fid target
return False
effectImpress :: (MonadAtomic m, MonadServer m)
=> (IK.Effect -> m Bool) -> m () -> ActorId -> ActorId -> m Bool
effectImpress recursiveCall execSfx source target = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
if | bproj tb -> return False
| bfid tb == bfid sb -> do
res <- recursiveCall $ IK.DropItem 1 1 COrgan "impressed"
when res execSfx
return res
| otherwise -> do
execSfx
effectCreateItem (Just $ bfid sb) (Just 1) target COrgan
"impressed" IK.TimerNone
effectSummon :: (MonadAtomic m, MonadServer m)
=> m () -> GroupName ItemKind -> Dice.Dice -> ItemId
-> ActorId -> ActorId -> Bool
-> m Bool
effectSummon execSfx grp nDm iid source target periodic = do
Kind.COps{coTileSpeedup} <- getsState scops
power <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
actorAspect <- getsServer sactorAspect
item <- getsState $ getItemBody iid
let sar = actorAspect EM.! source
tar = actorAspect EM.! target
durable = IK.Durable `elem` jfeature item
deltaCalm = - xM 30
if (periodic || durable) && not (bproj sb)
&& (bcalm sb < - deltaCalm || not (calmEnough sb sar)) then do
unless (bproj sb) $
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxSummonLackCalm source
return False
else 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 $ bspeed tb tar
targetTime = timeShift localTime actorTurn
afterTime = timeShift targetTime $ Delta timeClip
bs <- forM (take power ps) $ \p -> do
maid <- addAnyActor [(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 $! or bs
effectAscend :: (MonadAtomic m, MonadServer m)
=> (IK.Effect -> m Bool)
-> m () -> Bool -> ActorId -> ActorId -> Point
-> m Bool
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 False
| 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 = 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 True
findStairExit :: MonadStateRead m
=> FactionId -> Bool -> LevelId -> Point -> m Point
findStairExit side moveUp lid pos = do
Kind.COps{coTileSpeedup} <- getsState scops
fact <- getsState $ (EM.! side) . sfactionD
lvl <- getLevel lid
let defLanding = uncurry Vector $ if moveUp then (-1, 0) else (1, 0)
(mvs2, mvs1) = break (== defLanding) moves
mvs = 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) : _ | isAtWar 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 :: MonadAtomic 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 $ getCarriedAssocs bOld
execUpdAtomic $ UpdLoseActor aid bOld ais
return mlead
switchLevels2 ::(MonadAtomic m, MonadServer 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 $ getCarriedAssocs bOld
execUpdAtomic $ UpdCreateActor aid bNew ais
let btime = shiftByDelta btime_bOld
modifyServer $ \ser ->
ser {sactorTime = updateActorTime (bfid bNew) lidNew aid btime
$ sactorTime ser}
case mlead of
Nothing -> return ()
Just leader -> supplantLeader side leader
effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> ActorId -> m Bool
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 False
| not (fcanEscape $ gplayer fact) -> do
execSfxAtomic $ SfxMsgFid (bfid sb) SfxEscapeImpossible
return False
| otherwise -> do
deduceQuits (bfid b) $ Status Escape (fromEnum $ blid b) Nothing
return True
effectParalyze :: (MonadAtomic m, MonadServer m)
=> m () -> Dice.Dice -> ActorId -> m Bool
effectParalyze execSfx nDm target = do
p <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm
b <- getsState $ getActorBody target
if bproj b || bhp b <= 0
then return False
else do
execSfx
let t = timeDeltaScale (Delta timeClip) p
modifyServer $ \ser ->
ser {sactorTime = ageActor (bfid b) (blid b) target t $ sactorTime ser}
return True
effectInsertMove :: (MonadAtomic m, MonadServer m)
=> m () -> Dice.Dice -> ActorId -> m Bool
effectInsertMove execSfx nDm target = do
execSfx
p <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm
b <- getsState $ getActorBody target
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! target
let actorTurn = ticksPerMeter $ bspeed b ar
t = timeDeltaScale actorTurn (-p)
modifyServer $ \ser ->
ser {sactorTime = ageActor (bfid b) (blid b) target t $ sactorTime ser}
return True
effectTeleport :: (MonadAtomic m, MonadServer m)
=> m () -> Dice.Dice -> ActorId -> ActorId -> m Bool
effectTeleport execSfx nDm source target = do
Kind.COps{coTileSpeedup} <- getsState scops
range <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm
sb <- getsState $ getActorBody source
b <- getsState $ getActorBody target
Level{ltile} <- getLevel (blid b)
let spos = bpos b
dMinMax delta pos =
let d = chessDist spos pos
in d >= range - delta && d <= range + delta
dist delta pos _ = dMinMax delta pos
lvl <- getLevel (blid b)
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 b -> do
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target
return False
| not (dMinMax 9 tpos) -> do
execSfxAtomic $ SfxMsgFid (bfid sb) SfxTransImpossible
return False
| otherwise -> do
execSfx
execUpdAtomic $ UpdMoveActor target spos tpos
return True
effectCreateItem :: (MonadAtomic m, MonadServer m)
=> Maybe FactionId -> Maybe Int -> ActorId -> CStore
-> GroupName ItemKind -> IK.TimerDice
-> m Bool
effectCreateItem jfidRaw mcount target store grp tim = do
tb <- getsState $ getActorBody target
delta <- case tim of
IK.TimerNone -> return $ Delta timeZero
IK.TimerGameTurn nDm -> do
k <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm
let !_A = assert (k >= 0) ()
return $! timeDeltaScale (Delta timeTurn) k
IK.TimerActorTurn nDm -> do
k <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm
let !_A = assert (k >= 0) ()
actorAspect <- getsServer sactorAspect
let ar = actorAspect EM.! target
actorTurn = ticksPerMeter $ bspeed tb ar
return $! timeDeltaScale actorTurn k
let c = CActor target store
bagBefore <- getsState $ getBodyStoreBag tb store
let litemFreq = [(grp, 1)]
m5 <- rollItem 0 (blid tb) litemFreq
let (itemKnownRaw, itemFullRaw, itemDisco, seed, _) =
fromMaybe (error $ "" `showFailure` (blid tb, litemFreq, c)) m5
jfid = if store == COrgan
&& IK.Identified `elem` IK.ifeature (itemKind itemDisco)
then jfidRaw
else Nothing
(itemKnown, itemFullFid) =
let (kindIx, ar, damage, _) = itemKnownRaw
in ( (kindIx, ar, damage, jfid)
, itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}} )
itemFull = case mcount of
Just itemK -> itemFullFid {itemK}
Nothing -> itemFullFid
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))) | tim /= IK.TimerNone -> do
let newIt = timer `timeShift` delta : rest
when (afterIt /= newIt) $ do
execUpdAtomic $ UpdTimeItem iid c afterIt newIt
execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxTimerExtended target iid store
_ -> do
iid <- registerItem itemFull itemKnown seed c True
when (store /= CGround) $ discoverIfNoEffects c iid itemFull
when (tim /= IK.TimerNone) $ 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 True
effectDropItem :: (MonadAtomic m, MonadServer m)
=> m () -> Int -> Int -> CStore -> GroupName ItemKind -> ActorId
-> m Bool
effectDropItem execSfx ngroup kcopy store grp target = do
b <- getsState $ getActorBody target
is <- allGroupItems store grp target
if null is then return False
else do
unless (store == COrgan) execSfx
mapM_ (uncurry (dropCStoreItem True store target b kcopy)) $ take ngroup is
return True
allGroupItems :: (MonadAtomic m, MonadServer m)
=> CStore -> GroupName ItemKind -> ActorId
-> m [(ItemId, ItemQuant)]
allGroupItems store grp target = do
Kind.COps{coitem=Kind.Ops{okind}} <- getsState scops
discoKind <- getsServer sdiscoKind
b <- getsState $ getActorBody target
let hasGroup (iid, _) = do
item <- getsState $ getItemBody iid
case EM.lookup (jkindIx item) discoKind of
Just KindMean{kmKind} ->
return $! maybe False (> 0) $ lookup grp $ IK.ifreq (okind kmKind)
Nothing ->
error $ "" `showFailure` (target, grp, iid, item)
assocsCStore <- getsState $ EM.assocs . getBodyStoreBag b store
filterM hasGroup assocsCStore
dropCStoreItem :: (MonadAtomic m, MonadServer m)
=> Bool -> CStore -> ActorId -> Actor -> Int
-> ItemId -> ItemQuant
-> m ()
dropCStoreItem verbose store aid b kMax iid kit@(k, _) = do
item <- getsState $ getItemBody iid
let c = CActor aid store
fragile = IK.Fragile `elem` jfeature item
durable = IK.Durable `elem` jfeature item
isDestroyed = bproj b && (bhp b <= 0 && not durable || fragile)
|| fragile && durable
if isDestroyed then do
itemToF <- itemToFullServer
let itemFull = itemToF iid kit
effs = strengthOnSmash itemFull
effectAndDestroy False aid aid iid c False effs itemFull
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
Kind.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 ps of
[] -> CActor aid CGround
pos : _ -> CFloor (blid b) pos
effectPolyItem :: (MonadAtomic m, MonadServer m)
=> m () -> ActorId -> ActorId -> m Bool
effectPolyItem execSfx source target = do
sb <- getsState $ getActorBody source
let cstore = CGround
allAssocs <- fullAssocsServer target [cstore]
case allAssocs of
[] -> do
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxPurposeNothing cstore
return False
(iid, itemFull@ItemFull{..}) : _ -> case itemDisco of
Just ItemDisco{itemKind, itemKindId} -> do
let maxCount = Dice.maxDice $ IK.icount itemKind
if | itemK < maxCount -> do
execSfxAtomic $ SfxMsgFid (bfid sb)
$ SfxPurposeTooFew maxCount itemK
return False
| IK.Unique `elem` IK.ieffects itemKind -> do
execSfxAtomic $ SfxMsgFid (bfid sb) SfxPurposeUnique
return False
| 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 "useful" IK.TimerNone
_ -> error $ "" `showFailure` (target, iid, itemFull)
effectIdentify :: (MonadAtomic m, MonadServer m)
=> m () -> ItemId -> ActorId -> ActorId -> m Bool
effectIdentify execSfx iidId source target = do
sb <- getsState $ getActorBody source
let tryFull store as = case as of
[] -> do
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxIdentifyNothing store
return False
(iid, _) : rest | iid == iidId -> tryFull store rest
(iid, ItemFull{itemDisco=Just ItemDisco{..}}) : rest -> do
let ided = IK.Identified `elem` IK.ifeature itemKind
statsObvious = Just itemAspectMean == itemAspect
if ided && statsObvious && not (null rest)
then tryFull store rest
else do
let c = CActor target store
execSfx
identifyIid iid c itemKindId
return True
_ -> error $ "" `showFailure` (store, as)
tryStore stores = case stores of
[] -> return False
store : rest -> do
allAssocs <- fullAssocsServer target [store]
go <- tryFull store allAssocs
if go then return True else tryStore rest
tryStore [CGround]
identifyIid :: (MonadAtomic m, MonadServer m)
=> ItemId -> Container -> Kind.Id ItemKind -> m ()
identifyIid iid c itemKindId = do
seed <- getsServer $ (EM.! iid) . sitemSeedD
execUpdAtomic $ UpdDiscover c iid itemKindId seed
effectDetect :: (MonadAtomic m, MonadServer m)
=> m () -> Int -> ActorId -> m Bool
effectDetect = effectDetectX (const True) (const $ return False)
effectDetectX :: (MonadAtomic m, MonadServer m)
=> (Point -> Bool) -> ([Point] -> m Bool)
-> m () -> Int -> ActorId -> m Bool
effectDetectX 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
perModified <- if nullPer inPer then return False else 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
return True
pointsModified <- action perList
if perModified || pointsModified then do
execSfx
when perModified $ do
modifyServer $ \ser -> ser {sperFid = sperFidOld}
execSendPer (bfid b) (blid b) inPer emptyPer perOld
else
execSfxAtomic $ SfxMsgFid (bfid b) SfxVoidDetection
return True
effectDetectActor :: (MonadAtomic m, MonadServer m)
=> m () -> Int -> ActorId -> m Bool
effectDetectActor execSfx radius target = do
b <- getsState $ getActorBody target
Level{lactor} <- getLevel $ blid b
effectDetectX (`EM.member` lactor) (const $ return False)
execSfx radius target
effectDetectItem :: (MonadAtomic m, MonadServer m)
=> m () -> Int -> ActorId -> m Bool
effectDetectItem execSfx radius target = do
b <- getsState $ getActorBody target
Level{lfloor} <- getLevel $ blid b
effectDetectX (`EM.member` lfloor) (const $ return False)
execSfx radius target
effectDetectExit :: (MonadAtomic m, MonadServer m)
=> m () -> Int -> ActorId -> m Bool
effectDetectExit execSfx radius target = do
b <- getsState $ getActorBody target
Level{lstair=(ls1, ls2), lescape} <- getLevel $ blid b
effectDetectX (`elem` ls1 ++ ls2 ++ lescape) (const $ return False)
execSfx radius target
effectDetectHidden :: (MonadAtomic m, MonadServer m)
=> m () -> Int -> ActorId -> Point -> m Bool
effectDetectHidden execSfx radius target pos = do
Kind.COps{coTileSpeedup} <- getsState scops
b <- getsState $ getActorBody target
lvl <- getLevel $ blid b
let predicate p = Tile.isHideAs coTileSpeedup $ lvl `at` p
action l = do
let f p = when (p /= pos)
$ execUpdAtomic $ UpdSearchTile target p $ lvl `at` p
mapM_ f l
return $! not $ null l
effectDetectX predicate action execSfx radius target
effectSendFlying :: (MonadAtomic m, MonadServer m)
=> m () -> IK.ThrowMod
-> ActorId -> ActorId -> Maybe Bool
-> m Bool
effectSendFlying execSfx IK.ThrowMod{..} source target modePush = do
v <- sendFlyingVector source target modePush
Kind.COps{coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
lvl@Level{lxsize, lysize} <- getLevel (blid tb)
let eps = 0
fpos = bpos tb `shift` v
if braced tb then do
execSfxAtomic $ SfxMsgFid (bfid sb) $ SfxBracedImmune target
return False
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
let t = lvl `at` pos
if not $ Tile.isWalkable coTileSpeedup t
then return False
else do
weightAssocs <- fullAssocsServer target [CInv, CEqp, COrgan]
let weight = sum $ map (jweight . itemBase . 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
|| throwVelocity <= 0 || throwLinger <= 0
then return False
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 True
sendFlyingVector :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> Maybe Bool -> m Vector
sendFlyingVector source target modePush = do
sb <- getsState $ getActorBody source
let boldpos_sb = fromMaybe originPoint (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 (sp, tp) = if adjacent (bpos sb) (bpos tb)
then let pos = if chessDist boldpos_sb (bpos tb)
> chessDist (bpos sb) (bpos tb)
then boldpos_sb
else bpos sb
in (pos, bpos tb)
else (bpos sb, bpos tb)
pushV = vectorToFrom tp sp
pullV = vectorToFrom sp tp
return $! case modePush of
Just True -> pushV
Just False -> pullV
Nothing | adjacent (bpos sb) (bpos tb) -> pushV
Nothing -> pullV
effectDropBestWeapon :: (MonadAtomic m, MonadServer m)
=> m () -> ActorId -> m Bool
effectDropBestWeapon execSfx target = do
tb <- getsState $ getActorBody target
localTime <- getsState $ getLocalTime (blid tb)
allAssocsRaw <- fullAssocsServer target [CEqp]
let allAssocs = filter (isMelee . itemBase . snd) allAssocsRaw
case strongestMelee Nothing localTime allAssocs of
(_, (iid, _)) : _ -> do
execSfx
let kit = beqp tb EM.! iid
dropCStoreItem True CEqp target tb 1 iid kit
return True
[] ->
return False
effectActivateInv :: (MonadAtomic m, MonadServer m)
=> m () -> ActorId -> Char -> m Bool
effectActivateInv execSfx target symbol =
effectTransformEqp execSfx target symbol CInv $ \iid _ -> do
let c = CActor target CInv
meleeEffectAndDestroy target target iid c
effectTransformEqp :: forall m. MonadAtomic m
=> m () -> ActorId -> Char -> CStore
-> (ItemId -> ItemQuant -> m ())
-> m Bool
effectTransformEqp execSfx target symbol cstore m = do
b <- getsState $ getActorBody target
let hasSymbol (iid, _) = do
item <- getsState $ getItemBody iid
return $! jsymbol item == symbol
assocsCStore <- getsState $ EM.assocs . getBodyStoreBag b cstore
is <- if symbol == ' '
then return assocsCStore
else filterM hasSymbol assocsCStore
if null is
then return False
else do
execSfx
mapM_ (uncurry m) is
return True
effectApplyPerfume :: MonadAtomic m
=> m () -> ActorId -> m Bool
effectApplyPerfume execSfx target = do
execSfx
tb <- getsState $ getActorBody target
Level{lsmell} <- getLevel $ blid tb
let f p fromSm =
execUpdAtomic $ UpdAlterSmell (blid tb) p fromSm timeZero
mapWithKeyM_ f lsmell
return True
effectOneOf :: (MonadAtomic m, MonadServer m)
=> (IK.Effect -> m Bool)
-> [IK.Effect]
-> m Bool
effectOneOf recursiveCall l = do
let call1 = do
ef <- rndToAction $ oneOf l
recursiveCall ef
call99 = replicate 99 call1
f callNext result = do
b <- result
if b then return True else callNext
foldr f (return False) call99
effectRecharging :: MonadAtomic m
=> (IK.Effect -> m Bool)
-> IK.Effect -> Bool
-> m Bool
effectRecharging recursiveCall e recharged =
if recharged
then recursiveCall e
else return False
effectTemporary :: MonadAtomic m
=> m () -> ActorId -> ItemId -> Container -> m Bool
effectTemporary execSfx source iid c =
case c of
CActor _ COrgan -> do
b <- getsState $ getActorBody source
case iid `EM.lookup` borgan b of
Just _ -> return ()
Nothing -> execSfx
return True
_ -> do
execSfx
return False