module Game.LambdaHack.Server.EffectSem
(
itemEffect, effectSem
, createItems, addHero, spawnMonsters, pickFaction, electLeader, deduceKilled
) where
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.Server.Action
import Game.LambdaHack.Server.Config
import Game.LambdaHack.Server.State
import Control.Exception.Assert.Sugar
import Game.LambdaHack.Utils.Frequency
itemEffect :: (MonadAtomic m, MonadServer m)
=> ActorId -> ActorId -> Maybe ItemId -> Item
-> m ()
itemEffect source target miid item = do
sb <- getsState $ getActorBody source
discoS <- getsServer sdisco
let ik = fromJust $ jkind discoS item
ef = jeffect item
b <- effectSem ef source target
let atomic iid = execCmdAtomic $ DiscoverA (blid sb) (bpos sb) 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
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)
deduceKilled tb
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
execCmdAtomic $ LeadFactionA fid mleader mleaderNew
deduceKilled :: (MonadAtomic m, MonadServer m) => Actor -> m ()
deduceKilled body = do
let fid = bfid body
spawn <- getsState $ isSpawnFaction fid
summon <- getsState $ isSummonFaction fid
Config{configFirstDeathEnds} <- getsServer sconfig
mleader <- getsState $ gleader . (EM.! fid) . sfactionD
when (not spawn && not summon
&& (isNothing mleader || configFirstDeathEnds)) $
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=Kind.Ops{okind}} <- getsState scops
let kind = okind mk
speed = aspeed kind
m = actorTemplate mk bsymbol bname bcolor speed hp 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 configHeroNames 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
name | gcolor == Color.BrWhite =
fromMaybe ("Hero" <+> showT n) $ lookup n configHeroNames
| otherwise = playerName gplayer <+> "Hero" <+> showT n
startHP = hp (hp `div` 5) * min 3 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
replicateM_ n $ do
(item, k, _) <- rndToAction
$ newItem coitem flavour discoRev litemFreq ldepth depth
itemRev <- getsServer sitemRev
case HM.lookup item itemRev of
Just iid ->
execCmdAtomic $ CreateItemA iid item k (CFloor lid pos)
Nothing -> do
icounter <- getsServer sicounter
modifyServer $ \ser ->
ser { sicounter = succ icounter
, sitemRev = HM.insert item icounter (sitemRev ser) }
execCmdAtomic $ CreateItemA icounter item k (CFloor lid pos)
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
b <- effLvlGoUp target power
when b $ execSfxAtomic $ EffectD target $ Effect.Ascend power
return b
effLvlGoUp :: MonadAtomic m => ActorId -> Int -> m Bool
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
if lid2 == lid1 && pos2 == pos1 || bproj b1 then
return False
else do
inhabitants <- getsState $ posToActor pos2 lid2
case inhabitants of
Nothing ->
switchLevels1 aid
Just aid2 -> do
b2 <- getsState $ getActorBody aid2
ais2 <- getsState $ getActorItem aid2
let part2 = partActor b2
verb = "be pushed to another level"
msg2 = makeSentence [MU.SubjectVerbSg part2 verb]
execSfxAtomic $ MsgFidD (bfid b2) msg2
switchLevels1 aid
switchLevels1 aid2
switchLevels2 aid2 b2 ais2 lid1 pos1
switchLevels2 aid b1 ais1 lid2 pos2
!_ <- getsState $ posToActor pos1 lid1
!_ <- getsState $ posToActor pos2 lid2
return True
switchLevels1 :: MonadAtomic m => ActorId -> m ()
switchLevels1 aid = do
bOld <- getsState $ getActorBody aid
ais <- getsState $ getActorItem aid
let side = bfid bOld
mleader <- getsState $ gleader . (EM.! side) . sfactionD
when (isJust mleader) $
execCmdAtomic $ LeadFactionA side mleader Nothing
execCmdAtomic $ LoseActorA aid bOld ais
switchLevels2 :: MonadAtomic m
=> ActorId -> Actor -> [(ItemId, Item)] -> LevelId -> Point
-> m ()
switchLevels2 aid bOld ais lidNew posNew = 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
, bwait = timeZero
, bpos = posNew
, boldpos = posNew
, bpath = Nothing }
mleader <- getsState $ gleader . (EM.! side) . sfactionD
execCmdAtomic $ CreateActorA aid bNew ais
when (isNothing mleader) $
execCmdAtomic $ LeadFactionA side Nothing (Just aid)
effectEscape :: (MonadAtomic m, MonadServer m) => ActorId -> m Bool
effectEscape aid = do
b <- getsState $ getActorBody aid
let fid = bfid b
spawn <- getsState $ isSpawnFaction fid
summon <- getsState $ isSummonFaction fid
if spawn || summon || bproj b then return False
else do
deduceQuits b $ Status Escape (fromEnum $ blid b) ""
return True