module Game.LambdaHack.Server.HandleEffectServer
( applyItem, itemEffectAndDestroy, effectAndDestroy, itemEffectCause
, dropCStoreItem, armorHurtBonus
) where
import Control.Applicative
import Control.Exception.Assert.Sugar
import Control.Monad
import Data.Bits (xor)
import qualified Data.EnumMap.Strict as EM
import qualified Data.HashMap.Strict as HM
import Data.Key (mapWithKeyM_)
import Data.List
import Data.Maybe
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Atomic
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.ItemDescription
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.Msg
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.CommonServer
import Game.LambdaHack.Server.ItemServer
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.PeriodicServer
import Game.LambdaHack.Server.StartServer
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
itemEffectAndDestroy aid aid iid c
itemEffectAndDestroy :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> ItemId -> Container
-> m ()
itemEffectAndDestroy source target iid c = do
discoEffect <- getsServer sdiscoEffect
case EM.lookup iid discoEffect of
Just ItemAspectEffect{jeffects, jaspects} -> do
bag <- getsState $ getCBag c
case iid `EM.lookup` bag of
Nothing -> assert `failure` (source, target, iid, c)
Just kit ->
effectAndDestroy source target iid c False jeffects jaspects kit
_ -> assert `failure` (source, target, iid, c)
effectAndDestroy :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> ItemId -> Container -> Bool
-> [IK.Effect] -> [IK.Aspect Int] -> ItemQuant
-> m ()
effectAndDestroy source target iid c periodic effs aspects kitK@(k, it) = do
let mtimeout = let timeoutAspect :: IK.Aspect a -> Bool
timeoutAspect IK.Timeout{} = True
timeoutAspect _ = False
in find timeoutAspect aspects
lid <- getsState $ lidFromC c
localTime <- getsState $ getLocalTime lid
let it1 = case mtimeout of
Just (IK.Timeout timeout) ->
let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout
charging startT = timeShift startT timeoutTurns > localTime
in filter charging it
_ -> []
len = length it1
recharged = len < k
let !_A = assert (len <= k `blame` (kitK, source, target, iid, c)) ()
it2 <- case mtimeout of
Just (IK.Timeout _) | recharged ->
return $ localTime : it1
_ ->
return it1
it3 <- if it /= it2 && mtimeout /= Just (IK.Timeout 0) then do
execUpdAtomic $ UpdTimeItem iid c it it2
return it2
else return it
when (not periodic || recharged) $ do
let mtmp = let tmpEffect :: IK.Effect -> Bool
tmpEffect IK.Temporary{} = True
tmpEffect (IK.Recharging IK.Temporary{}) = True
tmpEffect (IK.OnSmash IK.Temporary{}) = True
tmpEffect _ = False
in find tmpEffect effs
item <- getsState $ getItemBody iid
let durable = IK.Durable `elem` jfeature item
imperishable = durable || periodic && isNothing mtmp
kit = if isNothing mtmp || periodic then (1, take 1 it3) else (k, it3)
unless imperishable $
execUpdAtomic $ UpdLoseItem iid item kit c
triggered <- itemEffectDisco source target iid c recharged periodic effs
unless (triggered || imperishable) $
execUpdAtomic $ UpdSpotItem iid item kit c
itemEffectCause :: (MonadAtomic m, MonadServer m)
=> ActorId -> Point -> IK.Effect
-> m Bool
itemEffectCause aid tpos ef = do
sb <- getsState $ getActorBody aid
let c = CEmbed (blid sb) tpos
bag <- getsState $ getCBag c
case EM.assocs bag of
[(iid, kit)] -> do
discoEffect <- getsServer sdiscoEffect
let aspects = case EM.lookup iid discoEffect of
Just ItemAspectEffect{jaspects} -> jaspects
_ -> assert `failure` (aid, tpos, ef, iid)
execSfxAtomic $ SfxTrigger aid tpos $ TK.Cause ef
effectAndDestroy aid aid iid c False [ef] aspects kit
return True
ab -> assert `failure` (aid, tpos, ab)
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 itemKindId -> do
seed <- getsServer $ (EM.! iid) . sitemSeedD
Level{ldepth} <- getLevel $ jlid item
execUpdAtomic $ UpdDiscover c iid itemKindId seed ldepth
itemEffect source target iid recharged periodic effs
_ -> assert `failure` (source, target, iid, item)
itemEffect :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> ItemId -> Bool -> Bool
-> [IK.Effect]
-> m Bool
itemEffect source target iid recharged periodic effects = do
trs <- mapM (effectSem source target iid recharged) effects
let triggered = or trs
sb <- getsState $ getActorBody source
unless (triggered
|| periodic
|| bproj sb) $
if null effects
then execSfxAtomic $ SfxMsgFid (bfid sb) "Nothing happens."
else execSfxAtomic $ SfxMsgFid (bfid sb) "It flashes and fizzles."
return triggered
effectSem :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> ItemId -> Bool -> IK.Effect
-> m Bool
effectSem source target iid recharged effect = do
let recursiveCall = effectSem source target iid recharged
sb <- getsState $ getActorBody source
let execSfx = execSfxAtomic $ SfxEffect (bfid sb) target effect
case effect of
IK.NoEffect _ -> return False
IK.Hurt nDm -> effectHurt nDm source target IK.RefillHP
IK.Burn nDm -> effectBurn nDm source target
IK.Explode t -> effectExplode execSfx t target
IK.RefillHP p -> effectRefillHP False execSfx p source target
IK.OverfillHP p -> effectRefillHP True execSfx p source target
IK.RefillCalm p -> effectRefillCalm False execSfx p source target
IK.OverfillCalm p -> effectRefillCalm True execSfx p source target
IK.Dominate -> effectDominate recursiveCall source target
IK.Impress -> effectImpress source target
IK.CallFriend p -> effectCallFriend execSfx p source target
IK.Summon freqs p -> effectSummon execSfx freqs p source target
IK.Ascend p -> effectAscend recursiveCall execSfx p source target
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 target store grp tim
IK.DropItem store grp hit -> effectDropItem execSfx store grp hit target
IK.PolyItem -> effectPolyItem execSfx source target
IK.Identify -> effectIdentify execSfx iid source target
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
effectHurt :: (MonadAtomic m, MonadServer m)
=> Dice.Dice -> ActorId -> ActorId -> (Int -> IK.Effect)
-> m Bool
effectHurt nDm source target verboseEffectConstructor = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
hpMax <- sumOrganEqpServer IK.EqpSlotAddMaxHP target
n <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm
hurtBonus <- armorHurtBonus source target
let mult = 100 + hurtBonus
rawDeltaHP = (max oneM
(fromIntegral mult * xM n `divUp` 100))
serious = source /= target && not (bproj tb)
deltaHP | serious =
min rawDeltaHP (xM hpMax bhp tb)
| otherwise = rawDeltaHP
deltaDiv = fromIntegral $ deltaHP `divUp` oneM
execUpdAtomic $ UpdRefillHP target deltaHP
when serious $ halveCalm target
execSfxAtomic $ SfxEffect (bfid sb) target $
if source == target
then verboseEffectConstructor deltaDiv
else IK.Hurt (Dice.intToDice ( deltaDiv))
return True
armorHurtBonus :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId
-> m Int
armorHurtBonus source target = do
sactiveItems <- activeItemsServer source
tactiveItems <- activeItemsServer target
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
let itemBonus =
if bproj sb
then sumSlotNoFilter IK.EqpSlotAddHurtRanged sactiveItems
sumSlotNoFilter IK.EqpSlotAddArmorRanged tactiveItems
else sumSlotNoFilter IK.EqpSlotAddHurtMelee sactiveItems
sumSlotNoFilter IK.EqpSlotAddArmorMelee tactiveItems
block = braced tb
return $! itemBonus if block then 50 else 0
halveCalm :: (MonadAtomic m, MonadServer m) => ActorId -> m ()
halveCalm target = do
tb <- getsState $ getActorBody target
activeItems <- activeItemsServer target
let calmMax = sumSlotNoFilter IK.EqpSlotAddMaxCalm activeItems
upperBound = if hpTooLow tb activeItems
then 0
else max (xM calmMax) (bcalm tb) `div` 2
deltaCalm = min minusTwoM (upperBound bcalm tb)
udpateCalm target deltaCalm
effectBurn :: (MonadAtomic m, MonadServer m)
=> Dice.Dice -> ActorId -> ActorId
-> m Bool
effectBurn nDm source target =
effectHurt nDm source target (\p -> IK.Burn $ Dice.intToDice (p))
effectExplode :: (MonadAtomic m, MonadServer m)
=> m () -> GroupName ItemKind -> ActorId -> m Bool
effectExplode execSfx cgroup target = do
tb <- getsState $ getActorBody target
let itemFreq = [(cgroup, 1)]
container = CActor target CEqp
m2 <- rollAndRegisterItem (blid tb) itemFreq container False Nothing
let (iid, (ItemFull{..}, _)) = fromMaybe (assert `failure` cgroup) m2
Point x y = bpos tb
projectN k100 (n, _) = do
let fuzz = 2 + (k100 `xor` (itemK * n)) `mod` 9
k | itemK >= 8 && n < 8 = 0
| n < 8 && n >= 4 = 4
| otherwise = n
psAll =
[ 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 $
if k >= 4 then psAll
else drop ((n + x + y + fromEnum iid * 7) `mod` 16)
$ cycle $ psAll ++ reverse psAll
forM_ ps $ \tpxy -> do
let req = ReqProject tpxy k100 iid CEqp
mfail <- projectFail target tpxy k100 iid CEqp True
case mfail of
Nothing -> return ()
Just ProjectBlockTerrain -> return ()
Just ProjectBlockActor | not $ bproj tb -> return ()
Just failMsg -> execFailure target req failMsg
forM_ [101..201] $ \k100 -> do
bag2 <- getsState $ beqp . getActorBody target
let mn2 = EM.lookup iid bag2
maybe (return ()) (projectN k100) mn2
bag3 <- getsState $ beqp . getActorBody target
let mn3 = EM.lookup iid bag3
maybe (return ()) (\kit -> execUpdAtomic
$ UpdLoseItem iid itemBase kit container) mn3
execSfx
return True
effectRefillHP :: (MonadAtomic m, MonadServer m)
=> Bool -> m () -> Int -> ActorId -> ActorId -> m Bool
effectRefillHP overfill execSfx power source target = do
tb <- getsState $ getActorBody target
hpMax <- sumOrganEqpServer IK.EqpSlotAddMaxHP target
let overMax | overfill = xM hpMax * 10
| otherwise = xM hpMax
serious = not (bproj tb) && source /= target && power > 1
deltaHP | power > 0 = min (xM power) (max 0 $ overMax bhp tb)
| serious =
min (xM power) (xM hpMax bhp tb)
| otherwise = xM power
if deltaHP == 0
then return False
else do
execUpdAtomic $ UpdRefillHP target deltaHP
execSfx
when (deltaHP < 0 && serious) $ halveCalm target
return True
effectRefillCalm :: (MonadAtomic m, MonadServer m)
=> Bool -> m () -> Int -> ActorId -> ActorId -> m Bool
effectRefillCalm overfill execSfx power source target = do
tb <- getsState $ getActorBody target
calmMax <- sumOrganEqpServer IK.EqpSlotAddMaxCalm target
let overMax | overfill = xM calmMax * 10
| otherwise = xM calmMax
serious = not (bproj tb) && source /= target && power > 1
deltaCalm | power > 0 = min (xM power) (max 0 $ overMax bcalm tb)
| serious =
min (xM power) (xM calmMax bcalm tb)
| otherwise = xM power
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 bfid tb == bfid sb then
recursiveCall IK.Impress
else
dominateFidSfx (bfid sb) target
effectImpress :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> m Bool
effectImpress source target = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
if bfidImpressed tb == bfid sb || bproj tb then
return False
else do
execUpdAtomic $ UpdFidImpressedActor target (bfidImpressed tb) (bfid sb)
return True
effectCallFriend :: (MonadAtomic m, MonadServer m)
=> m () -> Dice.Dice -> ActorId -> ActorId
-> m Bool
effectCallFriend execSfx nDm source target = do
Kind.COps{cotile} <- getsState scops
power <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
activeItems <- activeItemsServer target
if not $ hpEnough10 tb activeItems then do
unless (bproj tb) $ do
let subject = partActor tb
verb = "lack enough HP to call aid"
msg = makeSentence [MU.SubjectVerbSg subject verb]
execSfxAtomic $ SfxMsgFid (bfid sb) msg
return False
else do
let deltaHP = xM 10
execUpdAtomic $ UpdRefillHP target deltaHP
execSfx
let validTile t = not $ Tile.hasFeature cotile TK.NoActor t
ps <- getsState $ nearbyFreePoints validTile (bpos tb) (blid tb)
time <- getsState $ getLocalTime (blid tb)
recruitActors (take power ps) (blid tb) time (bfid tb)
effectSummon :: (MonadAtomic m, MonadServer m)
=> m () -> Freqs ItemKind -> Dice.Dice -> ActorId -> ActorId
-> m Bool
effectSummon execSfx actorFreq nDm source target = do
Kind.COps{cotile} <- getsState scops
power <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
activeItems <- activeItemsServer target
if not $ calmEnough10 tb activeItems then do
unless (bproj tb) $ do
let subject = partActor tb
verb = "lack enough Calm to summon"
msg = makeSentence [MU.SubjectVerbSg subject verb]
execSfxAtomic $ SfxMsgFid (bfid sb) msg
return False
else do
let deltaCalm = xM 10
unless (bproj tb) $ udpateCalm target deltaCalm
execSfx
let validTile t = not $ Tile.hasFeature cotile TK.NoActor t
ps <- getsState $ nearbyFreePoints validTile (bpos tb) (blid tb)
localTime <- getsState $ getLocalTime (blid tb)
let targetTime = timeShift localTime $ ticksPerMeter $ bspeed tb activeItems
afterTime = timeShift targetTime $ Delta timeClip
bs <- forM (take power ps) $ \p -> do
maid <- addAnyActor actorFreq (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) $
execUpdAtomic
$ UpdLeadFaction (bfid b) Nothing (Just (aid, Nothing))
return True
return $! or bs
effectAscend :: (MonadAtomic m, MonadServer m)
=> (IK.Effect -> m Bool)
-> m () -> Int -> ActorId -> ActorId
-> m Bool
effectAscend recursiveCall execSfx k source target = do
b1 <- getsState $ getActorBody target
let lid1 = blid b1
pos1 = bpos b1
(lid2, pos2) <- getsState $ whereTo lid1 pos1 k . sdungeon
sb <- getsState $ getActorBody source
if braced b1 then do
execSfxAtomic $ SfxMsgFid (bfid sb)
"Braced actors are immune to translocation."
return False
else if lid2 == lid1 && pos2 == pos1 then do
execSfxAtomic $ SfxMsgFid (bfid sb) "No more levels in this direction."
recursiveCall $ IK.Teleport 30
else do
let switch1 = void $ switchLevels1 (target, b1)
switch2 = do
let mlead = Just target
switchLevels2 lid2 pos2 (target, b1) mlead
!_ <- getsState $ posToActors pos1 lid1
!_ <- getsState $ posToActors pos2 lid2
return ()
inhabitants <- getsState $ posToActors pos2 lid2
case inhabitants of
[] -> do
switch1
switch2
(_, b2) : _ -> do
let subjects = map (partActor . snd) inhabitants
subject = MU.WWandW subjects
verb = "be pushed to another level"
msg2 = makeSentence [MU.SubjectVerbSg subject verb]
execSfxAtomic $ SfxMsgFid (bfid b2) msg2
switch1
let moveInh inh = do
inhMLead <- switchLevels1 inh
switchLevels2 lid1 pos1 inh inhMLead
mapM_ moveInh inhabitants
switch2
execSfx
return True
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 $ fst <$> mleader
else return Nothing
ais <- getsState $ getCarriedAssocs bOld
execUpdAtomic $ UpdLoseActor aid bOld ais
return mlead
switchLevels2 ::(MonadAtomic m, MonadServer m)
=> LevelId -> Point -> (ActorId, Actor) -> Maybe ActorId
-> m ()
switchLevels2 lidNew posNew (aid, bOld) mlead = do
let lidOld = blid bOld
side = bfid bOld
let !_A = assert (lidNew /= lidOld `blame` "stairs looped" `twith` 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)
setTimeout :: ItemBag -> ItemBag
setTimeout = EM.map computeNewTimeout
bNew = bOld { blid = lidNew
, btime = shiftByDelta $ btime bOld
, bpos = posNew
, boldpos = Just posNew
, boldlid = lidOld
, borgan = setTimeout $ borgan bOld
, beqp = setTimeout $ beqp bOld }
ais <- getsState $ getCarriedAssocs bOld
execUpdAtomic $ UpdCreateActor aid bNew ais
case mlead of
Nothing -> return ()
Just leader ->
execUpdAtomic $ UpdLeadFaction side Nothing (Just (leader, Nothing))
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 then
return False
else if not (fcanEscape $ gplayer fact) then do
execSfxAtomic $ SfxMsgFid (bfid sb)
"This faction doesn't want to escape outside."
return False
else do
deduceQuits fid Nothing $ 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
let t = timeDeltaScale (Delta timeClip) p
execUpdAtomic $ UpdAgeActor target t
execSfx
return True
effectInsertMove :: (MonadAtomic m, MonadServer m)
=> m () -> Dice.Dice -> ActorId -> m Bool
effectInsertMove execSfx nDm target = do
p <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm
b <- getsState $ getActorBody target
activeItems <- activeItemsServer target
let tpm = ticksPerMeter $ bspeed b activeItems
t = timeDeltaScale tpm (p)
execUpdAtomic $ UpdAgeActor target t
execSfx
return True
effectTeleport :: (MonadAtomic m, MonadServer m)
=> m () -> Dice.Dice -> ActorId -> ActorId -> m Bool
effectTeleport execSfx nDm source target = do
Kind.COps{cotile} <- getsState scops
range <- rndToAction $ castDice (AbsDepth 0) (AbsDepth 0) nDm
sb <- getsState $ getActorBody source
b <- getsState $ getActorBody target
Level{ltile} <- getLevel (blid b)
as <- getsState $ actorList (const True) (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
tpos <- rndToAction $ findPosTry 200 ltile
(\p t -> Tile.isWalkable cotile t
&& (not (dMinMax 9 p)
|| not (Tile.hasFeature cotile TK.NoActor t)
&& unoccupied as p))
[ dist 1
, dist $ 1 + range `div` 9
, dist $ 1 + range `div` 7
, dist $ 1 + range `div` 5
, dist 5
, dist 7
]
if braced b then do
execSfxAtomic $ SfxMsgFid (bfid sb)
"Braced actors are immune to translocation."
return False
else if not (dMinMax 9 tpos) then do
execSfxAtomic $ SfxMsgFid (bfid sb) "Translocation not possible."
return False
else do
execUpdAtomic $ UpdMoveActor target spos tpos
execSfx
return True
effectCreateItem :: (MonadAtomic m, MonadServer m)
=> ActorId -> CStore -> GroupName ItemKind -> IK.TimerDice
-> m Bool
effectCreateItem 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) ()
activeItems <- activeItemsServer target
let actorTurn = ticksPerMeter $ bspeed tb activeItems
return $! timeDeltaScale actorTurn k
let c = CActor target store
bagBefore <- getsState $ getCBag c
let litemFreq = [(grp, 1)]
m5 <- rollItem 0 (blid tb) litemFreq
let (itemKnown, itemFull, _, seed, _) =
fromMaybe (assert `failure` (blid tb, litemFreq, c)) m5
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, (1, afterIt@(timer : rest))) | tim /= IK.TimerNone -> do
let newIt = let halfTurns = delta `timeDeltaDiv` 2
newTimer = timer `timeShift` halfTurns
in newTimer : rest
when (afterIt /= newIt) $
execUpdAtomic $ UpdTimeItem iid c afterIt newIt
_ -> do
iid <- registerItem itemFull itemKnown seed (itemK itemFull) c True
unless (tim == IK.TimerNone) $ do
bagAfter <- getsState $ getCBag c
localTime <- getsState $ getLocalTime (blid tb)
let newTimer = localTime `timeShift` delta
(afterK, afterIt) =
fromMaybe (assert `failure` (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 () -> CStore -> GroupName ItemKind -> Bool -> ActorId
-> m Bool
effectDropItem execSfx store grp hit 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 kindId ->
return $! maybe False (> 0) $ lookup grp $ IK.ifreq (okind kindId)
Nothing ->
assert `failure` (target, grp, iid, item)
assocsCStore <- getsState $ EM.assocs . getActorBag target store
is <- filterM hasGroup assocsCStore
if null is
then return False
else do
mapM_ (uncurry (dropCStoreItem store target b hit)) is
unless (store == COrgan) execSfx
return True
dropCStoreItem :: (MonadAtomic m, MonadServer m)
=> CStore -> ActorId -> Actor -> Bool -> ItemId -> ItemQuant
-> m ()
dropCStoreItem store aid b hit 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 = hit && not durable || bproj b && fragile
if isDestroyed then do
discoEffect <- getsServer sdiscoEffect
let aspects = case EM.lookup iid discoEffect of
Just ItemAspectEffect{jaspects} -> jaspects
_ -> assert `failure` (aid, iid)
itemToF <- itemToFullServer
let itemFull = itemToF iid kit
effs = strengthOnSmash itemFull
effectAndDestroy aid aid iid c False effs aspects kit
else do
mvCmd <- generalMoveItem iid k (CActor aid store)
(CActor aid CGround)
mapM_ execUpdAtomic mvCmd
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) $
"The purpose of repurpose cannot be availed without an item"
<+> ppCStoreIn cstore <> "."
return False
(iid, itemFull@ItemFull{..}) : _ -> case itemDisco of
Just ItemDisco{..} -> do
discoEffect <- getsServer sdiscoEffect
let maxCount = Dice.maxDice $ IK.icount itemKind
aspects = jaspects $ discoEffect EM.! iid
if itemK < maxCount then do
execSfxAtomic $ SfxMsgFid (bfid sb) $
"The purpose of repurpose is served by" <+> tshow maxCount
<+> "pieces of this item, not by" <+> tshow itemK <> "."
return False
else if IK.Unique `elem` aspects then do
execSfxAtomic $ SfxMsgFid (bfid sb)
"Unique items can't be repurposed."
return False
else do
let c = CActor target cstore
kit = (maxCount, take maxCount itemTimer)
identifyIid execSfx iid c itemKindId
execUpdAtomic $ UpdDestroyItem iid itemBase kit c
effectCreateItem target cstore "useful" IK.TimerNone
_ -> assert `failure` (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
let (tIn, t) = ppCStore store
msg = "Nothing to identify" <+> tIn <+> t <> "."
execSfxAtomic $ SfxMsgFid (bfid sb) msg
return False
(iid, _) : rest | iid == iidId -> tryFull store rest
(iid, itemFull@ItemFull{itemDisco=Just ItemDisco{..}}) : rest -> do
let ided = IK.Identified `elem` IK.ifeature itemKind
itemSecret = itemNoAE itemFull
statsObvious = textAllAE 7 False store itemFull
== textAllAE 7 False store itemSecret
if ided && statsObvious
then tryFull store rest
else do
let c = CActor target store
identifyIid execSfx iid c itemKindId
return True
_ -> assert `failure` (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)
=> m () -> ItemId -> Container -> Kind.Id ItemKind
-> m ()
identifyIid execSfx iid c itemKindId = do
execSfx
seed <- getsServer $ (EM.! iid) . sitemSeedD
item <- getsState $ getItemBody iid
Level{ldepth} <- getLevel $ jlid item
execUpdAtomic $ UpdDiscover c iid itemKindId seed ldepth
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{cotile} <- 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)
"Braced actors are immune to translocation."
return False
else case bla lxsize lysize eps (bpos tb) fpos of
Nothing -> assert `failure` (fpos, tb)
Just [] -> assert `failure` "projecting from the edge of level"
`twith` (fpos, tb)
Just (pos : rest) -> do
let t = lvl `at` pos
if not $ Tile.isWalkable cotile 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, _)) =
computeTrajectory weight throwVelocity throwLinger path
ts = Just (trajectory, speed)
if null trajectory || btrajectory tb == ts
|| throwVelocity <= 0 || throwLinger <= 0
then return False
else do
execUpdAtomic $ UpdTrajectory target (btrajectory tb) ts
activeItems <- activeItemsServer target
let tpm = ticksPerMeter $ bspeed tb activeItems
delta = timeDeltaScale tpm (1)
execUpdAtomic $ UpdAgeActor target delta
execSfx
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 (Point 0 0) (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
allAssocs <- fullAssocsServer target [CEqp]
localTime <- getsState $ getLocalTime (blid tb)
case strongestMelee False localTime allAssocs of
(_, (iid, _)) : _ -> do
let kit = beqp tb EM.! iid
dropCStoreItem CEqp target tb False iid kit
execSfx
return True
[] ->
return False
effectActivateInv :: (MonadAtomic m, MonadServer m)
=> m () -> ActorId -> Char -> m Bool
effectActivateInv execSfx target symbol =
effectTransformEqp execSfx target symbol CInv $ \iid _ ->
applyItem target iid CInv
effectTransformEqp :: forall m. (MonadAtomic m, MonadServer m)
=> m () -> ActorId -> Char -> CStore
-> (ItemId -> ItemQuant -> m ())
-> m Bool
effectTransformEqp execSfx target symbol cstore m = do
let hasSymbol (iid, _) = do
item <- getsState $ getItemBody iid
return $! jsymbol item == symbol
assocsCStore <- getsState $ EM.assocs . getActorBag target cstore
is <- if symbol == ' '
then return assocsCStore
else filterM hasSymbol assocsCStore
if null is
then return False
else do
mapM_ (uncurry m) is
execSfx
return True
effectApplyPerfume :: (MonadAtomic m, MonadServer m)
=> m () -> ActorId -> m Bool
effectApplyPerfume execSfx target = do
tb <- getsState $ getActorBody target
Level{lsmell} <- getLevel $ blid tb
let f p fromSm =
execUpdAtomic $ UpdAlterSmell (blid tb) p (Just fromSm) Nothing
mapWithKeyM_ f lsmell
execSfx
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, MonadServer 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, MonadServer m)
=> m () -> ActorId -> ItemId
-> m Bool
effectTemporary execSfx source iid = do
bag <- getsState $ getCBag $ CActor source COrgan
case iid `EM.lookup` bag of
Just _ -> return ()
Nothing -> execSfx
return True