module Game.LambdaHack.Server.EffectSem
(
itemEffect, effectSem
, registerItem, createItems, addHero, spawnMonsters
, electLeader, deduceKilled
) where
import Control.Exception.Assert.Sugar
import Control.Monad
import qualified Data.Char as Char
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 Data.Ratio ((%))
import Data.Text (Text)
import qualified NLP.Miniutter.English as MU
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.AtomicCmd
import qualified Game.LambdaHack.Common.Color as Color
import qualified Game.LambdaHack.Common.Effect as Effect
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Common.State
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Content.ActorKind
import Game.LambdaHack.Content.FactionKind
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Server.Action
import Game.LambdaHack.Server.State
import Game.LambdaHack.Utils.Frequency
itemEffect :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> Maybe ItemId -> Item
-> m ()
itemEffect source target miid item = do
discoS <- getsServer sdisco
let ik = fromJust $ jkind discoS item
ef = jeffect item
b <- effectSem ef source target
postb <- getsState $ getActorBody source
let atomic iid = execCmdAtomic $ DiscoverA (blid postb) (bpos postb) iid ik
when b $ maybe skip atomic miid
effectSem :: (MonadAtomic m, MonadServer m)
=> Effect.Effect Int -> ActorId -> ActorId
-> m Bool
effectSem effect source target = case effect of
Effect.NoEffect -> effectNoEffect target
Effect.Heal p -> effectHeal p target
Effect.Hurt nDm p -> effectWound nDm p source target
Effect.Mindprobe _ -> effectMindprobe target
Effect.Dominate | source /= target -> effectDominate source target
Effect.Dominate -> effectSem (Effect.Mindprobe undefined) source target
Effect.CallFriend p -> effectCallFriend p source target
Effect.Summon p -> effectSummon p target
Effect.CreateItem p -> effectCreateItem p target
Effect.ApplyPerfume -> effectApplyPerfume source target
Effect.Regeneration p -> effectSem (Effect.Heal p) source target
Effect.Searching p -> effectSearching p source
Effect.Ascend p -> effectAscend p target
Effect.Escape{} -> effectEscape target
effectNoEffect :: MonadAtomic m => ActorId -> m Bool
effectNoEffect target = do
execSfxAtomic $ EffectD target Effect.NoEffect
return False
effectHeal :: MonadAtomic m
=> Int -> ActorId -> m Bool
effectHeal power target = do
Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops
tm <- getsState $ getActorBody target
let bhpMax = maxDice (ahp $ okind $ bkind tm)
if power > 0 && bhp tm >= bhpMax
then do
execSfxAtomic $ EffectD target Effect.NoEffect
return False
else do
let deltaHP = min power (bhpMax bhp tm)
execCmdAtomic $ HealActorA target deltaHP
execSfxAtomic $ EffectD target $ Effect.Heal deltaHP
return True
effectWound :: (MonadAtomic m, MonadServer m)
=> RollDice -> Int -> ActorId -> ActorId
-> m Bool
effectWound nDm power source target = do
n <- rndToAction $ castDice nDm
let deltaHP = (n + power)
if deltaHP >= 0
then do
execSfxAtomic $ EffectD target Effect.NoEffect
return False
else do
execCmdAtomic $ HealActorA target deltaHP
execSfxAtomic $ EffectD target $
if source == target
then Effect.Heal deltaHP
else Effect.Hurt nDm deltaHP
return True
effectMindprobe :: MonadAtomic m
=> ActorId -> m Bool
effectMindprobe target = do
tb <- getsState (getActorBody target)
let lid = blid tb
fact <- getsState $ (EM.! bfid tb) . sfactionD
lb <- getsState $ actorNotProjList (isAtWar fact) lid
let nEnemy = length lb
if nEnemy == 0 || bproj tb then do
execSfxAtomic $ EffectD target Effect.NoEffect
return False
else do
execSfxAtomic $ EffectD target $ Effect.Mindprobe nEnemy
return True
effectDominate :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> m Bool
effectDominate source target = do
sb <- getsState (getActorBody source)
tb <- getsState (getActorBody target)
if bfid tb == bfid sb || bproj tb then do
execSfxAtomic $ EffectD target Effect.NoEffect
return False
else do
execSfxAtomic $ EffectD target Effect.Dominate
electLeader (bfid tb) (blid tb) target
deduceKilled tb
ais <- getsState $ getActorItem target
execCmdAtomic $ LoseActorA target tb ais
let bNew = tb {bfid = bfid sb}
execCmdAtomic $ CreateActorA target bNew ais
leaderOld <- getsState $ gleader . (EM.! bfid sb) . sfactionD
let speed = bspeed bNew
delta = speedScale (1%2) speed
when (delta > speedZero) $
execCmdAtomic $ HasteActorA target (speedNegate delta)
execCmdAtomic $ LeadFactionA (bfid sb) leaderOld (Just target)
return True
electLeader :: MonadAtomic m => FactionId -> LevelId -> ActorId -> m ()
electLeader fid lid aidDead = do
mleader <- getsState $ gleader . (EM.! fid) . sfactionD
when (isNothing mleader || mleader == Just aidDead) $ do
actorD <- getsState sactorD
let ours (_, b) = bfid b == fid && not (bproj b)
party = filter ours $ EM.assocs actorD
onLevel <- getsState $ actorNotProjAssocs (== fid) lid
let mleaderNew = listToMaybe $ filter (/= aidDead)
$ map fst $ onLevel ++ party
unless (mleader == mleaderNew) $
execCmdAtomic $ LeadFactionA fid mleader mleaderNew
deduceKilled :: (MonadAtomic m, MonadServer m) => Actor -> m ()
deduceKilled body = do
cops@Kind.COps{corule} <- getsState scops
let firstDeathEnds = rfirstDeathEnds $ Kind.stdRuleset corule
fid = bfid body
spawn <- getsState $ isSpawnFaction fid
fact <- getsState $ (EM.! fid) . sfactionD
let horror = isHorrorFact cops fact
mleader <- getsState $ gleader . (EM.! fid) . sfactionD
when (not spawn && not horror
&& (isNothing mleader || firstDeathEnds)) $
deduceQuits body $ Status Killed (fromEnum $ blid body) ""
effectCallFriend :: (MonadAtomic m, MonadServer m)
=> Int -> ActorId -> ActorId
-> m Bool
effectCallFriend power source target = assert (power > 0) $ do
Kind.COps{cotile} <- getsState scops
sm <- getsState (getActorBody source)
tm <- getsState (getActorBody target)
ps <- getsState $ nearbyFreePoints cotile (const True) (bpos tm) (blid tm)
summonFriends (bfid sm) (take power ps) (blid tm)
return True
summonFriends :: (MonadAtomic m, MonadServer m)
=> FactionId -> [Point] -> LevelId
-> m ()
summonFriends bfid ps lid = do
Kind.COps{ coactor=coactor@Kind.Ops{opick}
, cofaction=Kind.Ops{okind} } <- getsState scops
time <- getsState $ getLocalTime lid
factionD <- getsState sfactionD
let fact = okind $ gkind $ factionD EM.! bfid
forM_ ps $ \p -> do
let summonName = fname fact
mk <- rndToAction $ fmap (fromMaybe $ assert `failure` summonName)
$ opick summonName (const True)
if mk == heroKindId coactor
then addHero bfid p lid [] Nothing time
else addMonster mk bfid p lid time
addActor :: (MonadAtomic m, MonadServer m)
=> Kind.Id ActorKind -> FactionId -> Point -> LevelId -> Int
-> Char -> Text -> Color.Color -> Time
-> m ActorId
addActor mk bfid pos lid hp bsymbol bname bcolor time = do
Kind.COps{coactor=coactor@Kind.Ops{okind}} <- getsState scops
Faction{gplayer} <- getsState $ (EM.! bfid) . sfactionD
DebugModeSer{sdifficultySer} <- getsServer sdebugSer
nU <- nUI
let diffHP | playerUI gplayer || nU == 0 && mk == heroKindId coactor =
(ceiling :: Double -> Int) $ fromIntegral hp * 1.5 ^^ sdifficultySer
| otherwise = hp
kind = okind mk
speed = aspeed kind
m = actorTemplate mk bsymbol bname bcolor speed diffHP
Nothing pos lid time bfid False
acounter <- getsServer sacounter
modifyServer $ \ser -> ser {sacounter = succ acounter}
execCmdAtomic $ CreateActorA acounter m []
return $! acounter
addHero :: (MonadAtomic m, MonadServer m)
=> FactionId -> Point -> LevelId -> [(Int, Text)] -> Maybe Int -> Time
-> m ActorId
addHero bfid ppos lid heroNames mNumber time = do
Kind.COps{coactor=coactor@Kind.Ops{okind}} <- getsState scops
Faction{gcolor, gplayer} <- getsState $ (EM.! bfid) . sfactionD
let kId = heroKindId coactor
hp <- rndToAction $ castDice $ ahp $ okind kId
mhs <- mapM (\n -> getsState $ \s -> tryFindHeroK s bfid n) [0..9]
let freeHeroK = elemIndex Nothing mhs
n = fromMaybe (fromMaybe 100 freeHeroK) mNumber
symbol = if n < 1 || n > 9 then '@' else Char.intToDigit n
nameFromNumber 0 = "Captain"
nameFromNumber k = "Hero" <+> tshow k
name | gcolor == Color.BrWhite =
fromMaybe (nameFromNumber n) $ lookup n heroNames
| otherwise =
playerName gplayer <+> nameFromNumber n
startHP = hp (min 10 $ hp `div` 10) * min 5 n
addActor kId bfid ppos lid startHP symbol name gcolor time
effectSummon :: (MonadAtomic m, MonadServer m)
=> Int -> ActorId -> m Bool
effectSummon power target = assert (power > 0) $ do
Kind.COps{cotile} <- getsState scops
tm <- getsState (getActorBody target)
ps <- getsState $ nearbyFreePoints cotile (const True) (bpos tm) (blid tm)
time <- getsState $ getLocalTime (blid tm)
mfid <- pickFaction "summon" (const True)
case mfid of
Nothing -> return False
Just fid -> do
spawnMonsters (take power ps) (blid tm) time fid
return True
spawnMonsters :: (MonadAtomic m, MonadServer m)
=> [Point] -> LevelId -> Time -> FactionId
-> m ()
spawnMonsters ps lid time fid = assert (not $ null ps) $ do
Kind.COps{coactor=Kind.Ops{opick}, cofaction=Kind.Ops{okind}} <- getsState scops
fact <- getsState $ (EM.! fid) . sfactionD
let spawnName = fname $ okind $ gkind fact
laid <- forM ps $ \ p -> do
mk <- rndToAction $ fmap (fromMaybe $ assert `failure` spawnName)
$ opick spawnName (const True)
addMonster mk fid p lid time
mleader <- getsState $ gleader . (EM.! fid) . sfactionD
when (isNothing mleader) $
execCmdAtomic $ LeadFactionA fid Nothing (Just $ head laid)
pickFaction :: MonadServer m
=> Text
-> ((FactionId, Faction) -> Bool)
-> m (Maybe FactionId)
pickFaction freqChoice ffilter = do
Kind.COps{cofaction=Kind.Ops{okind}} <- getsState scops
factionD <- getsState sfactionD
let f (fid, fact) = let kind = okind (gkind fact)
g n = (n, fid)
in fmap g $ lookup freqChoice $ ffreq kind
flist = mapMaybe f $ filter ffilter $ EM.assocs factionD
freq = toFreq ("pickFaction" <+> freqChoice) flist
if nullFreq freq then return Nothing
else fmap Just $ rndToAction $ frequency freq
addMonster :: (MonadAtomic m, MonadServer m)
=> Kind.Id ActorKind -> FactionId -> Point -> LevelId -> Time
-> m ActorId
addMonster mk bfid ppos lid time = do
Kind.COps{coactor=Kind.Ops{okind}} <- getsState scops
let kind = okind mk
hp <- rndToAction $ castDice $ ahp kind
addActor mk bfid ppos lid hp (asymbol kind) (aname kind) (acolor kind) time
effectCreateItem :: (MonadAtomic m, MonadServer m)
=> Int -> ActorId -> m Bool
effectCreateItem power target = assert (power > 0) $ do
tm <- getsState $ getActorBody target
void $ createItems power (bpos tm) (blid tm)
return True
createItems :: (MonadAtomic m, MonadServer m)
=> Int -> Point -> LevelId -> m ()
createItems n pos lid = do
Kind.COps{coitem} <- getsState scops
flavour <- getsServer sflavour
discoRev <- getsServer sdiscoRev
Level{ldepth, litemFreq} <- getLevel lid
depth <- getsState sdepth
let container = CFloor lid pos
replicateM_ n $ do
(item, k, _) <- rndToAction
$ newItem coitem flavour discoRev litemFreq ldepth depth
void $ registerItem item k container True
registerItem :: (MonadAtomic m, MonadServer m)
=> Item -> Int -> Container -> Bool -> m ItemId
registerItem item k container verbose = do
itemRev <- getsServer sitemRev
let cmd = if verbose then CreateItemA else SpotItemA
case HM.lookup item itemRev of
Just iid -> do
execCmdAtomic $ cmd iid item k container
return iid
Nothing -> do
icounter <- getsServer sicounter
modifyServer $ \ser ->
ser { sicounter = succ icounter
, sitemRev = HM.insert item icounter (sitemRev ser) }
execCmdAtomic $ cmd icounter item k container
return $! icounter
effectApplyPerfume :: MonadAtomic m
=> ActorId -> ActorId -> m Bool
effectApplyPerfume source target =
if source == target
then do
execSfxAtomic $ EffectD target Effect.NoEffect
return False
else do
tm <- getsState $ getActorBody target
Level{lsmell} <- getLevel $ blid tm
let f p fromSm =
execCmdAtomic $ AlterSmellA (blid tm) p (Just fromSm) Nothing
mapWithKeyM_ f lsmell
execSfxAtomic $ EffectD target Effect.ApplyPerfume
return True
effectSearching :: MonadAtomic m => Int -> ActorId -> m Bool
effectSearching power source = do
execSfxAtomic $ EffectD source $ Effect.Searching power
return True
effectAscend :: MonadAtomic m => Int -> ActorId -> m Bool
effectAscend power target = do
mfail <- effLvlGoUp target power
case mfail of
Nothing -> do
execSfxAtomic $ EffectD target $ Effect.Ascend power
return True
Just failMsg -> do
b <- getsState $ getActorBody target
execSfxAtomic $ MsgFidD (bfid b) failMsg
return False
effLvlGoUp :: MonadAtomic m => ActorId -> Int -> m (Maybe Msg)
effLvlGoUp aid k = do
b1 <- getsState $ getActorBody aid
ais1 <- getsState $ getActorItem aid
let lid1 = blid b1
pos1 = bpos b1
(lid2, pos2) <- getsState $ whereTo lid1 pos1 k . sdungeon
if lid2 == lid1 && pos2 == pos1 then
return $ Just "The effect fizzles: no more levels in this direction."
else if bproj b1 then
assert `failure` "projectiles can't exit levels" `twith` (aid, k, b1)
else do
let switch1 = switchLevels1 ((aid, b1), ais1)
switch2 = do
switchLevels2 lid2 pos2 ((aid, b1), ais1)
!_ <- getsState $ posToActors pos1 lid1
!_ <- getsState $ posToActors pos2 lid2
return Nothing
inhabitants <- getsState $ posToActors pos2 lid2
case inhabitants of
[] -> do
switch1
switch2
((_, b2), _) : _ -> do
let subjects = map (partActor . snd . fst) inhabitants
subject = MU.WWandW subjects
verb = "be pushed to another level"
msg2 = makeSentence [MU.SubjectVerbSg subject verb]
execSfxAtomic $ MsgFidD (bfid b2) msg2
switch1
mapM_ switchLevels1 inhabitants
mapM_ (switchLevels2 lid1 pos1) inhabitants
switch2
switchLevels1 :: MonadAtomic m => ((ActorId, Actor), [(ItemId, Item)]) -> m ()
switchLevels1 ((aid, bOld), ais) = do
let side = bfid bOld
mleader <- getsState $ gleader . (EM.! side) . sfactionD
when (not (bproj bOld) && isJust mleader) $
execCmdAtomic $ LeadFactionA side mleader Nothing
execCmdAtomic $ LoseActorA aid bOld ais
switchLevels2 :: MonadAtomic m
=> LevelId -> Point -> ((ActorId, Actor), [(ItemId, Item)])
-> m ()
switchLevels2 lidNew posNew ((aid, bOld), ais) = do
let lidOld = blid bOld
side = bfid bOld
assert (lidNew /= lidOld `blame` "stairs looped" `twith` lidNew) skip
timeOld <- getsState $ getLocalTime lidOld
timeLastVisited <- getsState $ getLocalTime lidNew
let delta = timeAdd (btime bOld) (timeNegate timeOld)
bNew = bOld { blid = lidNew
, btime = timeAdd timeLastVisited delta
, bpos = posNew
, boldpos = posNew
, boldlid = lidOld }
mleader <- getsState $ gleader . (EM.! side) . sfactionD
execCmdAtomic $ CreateActorA aid bNew ais
when (not (bproj bOld) && isNothing mleader) $
execCmdAtomic $ LeadFactionA side Nothing (Just aid)
effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> m Bool
effectEscape aid = do
cops <- getsState scops
b <- getsState $ getActorBody aid
let fid = bfid b
fact <- getsState $ (EM.! fid) . sfactionD
if not (isHeroFact cops fact) || bproj b then
return False
else do
deduceQuits b $ Status Escape (fromEnum $ blid b) ""
return True